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 0]
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 1]
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 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
419 lset vdownptr
($v) $oa $na
420 lset vlastins
($v) $oa 0
421 lappend vupptr
($v) $oa
422 lappend vleftptr
($v) 0
423 lappend vbackptr
($v) 0
424 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
425 lset vupptr
($v) $b $na
429 proc renumbervarc
{a v
} {
430 global parents children varctok varcstart varccommits
431 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
433 set t1
[clock clicks
-milliseconds]
439 if {[info exists isrelated
($a)]} {
441 set id
[lindex
$varccommits($v,$a) end
]
442 foreach p
$parents($v,$id) {
443 if {[info exists varcid
($v,$p)]} {
444 set isrelated
($varcid($v,$p)) 1
449 set b
[lindex
$vdownptr($v) $a]
452 set b
[lindex
$vleftptr($v) $a]
454 set a
[lindex
$vupptr($v) $a]
460 if {![info exists kidchanged
($a)]} continue
461 set id
[lindex
$varcstart($v) $a]
462 if {[llength
$children($v,$id)] > 1} {
463 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
466 set oldtok
[lindex
$varctok($v) $a]
473 set kid
[last_real_child
$v,$id]
475 set k
$varcid($v,$kid)
476 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
479 set tok
[lindex
$varctok($v) $k]
483 set i
[lsearch
-exact $parents($v,$ki) $id]
484 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
485 append tok
[strrep
$j]
487 if {$tok eq
$oldtok} {
490 set id
[lindex
$varccommits($v,$a) end
]
491 foreach p
$parents($v,$id) {
492 if {[info exists varcid
($v,$p)]} {
493 set kidchanged
($varcid($v,$p)) 1
498 lset varctok
($v) $a $tok
499 set b
[lindex
$vupptr($v) $a]
501 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
504 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
507 set c
[lindex
$vbackptr($v) $a]
508 set d
[lindex
$vleftptr($v) $a]
510 lset vdownptr
($v) $b $d
512 lset vleftptr
($v) $c $d
515 lset vbackptr
($v) $d $c
517 if {[lindex
$vlastins($v) $b] == $a} {
518 lset vlastins
($v) $b $c
520 lset vupptr
($v) $a $ka
521 set c
[lindex
$vlastins($v) $ka]
523 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
525 set b
[lindex
$vdownptr($v) $ka]
527 set b
[lindex
$vleftptr($v) $c]
530 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
532 set b
[lindex
$vleftptr($v) $c]
535 lset vdownptr
($v) $ka $a
536 lset vbackptr
($v) $a 0
538 lset vleftptr
($v) $c $a
539 lset vbackptr
($v) $a $c
541 lset vleftptr
($v) $a $b
543 lset vbackptr
($v) $b $a
545 lset vlastins
($v) $ka $a
548 foreach id
[array names sortkids
] {
549 if {[llength
$children($v,$id)] > 1} {
550 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
554 set t2
[clock clicks
-milliseconds]
555 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
558 # Fix up the graph after we have found out that in view $v,
559 # $p (a commit that we have already seen) is actually the parent
560 # of the last commit in arc $a.
561 proc fix_reversal
{p a v
} {
562 global varcid varcstart varctok vupptr
564 set pa
$varcid($v,$p)
565 if {$p ne
[lindex
$varcstart($v) $pa]} {
567 set pa
$varcid($v,$p)
569 # seeds always need to be renumbered
570 if {[lindex
$vupptr($v) $pa] == 0 ||
571 [string compare
[lindex
$varctok($v) $a] \
572 [lindex
$varctok($v) $pa]] > 0} {
577 proc insertrow
{id p v
} {
578 global cmitlisted children parents varcid varctok vtokmod
579 global varccommits ordertok commitidx numcommits curview
580 global targetid targetrow
584 set cmitlisted
($vid) 1
585 set children
($vid) {}
586 set parents
($vid) [list
$p]
587 set a
[newvarc
$v $id]
589 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
592 lappend varccommits
($v,$a) $id
594 if {[llength
[lappend children
($vp) $id]] > 1} {
595 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
596 catch
{unset ordertok
}
598 fix_reversal
$p $a $v
600 if {$v == $curview} {
601 set numcommits
$commitidx($v)
603 if {[info exists targetid
]} {
604 if {![comes_before
$targetid $p]} {
611 proc insertfakerow
{id p
} {
612 global varcid varccommits parents children cmitlisted
613 global commitidx varctok vtokmod targetid targetrow curview numcommits
617 set i
[lsearch
-exact $varccommits($v,$a) $p]
619 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
622 set children
($v,$id) {}
623 set parents
($v,$id) [list
$p]
624 set varcid
($v,$id) $a
625 lappend children
($v,$p) $id
626 set cmitlisted
($v,$id) 1
627 set numcommits
[incr commitidx
($v)]
628 # note we deliberately don't update varcstart($v) even if $i == 0
629 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
630 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
633 if {[info exists targetid
]} {
634 if {![comes_before
$targetid $p]} {
642 proc removefakerow
{id
} {
643 global varcid varccommits parents children commitidx
644 global varctok vtokmod cmitlisted currentid selectedline
645 global targetid curview numcommits
648 if {[llength
$parents($v,$id)] != 1} {
649 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
652 set p
[lindex
$parents($v,$id) 0]
653 set a
$varcid($v,$id)
654 set i
[lsearch
-exact $varccommits($v,$a) $id]
656 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
660 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
661 unset parents
($v,$id)
662 unset children
($v,$id)
663 unset cmitlisted
($v,$id)
664 set numcommits
[incr commitidx
($v) -1]
665 set j
[lsearch
-exact $children($v,$p) $id]
667 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
669 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
672 if {[info exist currentid
] && $id eq
$currentid} {
676 if {[info exists targetid
] && $targetid eq
$id} {
683 proc first_real_child
{vp
} {
684 global children nullid nullid2
686 foreach id
$children($vp) {
687 if {$id ne
$nullid && $id ne
$nullid2} {
694 proc last_real_child
{vp
} {
695 global children nullid nullid2
697 set kids
$children($vp)
698 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
699 set id
[lindex
$kids $i]
700 if {$id ne
$nullid && $id ne
$nullid2} {
707 proc vtokcmp
{v a b
} {
708 global varctok varcid
710 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
711 [lindex
$varctok($v) $varcid($v,$b)]]
714 proc modify_arc
{v a
{lim
{}}} {
715 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
717 set vtokmod
($v) [lindex
$varctok($v) $a]
719 if {$v == $curview} {
720 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
721 set a
[lindex
$vupptr($v) $a]
727 set lim
[llength
$varccommits($v,$a)]
729 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
736 proc update_arcrows
{v
} {
737 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
738 global varcid vrownum varcorder varcix varccommits
739 global vupptr vdownptr vleftptr varctok
740 global displayorder parentlist curview cached_commitrow
742 set narctot
[expr {[llength
$varctok($v)] - 1}]
744 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
745 # go up the tree until we find something that has a row number,
746 # or we get to a seed
747 set a
[lindex
$vupptr($v) $a]
750 set a
[lindex
$vdownptr($v) 0]
753 set varcorder
($v) [list
$a]
755 lset varcrow
($v) $a 0
759 set arcn
[lindex
$varcix($v) $a]
760 # see if a is the last arc; if so, nothing to do
761 if {$arcn == $narctot - 1} {
764 if {[llength
$vrownum($v)] > $arcn + 1} {
765 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
766 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
768 set row
[lindex
$varcrow($v) $a]
770 if {$v == $curview} {
771 if {[llength
$displayorder] > $vrowmod($v)} {
772 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
773 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
775 catch
{unset cached_commitrow
}
779 incr row
[llength
$varccommits($v,$a)]
780 # go down if possible
781 set b
[lindex
$vdownptr($v) $a]
783 # if not, go left, or go up until we can go left
785 set b
[lindex
$vleftptr($v) $a]
787 set a
[lindex
$vupptr($v) $a]
793 lappend vrownum
($v) $row
794 lappend varcorder
($v) $a
795 lset varcix
($v) $a $arcn
796 lset varcrow
($v) $a $row
798 set vtokmod
($v) [lindex
$varctok($v) $p]
801 if {[info exists currentid
]} {
802 set selectedline
[rowofcommit
$currentid]
806 # Test whether view $v contains commit $id
807 proc commitinview
{id v
} {
810 return [info exists varcid
($v,$id)]
813 # Return the row number for commit $id in the current view
814 proc rowofcommit
{id
} {
815 global varcid varccommits varcrow curview cached_commitrow
816 global varctok vtokmod
819 if {![info exists varcid
($v,$id)]} {
820 puts
"oops rowofcommit no arc for [shortids $id]"
823 set a
$varcid($v,$id)
824 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
827 if {[info exists cached_commitrow
($id)]} {
828 return $cached_commitrow($id)
830 set i
[lsearch
-exact $varccommits($v,$a) $id]
832 puts
"oops didn't find commit [shortids $id] in arc $a"
835 incr i
[lindex
$varcrow($v) $a]
836 set cached_commitrow
($id) $i
840 # Returns 1 if a is on an earlier row than b, otherwise 0
841 proc comes_before
{a b
} {
842 global varcid varctok curview
845 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
846 ![info exists varcid
($v,$b)]} {
849 if {$varcid($v,$a) != $varcid($v,$b)} {
850 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
851 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
853 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
856 proc bsearch
{l elt
} {
857 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
862 while {$hi - $lo > 1} {
863 set mid
[expr {int
(($lo + $hi) / 2)}]
864 set t
[lindex
$l $mid]
867 } elseif
{$elt > $t} {
876 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
877 proc make_disporder
{start end
} {
878 global vrownum curview commitidx displayorder parentlist
879 global varccommits varcorder parents vrowmod varcrow
880 global d_valid_start d_valid_end
882 if {$end > $vrowmod($curview)} {
883 update_arcrows
$curview
885 set ai
[bsearch
$vrownum($curview) $start]
886 set start
[lindex
$vrownum($curview) $ai]
887 set narc
[llength
$vrownum($curview)]
888 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
889 set a
[lindex
$varcorder($curview) $ai]
890 set l
[llength
$displayorder]
891 set al
[llength
$varccommits($curview,$a)]
894 set pad
[ntimes
[expr {$r - $l}] {}]
895 set displayorder
[concat
$displayorder $pad]
896 set parentlist
[concat
$parentlist $pad]
898 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
899 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
901 foreach id
$varccommits($curview,$a) {
902 lappend displayorder
$id
903 lappend parentlist
$parents($curview,$id)
905 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
907 foreach id
$varccommits($curview,$a) {
908 lset displayorder
$i $id
909 lset parentlist
$i $parents($curview,$id)
917 proc commitonrow
{row
} {
920 set id
[lindex
$displayorder $row]
922 make_disporder
$row [expr {$row + 1}]
923 set id
[lindex
$displayorder $row]
928 proc closevarcs
{v
} {
929 global varctok varccommits varcid parents children
930 global cmitlisted commitidx commitinterest vtokmod
932 set missing_parents
0
934 set narcs
[llength
$varctok($v)]
935 for {set a
1} {$a < $narcs} {incr a
} {
936 set id
[lindex
$varccommits($v,$a) end
]
937 foreach p
$parents($v,$id) {
938 if {[info exists varcid
($v,$p)]} continue
939 # add p as a new commit
941 set cmitlisted
($v,$p) 0
942 set parents
($v,$p) {}
943 if {[llength
$children($v,$p)] == 1 &&
944 [llength
$parents($v,$id)] == 1} {
947 set b
[newvarc
$v $p]
950 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
953 lappend varccommits
($v,$b) $p
955 if {[info exists commitinterest
($p)]} {
956 foreach
script $commitinterest($p) {
957 lappend scripts
[string map
[list
"%I" $p] $script]
959 unset commitinterest
($id)
963 if {$missing_parents > 0} {
970 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
971 # Assumes we already have an arc for $rwid.
972 proc rewrite_commit
{v id rwid
} {
973 global children parents varcid varctok vtokmod varccommits
975 foreach ch
$children($v,$id) {
976 # make $rwid be $ch's parent in place of $id
977 set i
[lsearch
-exact $parents($v,$ch) $id]
979 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
981 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
982 # add $ch to $rwid's children and sort the list if necessary
983 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
984 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
987 # fix the graph after joining $id to $rwid
988 set a
$varcid($v,$ch)
989 fix_reversal
$rwid $a $v
990 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
991 # parentlist is wrong for the last element of arc $a
992 # even if displayorder is right, hence the 3rd arg here
993 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
998 proc getcommitlines
{fd inst view updating
} {
999 global cmitlisted commitinterest leftover
1000 global commitidx commitdata datemode
1001 global parents children curview hlview
1002 global vnextroot idpending ordertok
1003 global varccommits varcid varctok vtokmod viewfiles
1005 set stuff
[read $fd 500000]
1006 # git log doesn't terminate the last commit with a null...
1007 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1014 global commfd viewcomplete viewactive viewname progresscoords
1015 global viewinstances
1017 set i
[lsearch
-exact $viewinstances($view) $inst]
1019 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1021 # set it blocking so we wait for the process to terminate
1022 fconfigure
$fd -blocking 1
1023 if {[catch
{close
$fd} err
]} {
1025 if {$view != $curview} {
1026 set fv
" for the \"$viewname($view)\" view"
1028 if {[string range
$err 0 4] == "usage"} {
1029 set err
"Gitk: error reading commits$fv:\
1030 bad arguments to git rev-list."
1031 if {$viewname($view) eq
"Command line"} {
1033 " (Note: arguments to gitk are passed to git rev-list\
1034 to allow selection of commits to be displayed.)"
1037 set err
"Error reading commits$fv: $err"
1041 if {[incr viewactive
($view) -1] <= 0} {
1042 set viewcomplete
($view) 1
1043 # Check if we have seen any ids listed as parents that haven't
1044 # appeared in the list
1047 set progresscoords
{0 0}
1050 if {$view == $curview} {
1051 run chewcommits
$view
1059 set i
[string first
"\0" $stuff $start]
1061 append leftover
($inst) [string range
$stuff $start end
]
1065 set cmit
$leftover($inst)
1066 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1067 set leftover
($inst) {}
1069 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1071 set start
[expr {$i + 1}]
1072 set j
[string first
"\n" $cmit]
1075 if {$j >= 0 && [string match
"commit *" $cmit]} {
1076 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1077 if {[string match
{[-^
<>]*} $ids]} {
1078 switch
-- [string index
$ids 0] {
1084 set ids
[string range
$ids 1 end
]
1088 if {[string length
$id] != 40} {
1096 if {[string length
$shortcmit] > 80} {
1097 set shortcmit
"[string range $shortcmit 0 80]..."
1099 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1102 set id [lindex $ids 0]
1105 if {!$listed && $updating && ![info exists varcid($vid)] &&
1106 $viewfiles($view) ne {}} {
1107 # git log doesn't rewrite parents
for unlisted commits
1108 # when doing path limiting, so work around that here
1109 # by working out the rewritten parent with git rev-list
1110 # and if we already know about it, using the rewritten
1111 # parent as a substitute parent for $id's children.
1113 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1114 $id -- $viewfiles($view)]
1116 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1117 # use $rwid in place of $id
1118 rewrite_commit
$view $id $rwid
1125 if {[info exists varcid
($vid)]} {
1126 if {$cmitlisted($vid) ||
!$listed} continue
1130 set olds
[lrange
$ids 1 end
]
1134 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1135 set cmitlisted
($vid) $listed
1136 set parents
($vid) $olds
1137 if {![info exists children
($vid)]} {
1138 set children
($vid) {}
1139 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1140 set k
[lindex
$children($vid) 0]
1141 if {[llength
$parents($view,$k)] == 1 &&
1143 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1144 set a
$varcid($view,$k)
1149 set a
[newvarc
$view $id]
1151 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1154 if {![info exists varcid
($vid)]} {
1156 lappend varccommits
($view,$a) $id
1157 incr commitidx
($view)
1162 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1164 if {[llength
[lappend children
($vp) $id]] > 1 &&
1165 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1166 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1168 catch
{unset ordertok
}
1170 if {[info exists varcid
($view,$p)]} {
1171 fix_reversal
$p $a $view
1177 if {[info exists commitinterest
($id)]} {
1178 foreach
script $commitinterest($id) {
1179 lappend scripts
[string map
[list
"%I" $id] $script]
1181 unset commitinterest
($id)
1186 run chewcommits
$view
1187 foreach s
$scripts {
1190 if {$view == $curview} {
1191 # update progress bar
1192 global progressdirn progresscoords proglastnc
1193 set inc
[expr {($commitidx($view) - $proglastnc) * 0.0002}]
1194 set proglastnc
$commitidx($view)
1195 set l
[lindex
$progresscoords 0]
1196 set r
[lindex
$progresscoords 1]
1197 if {$progressdirn} {
1198 set r
[expr {$r + $inc}]
1204 set l
[expr {$r - 0.2}]
1207 set l
[expr {$l - $inc}]
1212 set r
[expr {$l + 0.2}]
1214 set progresscoords
[list
$l $r]
1221 proc chewcommits
{view
} {
1222 global curview hlview viewcomplete
1223 global pending_select
1225 if {$view == $curview} {
1227 if {$viewcomplete($view)} {
1228 global commitidx varctok
1229 global numcommits startmsecs
1230 global mainheadid commitinfo nullid
1232 if {[info exists pending_select
]} {
1233 set row
[first_real_row
]
1236 if {$commitidx($curview) > 0} {
1237 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1238 #puts "overall $ms ms for $numcommits commits"
1239 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1241 show_status
[mc
"No commits selected"]
1246 if {[info exists hlview
] && $view == $hlview} {
1252 proc readcommit
{id
} {
1253 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1254 parsecommit
$id $contents 0
1257 proc parsecommit
{id contents listed
} {
1258 global commitinfo cdate
1267 set hdrend
[string first
"\n\n" $contents]
1269 # should never happen...
1270 set hdrend
[string length
$contents]
1272 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1273 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1274 foreach line
[split $header "\n"] {
1275 set tag
[lindex
$line 0]
1276 if {$tag == "author"} {
1277 set audate
[lindex
$line end-1
]
1278 set auname
[lrange
$line 1 end-2
]
1279 } elseif
{$tag == "committer"} {
1280 set comdate
[lindex
$line end-1
]
1281 set comname
[lrange
$line 1 end-2
]
1285 # take the first non-blank line of the comment as the headline
1286 set headline
[string trimleft
$comment]
1287 set i
[string first
"\n" $headline]
1289 set headline
[string range
$headline 0 $i]
1291 set headline
[string trimright
$headline]
1292 set i
[string first
"\r" $headline]
1294 set headline
[string trimright
[string range
$headline 0 $i]]
1297 # git rev-list indents the comment by 4 spaces;
1298 # if we got this via git cat-file, add the indentation
1300 foreach line
[split $comment "\n"] {
1301 append newcomment
" "
1302 append newcomment
$line
1303 append newcomment
"\n"
1305 set comment
$newcomment
1307 if {$comdate != {}} {
1308 set cdate
($id) $comdate
1310 set commitinfo
($id) [list
$headline $auname $audate \
1311 $comname $comdate $comment]
1314 proc getcommit
{id
} {
1315 global commitdata commitinfo
1317 if {[info exists commitdata
($id)]} {
1318 parsecommit
$id $commitdata($id) 1
1321 if {![info exists commitinfo
($id)]} {
1322 set commitinfo
($id) [list
[mc
"No commit information available"]]
1329 global tagids idtags headids idheads tagobjid
1330 global otherrefids idotherrefs mainhead mainheadid
1332 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1335 set refd
[open
[list | git show-ref
-d] r
]
1336 while {[gets
$refd line
] >= 0} {
1337 if {[string index
$line 40] ne
" "} continue
1338 set id
[string range
$line 0 39]
1339 set ref
[string range
$line 41 end
]
1340 if {![string match
"refs/*" $ref]} continue
1341 set name
[string range
$ref 5 end
]
1342 if {[string match
"remotes/*" $name]} {
1343 if {![string match
"*/HEAD" $name]} {
1344 set headids
($name) $id
1345 lappend idheads
($id) $name
1347 } elseif
{[string match
"heads/*" $name]} {
1348 set name
[string range
$name 6 end
]
1349 set headids
($name) $id
1350 lappend idheads
($id) $name
1351 } elseif
{[string match
"tags/*" $name]} {
1352 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1353 # which is what we want since the former is the commit ID
1354 set name
[string range
$name 5 end
]
1355 if {[string match
"*^{}" $name]} {
1356 set name
[string range
$name 0 end-3
]
1358 set tagobjid
($name) $id
1360 set tagids
($name) $id
1361 lappend idtags
($id) $name
1363 set otherrefids
($name) $id
1364 lappend idotherrefs
($id) $name
1371 set thehead
[exec git symbolic-ref HEAD
]
1372 if {[string match
"refs/heads/*" $thehead]} {
1373 set mainhead
[string range
$thehead 11 end
]
1374 if {[info exists headids
($mainhead)]} {
1375 set mainheadid
$headids($mainhead)
1381 # skip over fake commits
1382 proc first_real_row
{} {
1383 global nullid nullid2 numcommits
1385 for {set row
0} {$row < $numcommits} {incr row
} {
1386 set id
[commitonrow
$row]
1387 if {$id ne
$nullid && $id ne
$nullid2} {
1394 # update things for a head moved to a child of its previous location
1395 proc movehead
{id name
} {
1396 global headids idheads
1398 removehead
$headids($name) $name
1399 set headids
($name) $id
1400 lappend idheads
($id) $name
1403 # update things when a head has been removed
1404 proc removehead
{id name
} {
1405 global headids idheads
1407 if {$idheads($id) eq
$name} {
1410 set i
[lsearch
-exact $idheads($id) $name]
1412 set idheads
($id) [lreplace
$idheads($id) $i $i]
1415 unset headids
($name)
1418 proc show_error
{w top msg
} {
1419 message
$w.m
-text $msg -justify center
-aspect 400
1420 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1421 button
$w.ok
-text [mc OK
] -command "destroy $top"
1422 pack
$w.ok
-side bottom
-fill x
1423 bind $top <Visibility
> "grab $top; focus $top"
1424 bind $top <Key-Return
> "destroy $top"
1428 proc error_popup msg
{
1432 show_error
$w $w $msg
1435 proc confirm_popup msg
{
1441 message
$w.m
-text $msg -justify center
-aspect 400
1442 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1443 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1444 pack
$w.ok
-side left
-fill x
1445 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1446 pack
$w.cancel
-side right
-fill x
1447 bind $w <Visibility
> "grab $w; focus $w"
1452 proc setoptions
{} {
1453 option add
*Panedwindow.showHandle
1 startupFile
1454 option add
*Panedwindow.sashRelief raised startupFile
1455 option add
*Button.font uifont startupFile
1456 option add
*Checkbutton.font uifont startupFile
1457 option add
*Radiobutton.font uifont startupFile
1458 option add
*Menu.font uifont startupFile
1459 option add
*Menubutton.font uifont startupFile
1460 option add
*Label.font uifont startupFile
1461 option add
*Message.font uifont startupFile
1462 option add
*Entry.font uifont startupFile
1465 proc makewindow
{} {
1466 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1468 global findtype findtypemenu findloc findstring fstring geometry
1469 global entries sha1entry sha1string sha1but
1470 global diffcontextstring diffcontext
1472 global maincursor textcursor curtextcursor
1473 global rowctxmenu fakerowmenu mergemax wrapcomment
1474 global highlight_files gdttype
1475 global searchstring sstring
1476 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1477 global headctxmenu progresscanv progressitem progresscoords statusw
1478 global fprogitem fprogcoord lastprogupdate progupdatepending
1479 global rprogitem rprogcoord
1483 .bar add cascade
-label [mc
"File"] -menu .bar.
file
1485 .bar.
file add
command -label [mc
"Update"] -command updatecommits
1486 .bar.
file add
command -label [mc
"Reload"] -command reloadcommits
1487 .bar.
file add
command -label [mc
"Reread references"] -command rereadrefs
1488 .bar.
file add
command -label [mc
"List references"] -command showrefs
1489 .bar.
file add
command -label [mc
"Quit"] -command doquit
1491 .bar add cascade
-label [mc
"Edit"] -menu .bar.edit
1492 .bar.edit add
command -label [mc
"Preferences"] -command doprefs
1495 .bar add cascade
-label [mc
"View"] -menu .bar.view
1496 .bar.view add
command -label [mc
"New view..."] -command {newview
0}
1497 .bar.view add
command -label [mc
"Edit view..."] -command editview \
1499 .bar.view add
command -label [mc
"Delete view"] -command delview
-state disabled
1500 .bar.view add separator
1501 .bar.view add radiobutton
-label [mc
"All files"] -command {showview
0} \
1502 -variable selectedview
-value 0
1505 .bar add cascade
-label [mc
"Help"] -menu .bar.
help
1506 .bar.
help add
command -label [mc
"About gitk"] -command about
1507 .bar.
help add
command -label [mc
"Key bindings"] -command keys
1509 . configure
-menu .bar
1511 # the gui has upper and lower half, parts of a paned window.
1512 panedwindow .ctop
-orient vertical
1514 # possibly use assumed geometry
1515 if {![info exists geometry
(pwsash0
)]} {
1516 set geometry
(topheight
) [expr {15 * $linespc}]
1517 set geometry
(topwidth
) [expr {80 * $charspc}]
1518 set geometry
(botheight
) [expr {15 * $linespc}]
1519 set geometry
(botwidth
) [expr {50 * $charspc}]
1520 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1521 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1524 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1525 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1527 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1529 # create three canvases
1530 set cscroll .tf.histframe.csb
1531 set canv .tf.histframe.pwclist.canv
1533 -selectbackground $selectbgcolor \
1534 -background $bgcolor -bd 0 \
1535 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1536 .tf.histframe.pwclist add
$canv
1537 set canv2 .tf.histframe.pwclist.canv2
1539 -selectbackground $selectbgcolor \
1540 -background $bgcolor -bd 0 -yscrollincr $linespc
1541 .tf.histframe.pwclist add
$canv2
1542 set canv3 .tf.histframe.pwclist.canv3
1544 -selectbackground $selectbgcolor \
1545 -background $bgcolor -bd 0 -yscrollincr $linespc
1546 .tf.histframe.pwclist add
$canv3
1547 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1548 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1550 # a scroll bar to rule them
1551 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1552 pack
$cscroll -side right
-fill y
1553 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1554 lappend bglist
$canv $canv2 $canv3
1555 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1557 # we have two button bars at bottom of top frame. Bar 1
1559 frame .tf.lbar
-height 15
1561 set sha1entry .tf.bar.sha1
1562 set entries
$sha1entry
1563 set sha1but .tf.bar.sha1label
1564 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
1565 -command gotocommit
-width 8
1566 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1567 pack .tf.bar.sha1label
-side left
1568 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1569 trace add variable sha1string
write sha1change
1570 pack
$sha1entry -side left
-pady 2
1572 image create bitmap bm-left
-data {
1573 #define left_width 16
1574 #define left_height 16
1575 static unsigned char left_bits
[] = {
1576 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1577 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1578 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1580 image create bitmap bm-right
-data {
1581 #define right_width 16
1582 #define right_height 16
1583 static unsigned char right_bits
[] = {
1584 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1585 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1586 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1588 button .tf.bar.leftbut
-image bm-left
-command goback \
1589 -state disabled
-width 26
1590 pack .tf.bar.leftbut
-side left
-fill y
1591 button .tf.bar.rightbut
-image bm-right
-command goforw \
1592 -state disabled
-width 26
1593 pack .tf.bar.rightbut
-side left
-fill y
1595 # Status label and progress bar
1596 set statusw .tf.bar.status
1597 label
$statusw -width 15 -relief sunken
1598 pack
$statusw -side left
-padx 5
1599 set h
[expr {[font metrics uifont
-linespace] + 2}]
1600 set progresscanv .tf.bar.progress
1601 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1602 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1603 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1604 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1605 pack
$progresscanv -side right
-expand 1 -fill x
1606 set progresscoords
{0 0}
1609 bind $progresscanv <Configure
> adjustprogress
1610 set lastprogupdate
[clock clicks
-milliseconds]
1611 set progupdatepending
0
1613 # build up the bottom bar of upper window
1614 label .tf.lbar.flabel
-text "[mc "Find
"] "
1615 button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
1616 button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
1617 label .tf.lbar.flab2
-text " [mc "commit
"] "
1618 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1620 set gdttype
[mc
"containing:"]
1621 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1622 [mc
"containing:"] \
1623 [mc
"touching paths:"] \
1624 [mc
"adding/removing string:"]]
1625 trace add variable gdttype
write gdttype_change
1626 pack .tf.lbar.gdttype
-side left
-fill y
1629 set fstring .tf.lbar.findstring
1630 lappend entries
$fstring
1631 entry
$fstring -width 30 -font textfont
-textvariable findstring
1632 trace add variable findstring
write find_change
1633 set findtype
[mc
"Exact"]
1634 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1635 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
1636 trace add variable findtype
write findcom_change
1637 set findloc
[mc
"All fields"]
1638 tk_optionMenu .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
1639 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
1640 trace add variable findloc
write find_change
1641 pack .tf.lbar.findloc
-side right
1642 pack .tf.lbar.findtype
-side right
1643 pack
$fstring -side left
-expand 1 -fill x
1645 # Finish putting the upper half of the viewer together
1646 pack .tf.lbar
-in .tf
-side bottom
-fill x
1647 pack .tf.bar
-in .tf
-side bottom
-fill x
1648 pack .tf.histframe
-fill both
-side top
-expand 1
1650 .ctop paneconfigure .tf
-height $geometry(topheight
)
1651 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1653 # now build up the bottom
1654 panedwindow .pwbottom
-orient horizontal
1656 # lower left, a text box over search bar, scroll bar to the right
1657 # if we know window height, then that will set the lower text height, otherwise
1658 # we set lower text height which will drive window height
1659 if {[info exists geometry
(main
)]} {
1660 frame .bleft
-width $geometry(botwidth
)
1662 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
1667 button .bleft.top.search
-text [mc
"Search"] -command dosearch
1668 pack .bleft.top.search
-side left
-padx 5
1669 set sstring .bleft.top.sstring
1670 entry
$sstring -width 20 -font textfont
-textvariable searchstring
1671 lappend entries
$sstring
1672 trace add variable searchstring
write incrsearch
1673 pack
$sstring -side left
-expand 1 -fill x
1674 radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
1675 -command changediffdisp
-variable diffelide
-value {0 0}
1676 radiobutton .bleft.mid.old
-text [mc
"Old version"] \
1677 -command changediffdisp
-variable diffelide
-value {0 1}
1678 radiobutton .bleft.mid.new
-text [mc
"New version"] \
1679 -command changediffdisp
-variable diffelide
-value {1 0}
1680 label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
1681 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
1682 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
1683 -from 1 -increment 1 -to 10000000 \
1684 -validate all
-validatecommand "diffcontextvalidate %P" \
1685 -textvariable diffcontextstring
1686 .bleft.mid.diffcontext
set $diffcontext
1687 trace add variable diffcontextstring
write diffcontextchange
1688 lappend entries .bleft.mid.diffcontext
1689 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
1690 checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
1691 -command changeignorespace
-variable ignorespace
1692 pack .bleft.mid.ignspace
-side left
-padx 5
1693 set ctext .bleft.ctext
1694 text
$ctext -background $bgcolor -foreground $fgcolor \
1695 -state disabled
-font textfont \
1696 -yscrollcommand scrolltext
-wrap none
1698 $ctext conf
-tabstyle wordprocessor
1700 scrollbar .bleft.sb
-command "$ctext yview"
1701 pack .bleft.top
-side top
-fill x
1702 pack .bleft.mid
-side top
-fill x
1703 pack .bleft.sb
-side right
-fill y
1704 pack
$ctext -side left
-fill both
-expand 1
1705 lappend bglist
$ctext
1706 lappend fglist
$ctext
1708 $ctext tag conf comment
-wrap $wrapcomment
1709 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
1710 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
1711 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
1712 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
1713 $ctext tag conf m0
-fore red
1714 $ctext tag conf m1
-fore blue
1715 $ctext tag conf m2
-fore green
1716 $ctext tag conf m3
-fore purple
1717 $ctext tag conf
m4 -fore brown
1718 $ctext tag conf m5
-fore "#009090"
1719 $ctext tag conf m6
-fore magenta
1720 $ctext tag conf m7
-fore "#808000"
1721 $ctext tag conf m8
-fore "#009000"
1722 $ctext tag conf m9
-fore "#ff0080"
1723 $ctext tag conf m10
-fore cyan
1724 $ctext tag conf m11
-fore "#b07070"
1725 $ctext tag conf m12
-fore "#70b0f0"
1726 $ctext tag conf m13
-fore "#70f0b0"
1727 $ctext tag conf m14
-fore "#f0b070"
1728 $ctext tag conf m15
-fore "#ff70b0"
1729 $ctext tag conf mmax
-fore darkgrey
1731 $ctext tag conf mresult
-font textfontbold
1732 $ctext tag conf msep
-font textfontbold
1733 $ctext tag conf found
-back yellow
1735 .pwbottom add .bleft
1736 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
1741 radiobutton .bright.mode.
patch -text [mc
"Patch"] \
1742 -command reselectline
-variable cmitmode
-value "patch"
1743 radiobutton .bright.mode.tree
-text [mc
"Tree"] \
1744 -command reselectline
-variable cmitmode
-value "tree"
1745 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
1746 pack .bright.mode
-side top
-fill x
1747 set cflist .bright.cfiles
1748 set indent
[font measure mainfont
"nn"]
1750 -selectbackground $selectbgcolor \
1751 -background $bgcolor -foreground $fgcolor \
1753 -tabs [list
$indent [expr {2 * $indent}]] \
1754 -yscrollcommand ".bright.sb set" \
1755 -cursor [. cget
-cursor] \
1756 -spacing1 1 -spacing3 1
1757 lappend bglist
$cflist
1758 lappend fglist
$cflist
1759 scrollbar .bright.sb
-command "$cflist yview"
1760 pack .bright.sb
-side right
-fill y
1761 pack
$cflist -side left
-fill both
-expand 1
1762 $cflist tag configure highlight \
1763 -background [$cflist cget
-selectbackground]
1764 $cflist tag configure bold
-font mainfontbold
1766 .pwbottom add .bright
1769 # restore window position if known
1770 if {[info exists geometry
(main
)]} {
1771 wm geometry .
"$geometry(main)"
1774 if {[tk windowingsystem
] eq
{aqua
}} {
1780 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
1781 pack .ctop
-fill both
-expand 1
1782 bindall
<1> {selcanvline
%W
%x
%y
}
1783 #bindall <B1-Motion> {selcanvline %W %x %y}
1784 if {[tk windowingsystem
] == "win32"} {
1785 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
1786 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
1788 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
1789 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
1790 if {[tk windowingsystem
] eq
"aqua"} {
1791 bindall
<MouseWheel
> {
1792 set delta
[expr {- (%D
)}]
1793 allcanvs yview scroll
$delta units
1797 bindall
<2> "canvscan mark %W %x %y"
1798 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
1799 bindkey
<Home
> selfirstline
1800 bindkey
<End
> sellastline
1801 bind .
<Key-Up
> "selnextline -1"
1802 bind .
<Key-Down
> "selnextline 1"
1803 bind .
<Shift-Key-Up
> "dofind -1 0"
1804 bind .
<Shift-Key-Down
> "dofind 1 0"
1805 bindkey
<Key-Right
> "goforw"
1806 bindkey
<Key-Left
> "goback"
1807 bind .
<Key-Prior
> "selnextpage -1"
1808 bind .
<Key-Next
> "selnextpage 1"
1809 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
1810 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
1811 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
1812 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
1813 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1814 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1815 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
1816 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
1817 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
1818 bindkey p
"selnextline -1"
1819 bindkey n
"selnextline 1"
1822 bindkey i
"selnextline -1"
1823 bindkey k
"selnextline 1"
1826 bindkey b
"$ctext yview scroll -1 pages"
1827 bindkey d
"$ctext yview scroll 18 units"
1828 bindkey u
"$ctext yview scroll -18 units"
1829 bindkey
/ {dofind
1 1}
1830 bindkey
<Key-Return
> {dofind
1 1}
1831 bindkey ?
{dofind
-1 1}
1833 bindkey
<F5
> updatecommits
1834 bind .
<$M1B-q> doquit
1835 bind .
<$M1B-f> {dofind
1 1}
1836 bind .
<$M1B-g> {dofind
1 0}
1837 bind .
<$M1B-r> dosearchback
1838 bind .
<$M1B-s> dosearch
1839 bind .
<$M1B-equal> {incrfont
1}
1840 bind .
<$M1B-plus> {incrfont
1}
1841 bind .
<$M1B-KP_Add> {incrfont
1}
1842 bind .
<$M1B-minus> {incrfont
-1}
1843 bind .
<$M1B-KP_Subtract> {incrfont
-1}
1844 wm protocol . WM_DELETE_WINDOW doquit
1845 bind .
<Button-1
> "click %W"
1846 bind $fstring <Key-Return
> {dofind
1 1}
1847 bind $sha1entry <Key-Return
> gotocommit
1848 bind $sha1entry <<PasteSelection>> clearsha1
1849 bind $cflist <1> {sel_flist %W %x %y; break}
1850 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1851 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1852 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1854 set maincursor [. cget -cursor]
1855 set textcursor [$ctext cget -cursor]
1856 set curtextcursor $textcursor
1858 set rowctxmenu .rowctxmenu
1859 menu $rowctxmenu -tearoff 0
1860 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1861 -command {diffvssel 0}
1862 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1863 -command {diffvssel 1}
1864 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1865 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1866 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1867 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1868 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1870 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1873 set fakerowmenu .fakerowmenu
1874 menu $fakerowmenu -tearoff 0
1875 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1876 -command {diffvssel 0}
1877 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1878 -command {diffvssel 1}
1879 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1880 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1881 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1882 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1884 set headctxmenu .headctxmenu
1885 menu $headctxmenu -tearoff 0
1886 $headctxmenu add command -label [mc "Check out this branch"] \
1888 $headctxmenu add command -label [mc "Remove this branch"] \
1892 set flist_menu .flistctxmenu
1893 menu $flist_menu -tearoff 0
1894 $flist_menu add command -label [mc "Highlight this too"] \
1895 -command {flist_hl 0}
1896 $flist_menu add command -label [mc "Highlight this only"] \
1897 -command {flist_hl 1}
1900 # Windows sends all mouse wheel events to the current focused window, not
1901 # the one where the mouse hovers, so bind those events here and redirect
1902 # to the correct window
1903 proc windows_mousewheel_redirector {W X Y D} {
1904 global canv canv2 canv3
1905 set w [winfo containing -displayof $W $X $Y]
1907 set u [expr {$D < 0 ? 5 : -5}]
1908 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1909 allcanvs yview scroll $u units
1912 $w yview scroll $u units
1918 # mouse-2 makes all windows scan vertically, but only the one
1919 # the cursor is in scans horizontally
1920 proc canvscan {op w x y} {
1921 global canv canv2 canv3
1922 foreach c [list $canv $canv2 $canv3] {
1931 proc scrollcanv {cscroll f0 f1} {
1932 $cscroll set $f0 $f1
1937 # when we make a key binding for the toplevel, make sure
1938 # it doesn't get triggered when that key is pressed in the
1939 # find string entry widget.
1940 proc bindkey {ev script} {
1943 set escript [bind Entry $ev]
1944 if {$escript == {}} {
1945 set escript [bind Entry <Key>]
1947 foreach e $entries {
1948 bind $e $ev "$escript; break"
1952 # set the focus back to the toplevel for any click outside
1955 global ctext entries
1956 foreach e [concat $entries $ctext] {
1957 if {$w == $e} return
1962 # Adjust the progress bar for a change in requested extent or canvas size
1963 proc adjustprogress {} {
1964 global progresscanv progressitem progresscoords
1965 global fprogitem fprogcoord lastprogupdate progupdatepending
1966 global rprogitem rprogcoord
1968 set w [expr {[winfo width $progresscanv] - 4}]
1969 set x0 [expr {$w * [lindex $progresscoords 0]}]
1970 set x1 [expr {$w * [lindex $progresscoords 1]}]
1971 set h [winfo height $progresscanv]
1972 $progresscanv coords $progressitem $x0 0 $x1 $h
1973 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1974 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1975 set now [clock clicks -milliseconds]
1976 if {$now >= $lastprogupdate + 100} {
1977 set progupdatepending 0
1979 } elseif {!$progupdatepending} {
1980 set progupdatepending 1
1981 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1985 proc doprogupdate {} {
1986 global lastprogupdate progupdatepending
1988 if {$progupdatepending} {
1989 set progupdatepending 0
1990 set lastprogupdate [clock clicks -milliseconds]
1995 proc savestuff {w} {
1996 global canv canv2 canv3 mainfont textfont uifont tabstop
1997 global stuffsaved findmergefiles maxgraphpct
1998 global maxwidth showneartags showlocalchanges
1999 global viewname viewfiles viewargs viewperm nextviewnum
2000 global cmitmode wrapcomment datetimeformat limitdiffs
2001 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2003 if {$stuffsaved} return
2004 if {![winfo viewable .]} return
2006 set f [open "~/.gitk-new" w]
2007 puts $f [list set mainfont $mainfont]
2008 puts $f [list set textfont $textfont]
2009 puts $f [list set uifont $uifont]
2010 puts $f [list set tabstop $tabstop]
2011 puts $f [list set findmergefiles $findmergefiles]
2012 puts $f [list set maxgraphpct $maxgraphpct]
2013 puts $f [list set maxwidth $maxwidth]
2014 puts $f [list set cmitmode $cmitmode]
2015 puts $f [list set wrapcomment $wrapcomment]
2016 puts $f [list set showneartags $showneartags]
2017 puts $f [list set showlocalchanges $showlocalchanges]
2018 puts $f [list set datetimeformat $datetimeformat]
2019 puts $f [list set limitdiffs $limitdiffs]
2020 puts $f [list set bgcolor $bgcolor]
2021 puts $f [list set fgcolor $fgcolor]
2022 puts $f [list set colors $colors]
2023 puts $f [list set diffcolors $diffcolors]
2024 puts $f [list set diffcontext $diffcontext]
2025 puts $f [list set selectbgcolor $selectbgcolor]
2027 puts $f "set geometry(main) [wm geometry .]"
2028 puts $f "set geometry(topwidth) [winfo width .tf]"
2029 puts $f "set geometry(topheight) [winfo height .tf]"
2030 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2031 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2032 puts $f "set geometry(botwidth) [winfo width .bleft]"
2033 puts $f "set geometry(botheight) [winfo height .bleft]"
2035 puts -nonewline $f "set permviews {"
2036 for {set v 0} {$v < $nextviewnum} {incr v} {
2037 if {$viewperm($v)} {
2038 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
2043 file rename -force "~/.gitk-new" "~/.gitk"
2048 proc resizeclistpanes {win w} {
2050 if {[info exists oldwidth($win)]} {
2051 set s0 [$win sash coord 0]
2052 set s1 [$win sash coord 1]
2054 set sash0 [expr {int($w/2 - 2)}]
2055 set sash1 [expr {int($w*5/6 - 2)}]
2057 set factor [expr {1.0 * $w / $oldwidth($win)}]
2058 set sash0 [expr {int($factor * [lindex $s0 0])}]
2059 set sash1 [expr {int($factor * [lindex $s1 0])}]
2063 if {$sash1 < $sash0 + 20} {
2064 set sash1 [expr {$sash0 + 20}]
2066 if {$sash1 > $w - 10} {
2067 set sash1 [expr {$w - 10}]
2068 if {$sash0 > $sash1 - 20} {
2069 set sash0 [expr {$sash1 - 20}]
2073 $win sash place 0 $sash0 [lindex $s0 1]
2074 $win sash place 1 $sash1 [lindex $s1 1]
2076 set oldwidth($win) $w
2079 proc resizecdetpanes {win w} {
2081 if {[info exists oldwidth($win)]} {
2082 set s0 [$win sash coord 0]
2084 set sash0 [expr {int($w*3/4 - 2)}]
2086 set factor [expr {1.0 * $w / $oldwidth($win)}]
2087 set sash0 [expr {int($factor * [lindex $s0 0])}]
2091 if {$sash0 > $w - 15} {
2092 set sash0 [expr {$w - 15}]
2095 $win sash place 0 $sash0 [lindex $s0 1]
2097 set oldwidth($win) $w
2100 proc allcanvs args {
2101 global canv canv2 canv3
2107 proc bindall {event action} {
2108 global canv canv2 canv3
2109 bind $canv $event $action
2110 bind $canv2 $event $action
2111 bind $canv3 $event $action
2117 if {[winfo exists $w]} {
2122 wm title $w [mc "About gitk"]
2123 message $w.m -text [mc "
2124 Gitk - a commit viewer for git
2126 Copyright © 2005-2006 Paul Mackerras
2128 Use and redistribute under the terms of the GNU General Public License"] \
2129 -justify center -aspect 400 -border 2 -bg white -relief groove
2130 pack $w.m -side top -fill x -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"
2140 if {[winfo exists $w]} {
2144 if {[tk windowingsystem] eq {aqua}} {
2150 wm title $w [mc "Gitk key bindings"]
2151 message $w.m -text "
2152 [mc "Gitk key bindings:"]
2154 [mc "<%s-Q> Quit" $M1T]
2155 [mc "<Home> Move to first commit"]
2156 [mc "<End> Move to last commit"]
2157 [mc "<Up>, p, i Move up one commit"]
2158 [mc "<Down>, n, k Move down one commit"]
2159 [mc "<Left>, z, j Go back in history list"]
2160 [mc "<Right>, x, l Go forward in history list"]
2161 [mc "<PageUp> Move up one page in commit list"]
2162 [mc "<PageDown> Move down one page in commit list"]
2163 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2164 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2165 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2166 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2167 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2168 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2169 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2170 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2171 [mc "<Delete>, b Scroll diff view up one page"]
2172 [mc "<Backspace> Scroll diff view up one page"]
2173 [mc "<Space> Scroll diff view down one page"]
2174 [mc "u Scroll diff view up 18 lines"]
2175 [mc "d Scroll diff view down 18 lines"]
2176 [mc "<%s-F> Find" $M1T]
2177 [mc "<%s-G> Move to next find hit" $M1T]
2178 [mc "<Return> Move to next find hit"]
2179 [mc "/ Move to next find hit, or redo find"]
2180 [mc "? Move to previous find hit"]
2181 [mc "f Scroll diff view to next file"]
2182 [mc "<%s-S> Search for next hit in diff view" $M1T]
2183 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2184 [mc "<%s-KP+> Increase font size" $M1T]
2185 [mc "<%s-plus> Increase font size" $M1T]
2186 [mc "<%s-KP-> Decrease font size" $M1T]
2187 [mc "<%s-minus> Decrease font size" $M1T]
2190 -justify left -bg white -border 2 -relief groove
2191 pack $w.m -side top -fill both -padx 2 -pady 2
2192 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2193 pack $w.ok -side bottom
2194 bind $w <Visibility> "focus $w.ok"
2195 bind $w <Key-Escape> "destroy $w"
2196 bind $w <Key-Return> "destroy $w"
2199 # Procedures for manipulating the file list window at the
2200 # bottom right of the overall window.
2202 proc treeview {w l openlevs} {
2203 global treecontents treediropen treeheight treeparent treeindex
2213 set treecontents() {}
2214 $w conf -state normal
2216 while {[string range $f 0 $prefixend] ne $prefix} {
2217 if {$lev <= $openlevs} {
2218 $w mark set e:$treeindex($prefix) "end -1c"
2219 $w mark gravity e:$treeindex($prefix) left
2221 set treeheight($prefix) $ht
2222 incr ht [lindex $htstack end]
2223 set htstack [lreplace $htstack end end]
2224 set prefixend [lindex $prefendstack end]
2225 set prefendstack [lreplace $prefendstack end end]
2226 set prefix [string range $prefix 0 $prefixend]
2229 set tail [string range $f [expr {$prefixend+1}] end]
2230 while {[set slash [string first "/" $tail]] >= 0} {
2233 lappend prefendstack $prefixend
2234 incr prefixend [expr {$slash + 1}]
2235 set d [string range $tail 0 $slash]
2236 lappend treecontents($prefix) $d
2237 set oldprefix $prefix
2239 set treecontents($prefix) {}
2240 set treeindex($prefix) [incr ix]
2241 set treeparent($prefix) $oldprefix
2242 set tail [string range $tail [expr {$slash+1}] end]
2243 if {$lev <= $openlevs} {
2245 set treediropen($prefix) [expr {$lev < $openlevs}]
2246 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2247 $w mark set d:$ix "end -1c"
2248 $w mark gravity d:$ix left
2250 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2252 $w image create end -align center -image $bm -padx 1 \
2254 $w insert end $d [highlight_tag $prefix]
2255 $w mark set s:$ix "end -1c"
2256 $w mark gravity s:$ix left
2261 if {$lev <= $openlevs} {
2264 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2266 $w insert end $tail [highlight_tag $f]
2268 lappend treecontents($prefix) $tail
2271 while {$htstack ne {}} {
2272 set treeheight($prefix) $ht
2273 incr ht [lindex $htstack end]
2274 set htstack [lreplace $htstack end end]
2275 set prefixend [lindex $prefendstack end]
2276 set prefendstack [lreplace $prefendstack end end]
2277 set prefix [string range $prefix 0 $prefixend]
2279 $w conf -state disabled
2282 proc linetoelt {l} {
2283 global treeheight treecontents
2288 foreach e $treecontents($prefix) {
2293 if {[string index $e end] eq "/"} {
2294 set n $treeheight($prefix$e)
2306 proc highlight_tree {y prefix} {
2307 global treeheight treecontents cflist
2309 foreach e $treecontents($prefix) {
2311 if {[highlight_tag $path] ne {}} {
2312 $cflist tag add bold $y.0 "$y.0 lineend"
2315 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2316 set y [highlight_tree $y $path]
2322 proc treeclosedir {w dir} {
2323 global treediropen treeheight treeparent treeindex
2325 set ix $treeindex($dir)
2326 $w conf -state normal
2327 $w delete s:$ix e:$ix
2328 set treediropen($dir) 0
2329 $w image configure a:$ix -image tri-rt
2330 $w conf -state disabled
2331 set n [expr {1 - $treeheight($dir)}]
2332 while {$dir ne {}} {
2333 incr treeheight($dir) $n
2334 set dir $treeparent($dir)
2338 proc treeopendir {w dir} {
2339 global treediropen treeheight treeparent treecontents treeindex
2341 set ix $treeindex($dir)
2342 $w conf -state normal
2343 $w image configure a:$ix -image tri-dn
2344 $w mark set e:$ix s:$ix
2345 $w mark gravity e:$ix right
2348 set n [llength $treecontents($dir)]
2349 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2352 incr treeheight($x) $n
2354 foreach e $treecontents($dir) {
2356 if {[string index $e end] eq "/"} {
2357 set iy $treeindex($de)
2358 $w mark set d:$iy e:$ix
2359 $w mark gravity d:$iy left
2360 $w insert e:$ix $str
2361 set treediropen($de) 0
2362 $w image create e:$ix -align center -image tri-rt -padx 1 \
2364 $w insert e:$ix $e [highlight_tag $de]
2365 $w mark set s:$iy e:$ix
2366 $w mark gravity s:$iy left
2367 set treeheight($de) 1
2369 $w insert e:$ix $str
2370 $w insert e:$ix $e [highlight_tag $de]
2373 $w mark gravity e:$ix left
2374 $w conf -state disabled
2375 set treediropen($dir) 1
2376 set top [lindex [split [$w index @0,0] .] 0]
2377 set ht [$w cget -height]
2378 set l [lindex [split [$w index s:$ix] .] 0]
2381 } elseif {$l + $n + 1 > $top + $ht} {
2382 set top [expr {$l + $n + 2 - $ht}]
2390 proc treeclick {w x y} {
2391 global treediropen cmitmode ctext cflist cflist_top
2393 if {$cmitmode ne "tree"} return
2394 if {![info exists cflist_top]} return
2395 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2396 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2397 $cflist tag add highlight $l.0 "$l.0 lineend"
2403 set e [linetoelt $l]
2404 if {[string index $e end] ne "/"} {
2406 } elseif {$treediropen($e)} {
2413 proc setfilelist {id} {
2414 global treefilelist cflist
2416 treeview $cflist $treefilelist($id) 0
2419 image create bitmap tri-rt -background black -foreground blue -data {
2420 #define tri-rt_width 13
2421 #define tri-rt_height 13
2422 static unsigned char tri-rt_bits[] = {
2423 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2424 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2427 #define tri-rt-mask_width 13
2428 #define tri-rt-mask_height 13
2429 static unsigned char tri-rt-mask_bits[] = {
2430 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2431 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2434 image create bitmap tri-dn -background black -foreground blue -data {
2435 #define tri-dn_width 13
2436 #define tri-dn_height 13
2437 static unsigned char tri-dn_bits[] = {
2438 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2439 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2442 #define tri-dn-mask_width 13
2443 #define tri-dn-mask_height 13
2444 static unsigned char tri-dn-mask_bits[] = {
2445 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2446 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2450 image create bitmap reficon-T -background black -foreground yellow -data {
2451 #define tagicon_width 13
2452 #define tagicon_height 9
2453 static unsigned char tagicon_bits[] = {
2454 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2455 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2457 #define tagicon-mask_width 13
2458 #define tagicon-mask_height 9
2459 static unsigned char tagicon-mask_bits[] = {
2460 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2461 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2464 #define headicon_width 13
2465 #define headicon_height 9
2466 static unsigned char headicon_bits[] = {
2467 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2468 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2471 #define headicon-mask_width 13
2472 #define headicon-mask_height 9
2473 static unsigned char headicon-mask_bits[] = {
2474 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2475 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2477 image create bitmap reficon-H -background black -foreground green \
2478 -data $rectdata -maskdata $rectmask
2479 image create bitmap reficon-o -background black -foreground "#ddddff" \
2480 -data $rectdata -maskdata $rectmask
2482 proc init_flist {first} {
2483 global cflist cflist_top difffilestart
2485 $cflist conf -state normal
2486 $cflist delete 0.0 end
2488 $cflist insert end $first
2490 $cflist tag add highlight 1.0 "1.0 lineend"
2492 catch {unset cflist_top}
2494 $cflist conf -state disabled
2495 set difffilestart {}
2498 proc highlight_tag {f} {
2499 global highlight_paths
2501 foreach p $highlight_paths {
2502 if {[string match $p $f]} {
2509 proc highlight_filelist {} {
2510 global cmitmode cflist
2512 $cflist conf -state normal
2513 if {$cmitmode ne "tree"} {
2514 set end [lindex [split [$cflist index end] .] 0]
2515 for {set l 2} {$l < $end} {incr l} {
2516 set line [$cflist get $l.0 "$l.0 lineend"]
2517 if {[highlight_tag $line] ne {}} {
2518 $cflist tag add bold $l.0 "$l.0 lineend"
2524 $cflist conf -state disabled
2527 proc unhighlight_filelist {} {
2530 $cflist conf -state normal
2531 $cflist tag remove bold 1.0 end
2532 $cflist conf -state disabled
2535 proc add_flist {fl} {
2538 $cflist conf -state normal
2540 $cflist insert end "\n"
2541 $cflist insert end $f [highlight_tag $f]
2543 $cflist conf -state disabled
2546 proc sel_flist {w x y} {
2547 global ctext difffilestart cflist cflist_top cmitmode
2549 if {$cmitmode eq "tree"} return
2550 if {![info exists cflist_top]} return
2551 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2552 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2553 $cflist tag add highlight $l.0 "$l.0 lineend"
2558 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2562 proc pop_flist_menu {w X Y x y} {
2563 global ctext cflist cmitmode flist_menu flist_menu_file
2564 global treediffs diffids
2567 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2569 if {$cmitmode eq "tree"} {
2570 set e [linetoelt $l]
2571 if {[string index $e end] eq "/"} return
2573 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2575 set flist_menu_file $e
2576 tk_popup $flist_menu $X $Y
2579 proc flist_hl {only} {
2580 global flist_menu_file findstring gdttype
2582 set x [shellquote $flist_menu_file]
2583 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2586 append findstring " " $x
2588 set gdttype [mc "touching paths:"]
2591 # Functions for adding and removing shell-type quoting
2593 proc shellquote {str} {
2594 if {![string match "*\['\"\\ \t]*" $str]} {
2597 if {![string match "*\['\"\\]*" $str]} {
2600 if {![string match "*'*" $str]} {
2603 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2606 proc shellarglist {l} {
2612 append str [shellquote $a]
2617 proc shelldequote {str} {
2622 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2623 append ret [string range $str $used end]
2624 set used [string length $str]
2627 set first [lindex $first 0]
2628 set ch [string index $str $first]
2629 if {$first > $used} {
2630 append ret [string range $str $used [expr {$first - 1}]]
2633 if {$ch eq " " || $ch eq "\t"} break
2636 set first [string first "'" $str $used]
2638 error "unmatched single-quote"
2640 append ret [string range $str $used [expr {$first - 1}]]
2645 if {$used >= [string length $str]} {
2646 error "trailing backslash"
2648 append ret [string index $str $used]
2653 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2654 error "unmatched double-quote"
2656 set first [lindex $first 0]
2657 set ch [string index $str $first]
2658 if {$first > $used} {
2659 append ret [string range $str $used [expr {$first - 1}]]
2662 if {$ch eq "\""} break
2664 append ret [string index $str $used]
2668 return [list $used $ret]
2671 proc shellsplit {str} {
2674 set str [string trimleft $str]
2675 if {$str eq {}} break
2676 set dq [shelldequote $str]
2677 set n [lindex $dq 0]
2678 set word [lindex $dq 1]
2679 set str [string range $str $n end]
2685 # Code to implement multiple views
2687 proc newview {ishighlight} {
2688 global nextviewnum newviewname newviewperm newishighlight
2689 global newviewargs revtreeargs
2691 set newishighlight $ishighlight
2693 if {[winfo exists $top]} {
2697 set newviewname($nextviewnum) "View $nextviewnum"
2698 set newviewperm($nextviewnum) 0
2699 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2700 vieweditor $top $nextviewnum [mc "Gitk view definition"]
2705 global viewname viewperm newviewname newviewperm
2706 global viewargs newviewargs
2708 set top .gitkvedit-$curview
2709 if {[winfo exists $top]} {
2713 set newviewname($curview) $viewname($curview)
2714 set newviewperm($curview) $viewperm($curview)
2715 set newviewargs($curview) [shellarglist $viewargs($curview)]
2716 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2719 proc vieweditor {top n title} {
2720 global newviewname newviewperm viewfiles bgcolor
2723 wm title $top $title
2724 label $top.nl -text [mc "Name"]
2725 entry $top.name -width 20 -textvariable newviewname($n)
2726 grid $top.nl $top.name -sticky w -pady 5
2727 checkbutton $top.perm -text [mc "Remember this view"] \
2728 -variable newviewperm($n)
2729 grid $top.perm - -pady 5 -sticky w
2730 message $top.al -aspect 1000 \
2731 -text [mc "Commits to include (arguments to git rev-list):"]
2732 grid $top.al - -sticky w -pady 5
2733 entry $top.args -width 50 -textvariable newviewargs($n) \
2734 -background $bgcolor
2735 grid $top.args - -sticky ew -padx 5
2736 message $top.l -aspect 1000 \
2737 -text [mc "Enter files and directories to include, one per line:"]
2738 grid $top.l - -sticky w
2739 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
2740 if {[info exists viewfiles($n)]} {
2741 foreach f $viewfiles($n) {
2742 $top.t insert end $f
2743 $top.t insert end "\n"
2745 $top.t delete {end - 1c} end
2746 $top.t mark set insert 0.0
2748 grid $top.t - -sticky ew -padx 5
2750 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
2751 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
2752 grid $top.buts.ok $top.buts.can
2753 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2754 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2755 grid $top.buts - -pady 10 -sticky ew
2759 proc doviewmenu {m first cmd op argv} {
2760 set nmenu [$m index end]
2761 for {set i $first} {$i <= $nmenu} {incr i} {
2762 if {[$m entrycget $i -command] eq $cmd} {
2763 eval $m $op $i $argv
2769 proc allviewmenus {n op args} {
2772 doviewmenu .bar.view 5 [list showview $n] $op $args
2773 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2776 proc newviewok {top n} {
2777 global nextviewnum newviewperm newviewname newishighlight
2778 global viewname viewfiles viewperm selectedview curview
2779 global viewargs newviewargs viewhlmenu
2782 set newargs [shellsplit $newviewargs($n)]
2784 error_popup "[mc "Error in commit selection arguments:"] $err"
2790 foreach f [split [$top.t get 0.0 end] "\n"] {
2791 set ft [string trim $f]
2796 if {![info exists viewfiles($n)]} {
2797 # creating a new view
2799 set viewname($n) $newviewname($n)
2800 set viewperm($n) $newviewperm($n)
2801 set viewfiles($n) $files
2802 set viewargs($n) $newargs
2804 if {!$newishighlight} {
2807 run addvhighlight $n
2810 # editing an existing view
2811 set viewperm($n) $newviewperm($n)
2812 if {$newviewname($n) ne $viewname($n)} {
2813 set viewname($n) $newviewname($n)
2814 doviewmenu .bar.view 5 [list showview $n] \
2815 entryconf [list -label $viewname($n)]
2816 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2817 # entryconf [list -label $viewname($n) -value $viewname($n)]
2819 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2820 set viewfiles($n) $files
2821 set viewargs($n) $newargs
2822 if {$curview == $n} {
2827 catch {destroy $top}
2831 global curview viewperm hlview selectedhlview
2833 if {$curview == 0} return
2834 if {[info exists hlview] && $hlview == $curview} {
2835 set selectedhlview [mc "None"]
2838 allviewmenus $curview delete
2839 set viewperm($curview) 0
2843 proc addviewmenu {n} {
2844 global viewname viewhlmenu
2846 .bar.view add radiobutton -label $viewname($n) \
2847 -command [list showview $n] -variable selectedview -value $n
2848 #$viewhlmenu add radiobutton -label $viewname($n) \
2849 # -command [list addvhighlight $n] -variable selectedhlview
2853 global curview viewfiles cached_commitrow ordertok
2854 global displayorder parentlist rowidlist rowisopt rowfinal
2855 global colormap rowtextx nextcolor canvxmax
2856 global numcommits viewcomplete
2857 global selectedline currentid canv canvy0
2859 global pending_select mainheadid
2862 global hlview selectedhlview commitinterest
2864 if {$n == $curview} return
2866 set ymax [lindex [$canv cget -scrollregion] 3]
2867 set span [$canv yview]
2868 set ytop [expr {[lindex $span 0] * $ymax}]
2869 set ybot [expr {[lindex $span 1] * $ymax}]
2870 set yscreen [expr {($ybot - $ytop) / 2}]
2871 if {[info exists selectedline]} {
2872 set selid $currentid
2873 set y [yc $selectedline]
2874 if {$ytop < $y && $y < $ybot} {
2875 set yscreen [expr {$y - $ytop}]
2877 } elseif {[info exists pending_select]} {
2878 set selid $pending_select
2879 unset pending_select
2883 catch {unset treediffs}
2885 if {[info exists hlview] && $hlview == $n} {
2887 set selectedhlview [mc "None"]
2889 catch {unset commitinterest}
2890 catch {unset cached_commitrow}
2891 catch {unset ordertok}
2895 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
2896 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
2899 if {![info exists viewcomplete($n)]} {
2901 set pending_select $selid
2912 set numcommits $commitidx($n)
2914 catch {unset colormap}
2915 catch {unset rowtextx}
2917 set canvxmax [$canv cget -width]
2923 if {$selid ne {} && [commitinview $selid $n]} {
2924 set row [rowofcommit $selid]
2925 # try to get the selected row in the same position on the screen
2926 set ymax [lindex [$canv cget -scrollregion] 3]
2927 set ytop [expr {[yc $row] - $yscreen}]
2931 set yf [expr {$ytop * 1.0 / $ymax}]
2933 allcanvs yview moveto $yf
2937 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
2938 selectline [rowofcommit $mainheadid] 1
2939 } elseif {!$viewcomplete($n)} {
2941 set pending_select $selid
2943 set pending_select $mainheadid
2946 set row [first_real_row]
2947 if {$row < $numcommits} {
2951 if {!$viewcomplete($n)} {
2952 if {$numcommits == 0} {
2953 show_status [mc "Reading commits..."]
2955 } elseif {$numcommits == 0} {
2956 show_status [mc "No commits selected"]
2960 # Stuff relating to the highlighting facility
2962 proc ishighlighted {id} {
2963 global vhighlights fhighlights nhighlights rhighlights
2965 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
2966 return $nhighlights($id)
2968 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
2969 return $vhighlights($id)
2971 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
2972 return $fhighlights($id)
2974 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
2975 return $rhighlights($id)
2980 proc bolden {row font} {
2981 global canv linehtag selectedline boldrows
2983 lappend boldrows $row
2984 $canv itemconf $linehtag($row) -font $font
2985 if {[info exists selectedline] && $row == $selectedline} {
2987 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2988 -outline {{}} -tags secsel \
2989 -fill [$canv cget -selectbackground]]
2994 proc bolden_name {row font} {
2995 global canv2 linentag selectedline boldnamerows
2997 lappend boldnamerows $row
2998 $canv2 itemconf $linentag($row) -font $font
2999 if {[info exists selectedline] && $row == $selectedline} {
3000 $canv2 delete secsel
3001 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3002 -outline {{}} -tags secsel \
3003 -fill [$canv2 cget -selectbackground]]
3012 foreach row $boldrows {
3013 if {![ishighlighted [commitonrow $row]]} {
3014 bolden $row mainfont
3016 lappend stillbold $row
3019 set boldrows $stillbold
3022 proc addvhighlight {n} {
3023 global hlview viewcomplete curview vhl_done commitidx
3025 if {[info exists hlview]} {
3029 if {$n != $curview && ![info exists viewcomplete($n)]} {
3032 set vhl_done $commitidx($hlview)
3033 if {$vhl_done > 0} {
3038 proc delvhighlight {} {
3039 global hlview vhighlights
3041 if {![info exists hlview]} return
3043 catch {unset vhighlights}
3047 proc vhighlightmore {} {
3048 global hlview vhl_done commitidx vhighlights curview
3050 set max $commitidx($hlview)
3051 set vr [visiblerows]
3052 set r0 [lindex $vr 0]
3053 set r1 [lindex $vr 1]
3054 for {set i $vhl_done} {$i < $max} {incr i} {
3055 set id [commitonrow $i $hlview]
3056 if {[commitinview $id $curview]} {
3057 set row [rowofcommit $id]
3058 if {$r0 <= $row && $row <= $r1} {
3059 if {![highlighted $row]} {
3060 bolden $row mainfontbold
3062 set vhighlights($id) 1
3069 proc askvhighlight {row id} {
3070 global hlview vhighlights iddrawn
3072 if {[commitinview $id $hlview]} {
3073 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3074 bolden $row mainfontbold
3076 set vhighlights($id) 1
3078 set vhighlights($id) 0
3082 proc hfiles_change {} {
3083 global highlight_files filehighlight fhighlights fh_serial
3084 global highlight_paths gdttype
3086 if {[info exists filehighlight]} {
3087 # delete previous highlights
3088 catch {close $filehighlight}
3090 catch {unset fhighlights}
3092 unhighlight_filelist
3094 set highlight_paths {}
3095 after cancel do_file_hl $fh_serial
3097 if {$highlight_files ne {}} {
3098 after 300 do_file_hl $fh_serial
3102 proc gdttype_change {name ix op} {
3103 global gdttype highlight_files findstring findpattern
3106 if {$findstring ne {}} {
3107 if {$gdttype eq [mc "containing:"]} {
3108 if {$highlight_files ne {}} {
3109 set highlight_files {}
3114 if {$findpattern ne {}} {
3118 set highlight_files $findstring
3123 # enable/disable findtype/findloc menus too
3126 proc find_change {name ix op} {
3127 global gdttype findstring highlight_files
3130 if {$gdttype eq [mc "containing:"]} {
3133 if {$highlight_files ne $findstring} {
3134 set highlight_files $findstring
3141 proc findcom_change args {
3142 global nhighlights boldnamerows
3143 global findpattern findtype findstring gdttype
3146 # delete previous highlights, if any
3147 foreach row $boldnamerows {
3148 bolden_name $row mainfont
3151 catch {unset nhighlights}
3154 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3156 } elseif {$findtype eq [mc "Regexp"]} {
3157 set findpattern $findstring
3159 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3161 set findpattern "*$e*"
3165 proc makepatterns {l} {
3168 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3169 if {[string index $ee end] eq "/"} {
3179 proc do_file_hl {serial} {
3180 global highlight_files filehighlight highlight_paths gdttype fhl_list
3182 if {$gdttype eq [mc "touching paths:"]} {
3183 if {[catch {set paths [shellsplit $highlight_files]}]} return
3184 set highlight_paths [makepatterns $paths]
3186 set gdtargs [concat -- $paths]
3187 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3188 set gdtargs [list "-S$highlight_files"]
3190 # must be "containing:", i.e. we're searching commit info
3193 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3194 set filehighlight [open $cmd r+]
3195 fconfigure $filehighlight -blocking 0
3196 filerun $filehighlight readfhighlight
3202 proc flushhighlights {} {
3203 global filehighlight fhl_list
3205 if {[info exists filehighlight]} {
3207 puts $filehighlight ""
3208 flush $filehighlight
3212 proc askfilehighlight {row id} {
3213 global filehighlight fhighlights fhl_list
3215 lappend fhl_list $id
3216 set fhighlights($id) -1
3217 puts $filehighlight $id
3220 proc readfhighlight {} {
3221 global filehighlight fhighlights curview iddrawn
3222 global fhl_list find_dirn
3224 if {![info exists filehighlight]} {
3228 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3229 set line [string trim $line]
3230 set i [lsearch -exact $fhl_list $line]
3231 if {$i < 0} continue
3232 for {set j 0} {$j < $i} {incr j} {
3233 set id [lindex $fhl_list $j]
3234 set fhighlights($id) 0
3236 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3237 if {$line eq {}} continue
3238 if {![commitinview $line $curview]} continue
3239 set row [rowofcommit $line]
3240 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3241 bolden $row mainfontbold
3243 set fhighlights($line) 1
3245 if {[eof $filehighlight]} {
3247 puts "oops, git diff-tree died"
3248 catch {close $filehighlight}
3252 if {[info exists find_dirn]} {
3258 proc doesmatch {f} {
3259 global findtype findpattern
3261 if {$findtype eq [mc "Regexp"]} {
3262 return [regexp $findpattern $f]
3263 } elseif {$findtype eq [mc "IgnCase"]} {
3264 return [string match -nocase $findpattern $f]
3266 return [string match $findpattern $f]
3270 proc askfindhighlight {row id} {
3271 global nhighlights commitinfo iddrawn
3273 global markingmatches
3275 if {![info exists commitinfo($id)]} {
3278 set info $commitinfo($id)
3280 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3281 foreach f $info ty $fldtypes {
3282 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3284 if {$ty eq [mc "Author"]} {
3291 if {$isbold && [info exists iddrawn($id)]} {
3292 if {![ishighlighted $id]} {
3293 bolden $row mainfontbold
3295 bolden_name $row mainfontbold
3298 if {$markingmatches} {
3299 markrowmatches $row $id
3302 set nhighlights($id) $isbold
3305 proc markrowmatches {row id} {
3306 global canv canv2 linehtag linentag commitinfo findloc
3308 set headline [lindex $commitinfo($id) 0]
3309 set author [lindex $commitinfo($id) 1]
3310 $canv delete match$row
3311 $canv2 delete match$row
3312 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3313 set m [findmatches $headline]
3315 markmatches $canv $row $headline $linehtag($row) $m \
3316 [$canv itemcget $linehtag($row) -font] $row
3319 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3320 set m [findmatches $author]
3322 markmatches $canv2 $row $author $linentag($row) $m \
3323 [$canv2 itemcget $linentag($row) -font] $row
3328 proc vrel_change {name ix op} {
3329 global highlight_related
3332 if {$highlight_related ne [mc "None"]} {
3337 # prepare for testing whether commits are descendents or ancestors of a
3338 proc rhighlight_sel {a} {
3339 global descendent desc_todo ancestor anc_todo
3340 global highlight_related
3342 catch {unset descendent}
3343 set desc_todo [list $a]
3344 catch {unset ancestor}
3345 set anc_todo [list $a]
3346 if {$highlight_related ne [mc "None"]} {
3352 proc rhighlight_none {} {
3355 catch {unset rhighlights}
3359 proc is_descendent {a} {
3360 global curview children descendent desc_todo
3363 set la [rowofcommit $a]
3367 for {set i 0} {$i < [llength $todo]} {incr i} {
3368 set do [lindex $todo $i]
3369 if {[rowofcommit $do] < $la} {
3370 lappend leftover $do
3373 foreach nk $children($v,$do) {
3374 if {![info exists descendent($nk)]} {
3375 set descendent($nk) 1
3383 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3387 set descendent($a) 0
3388 set desc_todo $leftover
3391 proc is_ancestor {a} {
3392 global curview parents ancestor anc_todo
3395 set la [rowofcommit $a]
3399 for {set i 0} {$i < [llength $todo]} {incr i} {
3400 set do [lindex $todo $i]
3401 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3402 lappend leftover $do
3405 foreach np $parents($v,$do) {
3406 if {![info exists ancestor($np)]} {
3415 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3420 set anc_todo $leftover
3423 proc askrelhighlight {row id} {
3424 global descendent highlight_related iddrawn rhighlights
3425 global selectedline ancestor
3427 if {![info exists selectedline]} return
3429 if {$highlight_related eq [mc "Descendant"] ||
3430 $highlight_related eq [mc "Not descendant"]} {
3431 if {![info exists descendent($id)]} {
3434 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3437 } elseif {$highlight_related eq [mc "Ancestor"] ||
3438 $highlight_related eq [mc "Not ancestor"]} {
3439 if {![info exists ancestor($id)]} {
3442 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3446 if {[info exists iddrawn($id)]} {
3447 if {$isbold && ![ishighlighted $id]} {
3448 bolden $row mainfontbold
3451 set rhighlights($id) $isbold
3454 # Graph layout functions
3456 proc shortids {ids} {
3459 if {[llength $id] > 1} {
3460 lappend res [shortids $id]
3461 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3462 lappend res [string range $id 0 7]
3473 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3474 if {($n & $mask) != 0} {
3475 set ret [concat $ret $o]
3477 set o [concat $o $o]
3482 proc ordertoken {id} {
3483 global ordertok curview varcid varcstart varctok curview parents children
3484 global nullid nullid2
3486 if {[info exists ordertok($id)]} {
3487 return $ordertok($id)
3492 if {[info exists varcid($curview,$id)]} {
3493 set a $varcid($curview,$id)
3494 set p [lindex $varcstart($curview) $a]
3496 set p [lindex $children($curview,$id) 0]
3498 if {[info exists ordertok($p)]} {
3499 set tok $ordertok($p)
3502 set id [first_real_child $curview,$p]
3505 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3508 if {[llength $parents($curview,$id)] == 1} {
3509 lappend todo [list $p {}]
3511 set j [lsearch -exact $parents($curview,$id) $p]
3513 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3515 lappend todo [list $p [strrep $j]]
3518 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3519 set p [lindex $todo $i 0]
3520 append tok [lindex $todo $i 1]
3521 set ordertok($p) $tok
3523 set ordertok($origid) $tok
3527 # Work out where id should go in idlist so that order-token
3528 # values increase from left to right
3529 proc idcol {idlist id {i 0}} {
3530 set t [ordertoken $id]
3534 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3535 if {$i > [llength $idlist]} {
3536 set i [llength $idlist]
3538 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3541 if {$t > [ordertoken [lindex $idlist $i]]} {
3542 while {[incr i] < [llength $idlist] &&
3543 $t >= [ordertoken [lindex $idlist $i]]} {}
3549 proc initlayout {} {
3550 global rowidlist rowisopt rowfinal displayorder parentlist
3551 global numcommits canvxmax canv
3553 global colormap rowtextx
3562 set canvxmax [$canv cget -width]
3563 catch {unset colormap}
3564 catch {unset rowtextx}
3567 proc setcanvscroll {} {
3568 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3570 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3571 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3572 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3573 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3576 proc visiblerows {} {
3577 global canv numcommits linespc
3579 set ymax [lindex [$canv cget -scrollregion] 3]
3580 if {$ymax eq {} || $ymax == 0} return
3582 set y0 [expr {int([lindex $f 0] * $ymax)}]
3583 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3587 set y1 [expr {int([lindex $f 1] * $ymax)}]
3588 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3589 if {$r1 >= $numcommits} {
3590 set r1 [expr {$numcommits - 1}]
3592 return [list $r0 $r1]
3595 proc layoutmore {} {
3596 global commitidx viewcomplete curview
3597 global numcommits pending_select selectedline curview
3598 global lastscrollset commitinterest
3600 set canshow $commitidx($curview)
3601 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3602 if {$numcommits == 0} {
3606 set prev $numcommits
3607 set numcommits $canshow
3608 set t [clock clicks -milliseconds]
3609 if {$prev < 100 || $viewcomplete($curview) || $t - $lastscrollset > 500} {
3610 set lastscrollset $t
3613 set rows [visiblerows]
3614 set r1 [lindex $rows 1]
3615 if {$r1 >= $canshow} {
3616 set r1 [expr {$canshow - 1}]
3621 if {[info exists pending_select] &&
3622 [commitinview $pending_select $curview]} {
3623 selectline [rowofcommit $pending_select] 1
3627 proc doshowlocalchanges {} {
3628 global curview mainheadid
3630 if {[commitinview $mainheadid $curview]} {
3633 lappend commitinterest($mainheadid) {dodiffindex}
3637 proc dohidelocalchanges {} {
3638 global nullid nullid2 lserial curview
3640 if {[commitinview $nullid $curview]} {
3641 removefakerow $nullid
3643 if {[commitinview $nullid2 $curview]} {
3644 removefakerow $nullid2
3649 # spawn off a process to do git diff-index --cached HEAD
3650 proc dodiffindex {} {
3651 global lserial showlocalchanges
3653 if {!$showlocalchanges} return
3655 set fd [open "|git diff-index --cached HEAD" r]
3656 fconfigure $fd -blocking 0
3657 filerun $fd [list readdiffindex $fd $lserial]
3660 proc readdiffindex {fd serial} {
3661 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3664 if {[gets $fd line] < 0} {
3670 # we only need to see one line and we don't really care what it says...
3673 if {$serial != $lserial} {
3677 # now see if there are any local changes not checked in to the index
3678 set fd [open "|git diff-files" r]
3679 fconfigure $fd -blocking 0
3680 filerun $fd [list readdifffiles $fd $serial]
3682 if {$isdiff && ![commitinview $nullid2 $curview]} {
3683 # add the line for the changes in the index to the graph
3684 set hl [mc "Local changes checked in to index but not committed"]
3685 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3686 set commitdata($nullid2) "\n $hl\n"
3687 if {[commitinview $nullid $curview]} {
3688 removefakerow $nullid
3690 insertfakerow $nullid2 $mainheadid
3691 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
3692 removefakerow $nullid2
3697 proc readdifffiles {fd serial} {
3698 global mainheadid nullid nullid2 curview
3699 global commitinfo commitdata lserial
3702 if {[gets $fd line] < 0} {
3708 # we only need to see one line and we don't really care what it says...
3711 if {$serial != $lserial} {
3715 if {$isdiff && ![commitinview $nullid $curview]} {
3716 # add the line for the local diff to the graph
3717 set hl [mc "Local uncommitted changes, not checked in to index"]
3718 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3719 set commitdata($nullid) "\n $hl\n"
3720 if {[commitinview $nullid2 $curview]} {
3725 insertfakerow $nullid $p
3726 } elseif {!$isdiff && [commitinview $nullid $curview]} {
3727 removefakerow $nullid
3732 proc nextuse {id row} {
3733 global curview children
3735 if {[info exists children($curview,$id)]} {
3736 foreach kid $children($curview,$id) {
3737 if {![commitinview $kid $curview]} {
3740 if {[rowofcommit $kid] > $row} {
3741 return [rowofcommit $kid]
3745 if {[commitinview $id $curview]} {
3746 return [rowofcommit $id]
3751 proc prevuse {id row} {
3752 global curview children
3755 if {[info exists children($curview,$id)]} {
3756 foreach kid $children($curview,$id) {
3757 if {![commitinview $kid $curview]} break
3758 if {[rowofcommit $kid] < $row} {
3759 set ret [rowofcommit $kid]
3766 proc make_idlist {row} {
3767 global displayorder parentlist uparrowlen downarrowlen mingaplen
3768 global commitidx curview children
3770 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3774 set ra [expr {$row - $downarrowlen}]
3778 set rb [expr {$row + $uparrowlen}]
3779 if {$rb > $commitidx($curview)} {
3780 set rb $commitidx($curview)
3782 make_disporder $r [expr {$rb + 1}]
3784 for {} {$r < $ra} {incr r} {
3785 set nextid [lindex $displayorder [expr {$r + 1}]]
3786 foreach p [lindex $parentlist $r] {
3787 if {$p eq $nextid} continue
3788 set rn [nextuse $p $r]
3790 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3791 lappend ids [list [ordertoken $p] $p]
3795 for {} {$r < $row} {incr r} {
3796 set nextid [lindex $displayorder [expr {$r + 1}]]
3797 foreach p [lindex $parentlist $r] {
3798 if {$p eq $nextid} continue
3799 set rn [nextuse $p $r]
3800 if {$rn < 0 || $rn >= $row} {
3801 lappend ids [list [ordertoken $p] $p]
3805 set id [lindex $displayorder $row]
3806 lappend ids [list [ordertoken $id] $id]
3808 foreach p [lindex $parentlist $r] {
3809 set firstkid [lindex $children($curview,$p) 0]
3810 if {[rowofcommit $firstkid] < $row} {
3811 lappend ids [list [ordertoken $p] $p]
3815 set id [lindex $displayorder $r]
3817 set firstkid [lindex $children($curview,$id) 0]
3818 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3819 lappend ids [list [ordertoken $id] $id]
3824 foreach idx [lsort -unique $ids] {
3825 lappend idlist [lindex $idx 1]
3830 proc rowsequal {a b} {
3831 while {[set i [lsearch -exact $a {}]] >= 0} {
3832 set a [lreplace $a $i $i]
3834 while {[set i [lsearch -exact $b {}]] >= 0} {
3835 set b [lreplace $b $i $i]
3837 return [expr {$a eq $b}]
3840 proc makeupline {id row rend col} {
3841 global rowidlist uparrowlen downarrowlen mingaplen
3843 for {set r $rend} {1} {set r $rstart} {
3844 set rstart [prevuse $id $r]
3845 if {$rstart < 0} return
3846 if {$rstart < $row} break
3848 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3849 set rstart [expr {$rend - $uparrowlen - 1}]
3851 for {set r $rstart} {[incr r] <= $row} {} {
3852 set idlist [lindex $rowidlist $r]
3853 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3854 set col [idcol $idlist $id $col]
3855 lset rowidlist $r [linsert $idlist $col $id]
3861 proc layoutrows {row endrow} {
3862 global rowidlist rowisopt rowfinal displayorder
3863 global uparrowlen downarrowlen maxwidth mingaplen
3864 global children parentlist
3865 global commitidx viewcomplete curview
3867 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3870 set rm1 [expr {$row - 1}]
3871 foreach id [lindex $rowidlist $rm1] {
3876 set final [lindex $rowfinal $rm1]
3878 for {} {$row < $endrow} {incr row} {
3879 set rm1 [expr {$row - 1}]
3880 if {$rm1 < 0 || $idlist eq {}} {
3881 set idlist [make_idlist $row]
3884 set id [lindex $displayorder $rm1]
3885 set col [lsearch -exact $idlist $id]
3886 set idlist [lreplace $idlist $col $col]
3887 foreach p [lindex $parentlist $rm1] {
3888 if {[lsearch -exact $idlist $p] < 0} {
3889 set col [idcol $idlist $p $col]
3890 set idlist [linsert $idlist $col $p]
3891 # if not the first child, we have to insert a line going up
3892 if {$id ne [lindex $children($curview,$p) 0]} {
3893 makeupline $p $rm1 $row $col
3897 set id [lindex $displayorder $row]
3898 if {$row > $downarrowlen} {
3899 set termrow [expr {$row - $downarrowlen - 1}]
3900 foreach p [lindex $parentlist $termrow] {
3901 set i [lsearch -exact $idlist $p]
3902 if {$i < 0} continue
3903 set nr [nextuse $p $termrow]
3904 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3905 set idlist [lreplace $idlist $i $i]
3909 set col [lsearch -exact $idlist $id]
3911 set col [idcol $idlist $id]
3912 set idlist [linsert $idlist $col $id]
3913 if {$children($curview,$id) ne {}} {
3914 makeupline $id $rm1 $row $col
3917 set r [expr {$row + $uparrowlen - 1}]
3918 if {$r < $commitidx($curview)} {
3920 foreach p [lindex $parentlist $r] {
3921 if {[lsearch -exact $idlist $p] >= 0} continue
3922 set fk [lindex $children($curview,$p) 0]
3923 if {[rowofcommit $fk] < $row} {
3924 set x [idcol $idlist $p $x]
3925 set idlist [linsert $idlist $x $p]
3928 if {[incr r] < $commitidx($curview)} {
3929 set p [lindex $displayorder $r]
3930 if {[lsearch -exact $idlist $p] < 0} {
3931 set fk [lindex $children($curview,$p) 0]
3932 if {$fk ne {} && [rowofcommit $fk] < $row} {
3933 set x [idcol $idlist $p $x]
3934 set idlist [linsert $idlist $x $p]
3940 if {$final && !$viewcomplete($curview) &&
3941 $row + $uparrowlen + $mingaplen + $downarrowlen
3942 >= $commitidx($curview)} {
3945 set l [llength $rowidlist]
3947 lappend rowidlist $idlist
3949 lappend rowfinal $final
3950 } elseif {$row < $l} {
3951 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3952 lset rowidlist $row $idlist
3955 lset rowfinal $row $final
3957 set pad [ntimes [expr {$row - $l}] {}]
3958 set rowidlist [concat $rowidlist $pad]
3959 lappend rowidlist $idlist
3960 set rowfinal [concat $rowfinal $pad]
3961 lappend rowfinal $final
3962 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3968 proc changedrow {row} {
3969 global displayorder iddrawn rowisopt need_redisplay
3971 set l [llength $rowisopt]
3973 lset rowisopt $row 0
3974 if {$row + 1 < $l} {
3975 lset rowisopt [expr {$row + 1}] 0
3976 if {$row + 2 < $l} {
3977 lset rowisopt [expr {$row + 2}] 0
3981 set id [lindex $displayorder $row]
3982 if {[info exists iddrawn($id)]} {
3983 set need_redisplay 1
3987 proc insert_pad {row col npad} {
3990 set pad [ntimes $npad {}]
3991 set idlist [lindex $rowidlist $row]
3992 set bef [lrange $idlist 0 [expr {$col - 1}]]
3993 set aft [lrange $idlist $col end]
3994 set i [lsearch -exact $aft {}]
3996 set aft [lreplace $aft $i $i]
3998 lset rowidlist $row [concat $bef $pad $aft]
4002 proc optimize_rows {row col endrow} {
4003 global rowidlist rowisopt displayorder curview children
4008 for {} {$row < $endrow} {incr row; set col 0} {
4009 if {[lindex $rowisopt $row]} continue
4011 set y0 [expr {$row - 1}]
4012 set ym [expr {$row - 2}]
4013 set idlist [lindex $rowidlist $row]
4014 set previdlist [lindex $rowidlist $y0]
4015 if {$idlist eq {} || $previdlist eq {}} continue
4017 set pprevidlist [lindex $rowidlist $ym]
4018 if {$pprevidlist eq {}} continue
4024 for {} {$col < [llength $idlist]} {incr col} {
4025 set id [lindex $idlist $col]
4026 if {[lindex $previdlist $col] eq $id} continue
4031 set x0 [lsearch -exact $previdlist $id]
4032 if {$x0 < 0} continue
4033 set z [expr {$x0 - $col}]
4037 set xm [lsearch -exact $pprevidlist $id]
4039 set z0 [expr {$xm - $x0}]
4043 # if row y0 is the first child of $id then it's not an arrow
4044 if {[lindex $children($curview,$id) 0] ne
4045 [lindex $displayorder $y0]} {
4049 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4050 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4053 # Looking at lines from this row to the previous row,
4054 # make them go straight up if they end in an arrow on
4055 # the previous row; otherwise make them go straight up
4057 if {$z < -1 || ($z < 0 && $isarrow)} {
4058 # Line currently goes left too much;
4059 # insert pads in the previous row, then optimize it
4060 set npad [expr {-1 - $z + $isarrow}]
4061 insert_pad $y0 $x0 $npad
4063 optimize_rows $y0 $x0 $row
4065 set previdlist [lindex $rowidlist $y0]
4066 set x0 [lsearch -exact $previdlist $id]
4067 set z [expr {$x0 - $col}]
4069 set pprevidlist [lindex $rowidlist $ym]
4070 set xm [lsearch -exact $pprevidlist $id]
4071 set z0 [expr {$xm - $x0}]
4073 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4074 # Line currently goes right too much;
4075 # insert pads in this line
4076 set npad [expr {$z - 1 + $isarrow}]
4077 insert_pad $row $col $npad
4078 set idlist [lindex $rowidlist $row]
4080 set z [expr {$x0 - $col}]
4083 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4084 # this line links to its first child on row $row-2
4085 set id [lindex $displayorder $ym]
4086 set xc [lsearch -exact $pprevidlist $id]
4088 set z0 [expr {$xc - $x0}]
4091 # avoid lines jigging left then immediately right
4092 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4093 insert_pad $y0 $x0 1
4095 optimize_rows $y0 $x0 $row
4096 set previdlist [lindex $rowidlist $y0]
4100 # Find the first column that doesn't have a line going right
4101 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4102 set id [lindex $idlist $col]
4103 if {$id eq {}} break
4104 set x0 [lsearch -exact $previdlist $id]
4106 # check if this is the link to the first child
4107 set kid [lindex $displayorder $y0]
4108 if {[lindex $children($curview,$id) 0] eq $kid} {
4109 # it is, work out offset to child
4110 set x0 [lsearch -exact $previdlist $kid]
4113 if {$x0 <= $col} break
4115 # Insert a pad at that column as long as it has a line and
4116 # isn't the last column
4117 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4118 set idlist [linsert $idlist $col {}]
4119 lset rowidlist $row $idlist
4127 global canvx0 linespc
4128 return [expr {$canvx0 + $col * $linespc}]
4132 global canvy0 linespc
4133 return [expr {$canvy0 + $row * $linespc}]
4136 proc linewidth {id} {
4137 global thickerline lthickness
4140 if {[info exists thickerline] && $id eq $thickerline} {
4141 set wid [expr {2 * $lthickness}]
4146 proc rowranges {id} {
4147 global curview children uparrowlen downarrowlen
4150 set kids $children($curview,$id)
4156 foreach child $kids {
4157 if {![commitinview $child $curview]} break
4158 set row [rowofcommit $child]
4159 if {![info exists prev]} {
4160 lappend ret [expr {$row + 1}]
4162 if {$row <= $prevrow} {
4163 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4165 # see if the line extends the whole way from prevrow to row
4166 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4167 [lsearch -exact [lindex $rowidlist \
4168 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4169 # it doesn't, see where it ends
4170 set r [expr {$prevrow + $downarrowlen}]
4171 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4172 while {[incr r -1] > $prevrow &&
4173 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4175 while {[incr r] <= $row &&
4176 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4180 # see where it starts up again
4181 set r [expr {$row - $uparrowlen}]
4182 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4183 while {[incr r] < $row &&
4184 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4186 while {[incr r -1] >= $prevrow &&
4187 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4193 if {$child eq $id} {
4202 proc drawlineseg {id row endrow arrowlow} {
4203 global rowidlist displayorder iddrawn linesegs
4204 global canv colormap linespc curview maxlinelen parentlist
4206 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4207 set le [expr {$row + 1}]
4210 set c [lsearch -exact [lindex $rowidlist $le] $id]
4216 set x [lindex $displayorder $le]
4221 if {[info exists iddrawn($x)] || $le == $endrow} {
4222 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4238 if {[info exists linesegs($id)]} {
4239 set lines $linesegs($id)
4241 set r0 [lindex $li 0]
4243 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4253 set li [lindex $lines [expr {$i-1}]]
4254 set r1 [lindex $li 1]
4255 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4260 set x [lindex $cols [expr {$le - $row}]]
4261 set xp [lindex $cols [expr {$le - 1 - $row}]]
4262 set dir [expr {$xp - $x}]
4264 set ith [lindex $lines $i 2]
4265 set coords [$canv coords $ith]
4266 set ah [$canv itemcget $ith -arrow]
4267 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4268 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4269 if {$x2 ne {} && $x - $x2 == $dir} {
4270 set coords [lrange $coords 0 end-2]
4273 set coords [list [xc $le $x] [yc $le]]
4276 set itl [lindex $lines [expr {$i-1}] 2]
4277 set al [$canv itemcget $itl -arrow]
4278 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4279 } elseif {$arrowlow} {
4280 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4281 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4285 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4286 for {set y $le} {[incr y -1] > $row} {} {
4288 set xp [lindex $cols [expr {$y - 1 - $row}]]
4289 set ndir [expr {$xp - $x}]
4290 if {$dir != $ndir || $xp < 0} {
4291 lappend coords [xc $y $x] [yc $y]
4297 # join parent line to first child
4298 set ch [lindex $displayorder $row]
4299 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4301 puts "oops: drawlineseg: child $ch not on row $row"
4302 } elseif {$xc != $x} {
4303 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4304 set d [expr {int(0.5 * $linespc)}]
4307 set x2 [expr {$x1 - $d}]
4309 set x2 [expr {$x1 + $d}]
4312 set y1 [expr {$y2 + $d}]
4313 lappend coords $x1 $y1 $x2 $y2
4314 } elseif {$xc < $x - 1} {
4315 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4316 } elseif {$xc > $x + 1} {
4317 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4321 lappend coords [xc $row $x] [yc $row]
4323 set xn [xc $row $xp]
4325 lappend coords $xn $yn
4329 set t [$canv create line $coords -width [linewidth $id] \
4330 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4333 set lines [linsert $lines $i [list $row $le $t]]
4335 $canv coords $ith $coords
4336 if {$arrow ne $ah} {
4337 $canv itemconf $ith -arrow $arrow
4339 lset lines $i 0 $row
4342 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4343 set ndir [expr {$xo - $xp}]
4344 set clow [$canv coords $itl]
4345 if {$dir == $ndir} {
4346 set clow [lrange $clow 2 end]
4348 set coords [concat $coords $clow]
4350 lset lines [expr {$i-1}] 1 $le
4352 # coalesce two pieces
4354 set b [lindex $lines [expr {$i-1}] 0]
4355 set e [lindex $lines $i 1]
4356 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4358 $canv coords $itl $coords
4359 if {$arrow ne $al} {
4360 $canv itemconf $itl -arrow $arrow
4364 set linesegs($id) $lines
4368 proc drawparentlinks {id row} {
4369 global rowidlist canv colormap curview parentlist
4370 global idpos linespc
4372 set rowids [lindex $rowidlist $row]
4373 set col [lsearch -exact $rowids $id]
4374 if {$col < 0} return
4375 set olds [lindex $parentlist $row]
4376 set row2 [expr {$row + 1}]
4377 set x [xc $row $col]
4380 set d [expr {int(0.5 * $linespc)}]
4381 set ymid [expr {$y + $d}]
4382 set ids [lindex $rowidlist $row2]
4383 # rmx = right-most X coord used
4386 set i [lsearch -exact $ids $p]
4388 puts "oops, parent $p of $id not in list"
4391 set x2 [xc $row2 $i]
4395 set j [lsearch -exact $rowids $p]
4397 # drawlineseg will do this one for us
4401 # should handle duplicated parents here...
4402 set coords [list $x $y]
4404 # if attaching to a vertical segment, draw a smaller
4405 # slant for visual distinctness
4408 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4410 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4412 } elseif {$i < $col && $i < $j} {
4413 # segment slants towards us already
4414 lappend coords [xc $row $j] $y
4416 if {$i < $col - 1} {
4417 lappend coords [expr {$x2 + $linespc}] $y
4418 } elseif {$i > $col + 1} {
4419 lappend coords [expr {$x2 - $linespc}] $y
4421 lappend coords $x2 $y2
4424 lappend coords $x2 $y2
4426 set t [$canv create line $coords -width [linewidth $p] \
4427 -fill $colormap($p) -tags lines.$p]
4431 if {$rmx > [lindex $idpos($id) 1]} {
4432 lset idpos($id) 1 $rmx
4437 proc drawlines {id} {
4440 $canv itemconf lines.$id -width [linewidth $id]
4443 proc drawcmittext {id row col} {
4444 global linespc canv canv2 canv3 fgcolor curview
4445 global cmitlisted commitinfo rowidlist parentlist
4446 global rowtextx idpos idtags idheads idotherrefs
4447 global linehtag linentag linedtag selectedline
4448 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4450 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4451 set listed $cmitlisted($curview,$id)
4452 if {$id eq $nullid} {
4454 } elseif {$id eq $nullid2} {
4457 set ofill [expr {$listed != 0 ? $listed == 2 ? "gray" : "blue" : "white"}]
4459 set x [xc $row $col]
4461 set orad [expr {$linespc / 3}]
4463 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4464 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4465 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4466 } elseif {$listed == 3} {
4467 # triangle pointing left for left-side commits
4468 set t [$canv create polygon \
4469 [expr {$x - $orad}] $y \
4470 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4471 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4472 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4474 # triangle pointing right for right-side commits
4475 set t [$canv create polygon \
4476 [expr {$x + $orad - 1}] $y \
4477 [expr {$x - $orad}] [expr {$y - $orad}] \
4478 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4479 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4482 $canv bind $t <1> {selcanvline {} %x %y}
4483 set rmx [llength [lindex $rowidlist $row]]
4484 set olds [lindex $parentlist $row]
4486 set nextids [lindex $rowidlist [expr {$row + 1}]]
4488 set i [lsearch -exact $nextids $p]
4494 set xt [xc $row $rmx]
4495 set rowtextx($row) $xt
4496 set idpos($id) [list $x $xt $y]
4497 if {[info exists idtags($id)] || [info exists idheads($id)]
4498 || [info exists idotherrefs($id)]} {
4499 set xt [drawtags $id $x $xt $y]
4501 set headline [lindex $commitinfo($id) 0]
4502 set name [lindex $commitinfo($id) 1]
4503 set date [lindex $commitinfo($id) 2]
4504 set date [formatdate $date]
4507 set isbold [ishighlighted $id]
4509 lappend boldrows $row
4510 set font mainfontbold
4512 lappend boldnamerows $row
4513 set nfont mainfontbold
4516 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4517 -text $headline -font $font -tags text]
4518 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4519 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4520 -text $name -font $nfont -tags text]
4521 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4522 -text $date -font mainfont -tags text]
4523 if {[info exists selectedline] && $selectedline == $row} {
4526 set xr [expr {$xt + [font measure $font $headline]}]
4527 if {$xr > $canvxmax} {
4533 proc drawcmitrow {row} {
4534 global displayorder rowidlist nrows_drawn
4535 global iddrawn markingmatches
4536 global commitinfo numcommits
4537 global filehighlight fhighlights findpattern nhighlights
4538 global hlview vhighlights
4539 global highlight_related rhighlights
4541 if {$row >= $numcommits} return
4543 set id [lindex $displayorder $row]
4544 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4545 askvhighlight $row $id
4547 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4548 askfilehighlight $row $id
4550 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4551 askfindhighlight $row $id
4553 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4554 askrelhighlight $row $id
4556 if {![info exists iddrawn($id)]} {
4557 set col [lsearch -exact [lindex $rowidlist $row] $id]
4559 puts "oops, row $row id $id not in list"
4562 if {![info exists commitinfo($id)]} {
4566 drawcmittext $id $row $col
4570 if {$markingmatches} {
4571 markrowmatches $row $id
4575 proc drawcommits {row {endrow {}}} {
4576 global numcommits iddrawn displayorder curview need_redisplay
4577 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4582 if {$endrow eq {}} {
4585 if {$endrow >= $numcommits} {
4586 set endrow [expr {$numcommits - 1}]
4589 set rl1 [expr {$row - $downarrowlen - 3}]
4593 set ro1 [expr {$row - 3}]
4597 set r2 [expr {$endrow + $uparrowlen + 3}]
4598 if {$r2 > $numcommits} {
4601 for {set r $rl1} {$r < $r2} {incr r} {
4602 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4606 set rl1 [expr {$r + 1}]
4612 optimize_rows $ro1 0 $r2
4613 if {$need_redisplay || $nrows_drawn > 2000} {
4618 # make the lines join to already-drawn rows either side
4619 set r [expr {$row - 1}]
4620 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4623 set er [expr {$endrow + 1}]
4624 if {$er >= $numcommits ||
4625 ![info exists iddrawn([lindex $displayorder $er])]} {
4628 for {} {$r <= $er} {incr r} {
4629 set id [lindex $displayorder $r]
4630 set wasdrawn [info exists iddrawn($id)]
4632 if {$r == $er} break
4633 set nextid [lindex $displayorder [expr {$r + 1}]]
4634 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4635 drawparentlinks $id $r
4637 set rowids [lindex $rowidlist $r]
4638 foreach lid $rowids {
4639 if {$lid eq {}} continue
4640 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4642 # see if this is the first child of any of its parents
4643 foreach p [lindex $parentlist $r] {
4644 if {[lsearch -exact $rowids $p] < 0} {
4645 # make this line extend up to the child
4646 set lineend($p) [drawlineseg $p $r $er 0]
4650 set lineend($lid) [drawlineseg $lid $r $er 1]
4656 proc undolayout {row} {
4657 global uparrowlen mingaplen downarrowlen
4658 global rowidlist rowisopt rowfinal need_redisplay
4660 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4664 if {[llength $rowidlist] > $r} {
4666 set rowidlist [lrange $rowidlist 0 $r]
4667 set rowfinal [lrange $rowfinal 0 $r]
4668 set rowisopt [lrange $rowisopt 0 $r]
4669 set need_redisplay 1
4674 proc drawvisible {} {
4675 global canv linespc curview vrowmod selectedline targetrow targetid
4676 global need_redisplay cscroll numcommits
4678 set fs [$canv yview]
4679 set ymax [lindex [$canv cget -scrollregion] 3]
4680 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
4681 set f0 [lindex $fs 0]
4682 set f1 [lindex $fs 1]
4683 set y0 [expr {int($f0 * $ymax)}]
4684 set y1 [expr {int($f1 * $ymax)}]
4686 if {[info exists targetid]} {
4687 if {[commitinview $targetid $curview]} {
4688 set r [rowofcommit $targetid]
4689 if {$r != $targetrow} {
4690 # Fix up the scrollregion and change the scrolling position
4691 # now that our target row has moved.
4692 set diff [expr {($r - $targetrow) * $linespc}]
4695 set ymax [lindex [$canv cget -scrollregion] 3]
4698 set f0 [expr {$y0 / $ymax}]
4699 set f1 [expr {$y1 / $ymax}]
4700 allcanvs yview moveto $f0
4701 $cscroll set $f0 $f1
4702 set need_redisplay 1
4709 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4710 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4711 if {$endrow >= $vrowmod($curview)} {
4712 update_arcrows $curview
4714 if {[info exists selectedline] &&
4715 $row <= $selectedline && $selectedline <= $endrow} {
4716 set targetrow $selectedline
4718 set targetrow [expr {int(($row + $endrow) / 2)}]
4720 if {$targetrow >= $numcommits} {
4721 set targetrow [expr {$numcommits - 1}]
4723 set targetid [commitonrow $targetrow]
4724 drawcommits $row $endrow
4727 proc clear_display {} {
4728 global iddrawn linesegs need_redisplay nrows_drawn
4729 global vhighlights fhighlights nhighlights rhighlights
4732 catch {unset iddrawn}
4733 catch {unset linesegs}
4734 catch {unset vhighlights}
4735 catch {unset fhighlights}
4736 catch {unset nhighlights}
4737 catch {unset rhighlights}
4738 set need_redisplay 0
4742 proc findcrossings {id} {
4743 global rowidlist parentlist numcommits displayorder
4747 foreach {s e} [rowranges $id] {
4748 if {$e >= $numcommits} {
4749 set e [expr {$numcommits - 1}]
4751 if {$e <= $s} continue
4752 for {set row $e} {[incr row -1] >= $s} {} {
4753 set x [lsearch -exact [lindex $rowidlist $row] $id]
4755 set olds [lindex $parentlist $row]
4756 set kid [lindex $displayorder $row]
4757 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4758 if {$kidx < 0} continue
4759 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4761 set px [lsearch -exact $nextrow $p]
4762 if {$px < 0} continue
4763 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4764 if {[lsearch -exact $ccross $p] >= 0} continue
4765 if {$x == $px + ($kidx < $px? -1: 1)} {
4767 } elseif {[lsearch -exact $cross $p] < 0} {
4774 return [concat $ccross {{}} $cross]
4777 proc assigncolor {id} {
4778 global colormap colors nextcolor
4779 global parents children children curview
4781 if {[info exists colormap($id)]} return
4782 set ncolors [llength $colors]
4783 if {[info exists children($curview,$id)]} {
4784 set kids $children($curview,$id)
4788 if {[llength $kids] == 1} {
4789 set child [lindex $kids 0]
4790 if {[info exists colormap($child)]
4791 && [llength $parents($curview,$child)] == 1} {
4792 set colormap($id) $colormap($child)
4798 foreach x [findcrossings $id] {
4800 # delimiter between corner crossings and other crossings
4801 if {[llength $badcolors] >= $ncolors - 1} break
4802 set origbad $badcolors
4804 if {[info exists colormap($x)]
4805 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4806 lappend badcolors $colormap($x)
4809 if {[llength $badcolors] >= $ncolors} {
4810 set badcolors $origbad
4812 set origbad $badcolors
4813 if {[llength $badcolors] < $ncolors - 1} {
4814 foreach child $kids {
4815 if {[info exists colormap($child)]
4816 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4817 lappend badcolors $colormap($child)
4819 foreach p $parents($curview,$child) {
4820 if {[info exists colormap($p)]
4821 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4822 lappend badcolors $colormap($p)
4826 if {[llength $badcolors] >= $ncolors} {
4827 set badcolors $origbad
4830 for {set i 0} {$i <= $ncolors} {incr i} {
4831 set c [lindex $colors $nextcolor]
4832 if {[incr nextcolor] >= $ncolors} {
4835 if {[lsearch -exact $badcolors $c]} break
4837 set colormap($id) $c
4840 proc bindline {t id} {
4843 $canv bind $t <Enter> "lineenter %x %y $id"
4844 $canv bind $t <Motion> "linemotion %x %y $id"
4845 $canv bind $t <Leave> "lineleave $id"
4846 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4849 proc drawtags {id x xt y1} {
4850 global idtags idheads idotherrefs mainhead
4851 global linespc lthickness
4852 global canv rowtextx curview fgcolor bgcolor
4857 if {[info exists idtags($id)]} {
4858 set marks $idtags($id)
4859 set ntags [llength $marks]
4861 if {[info exists idheads($id)]} {
4862 set marks [concat $marks $idheads($id)]
4863 set nheads [llength $idheads($id)]
4865 if {[info exists idotherrefs($id)]} {
4866 set marks [concat $marks $idotherrefs($id)]
4872 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4873 set yt [expr {$y1 - 0.5 * $linespc}]
4874 set yb [expr {$yt + $linespc - 1}]
4878 foreach tag $marks {
4880 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4881 set wid [font measure mainfontbold $tag]
4883 set wid [font measure mainfont $tag]
4887 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4889 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4890 -width $lthickness -fill black -tags tag.$id]
4892 foreach tag $marks x $xvals wid $wvals {
4893 set xl [expr {$x + $delta}]
4894 set xr [expr {$x + $delta + $wid + $lthickness}]
4896 if {[incr ntags -1] >= 0} {
4898 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4899 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4900 -width 1 -outline black -fill yellow -tags tag.$id]
4901 $canv bind $t <1> [list showtag $tag 1]
4902 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4904 # draw a head or other ref
4905 if {[incr nheads -1] >= 0} {
4907 if {$tag eq $mainhead} {
4908 set font mainfontbold
4913 set xl [expr {$xl - $delta/2}]
4914 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4915 -width 1 -outline black -fill $col -tags tag.$id
4916 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4917 set rwid [font measure mainfont $remoteprefix]
4918 set xi [expr {$x + 1}]
4919 set yti [expr {$yt + 1}]
4920 set xri [expr {$x + $rwid}]
4921 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4922 -width 0 -fill "#ffddaa" -tags tag.$id
4925 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4926 -font $font -tags [list tag.$id text]]
4928 $canv bind $t <1> [list showtag $tag 1]
4929 } elseif {$nheads >= 0} {
4930 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4936 proc xcoord {i level ln} {
4937 global canvx0 xspc1 xspc2
4939 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4940 if {$i > 0 && $i == $level} {
4941 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4942 } elseif {$i > $level} {
4943 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4948 proc show_status {msg} {
4952 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4953 -tags text -fill $fgcolor
4956 # Don't change the text pane cursor if it is currently the hand cursor,
4957 # showing that we are over a sha1 ID link.
4958 proc settextcursor {c} {
4959 global ctext curtextcursor
4961 if {[$ctext cget -cursor] == $curtextcursor} {
4962 $ctext config -cursor $c
4964 set curtextcursor $c
4967 proc nowbusy {what {name {}}} {
4968 global isbusy busyname statusw
4970 if {[array names isbusy] eq {}} {
4971 . config -cursor watch
4975 set busyname($what) $name
4977 $statusw conf -text $name
4981 proc notbusy {what} {
4982 global isbusy maincursor textcursor busyname statusw
4986 if {$busyname($what) ne {} &&
4987 [$statusw cget -text] eq $busyname($what)} {
4988 $statusw conf -text {}
4991 if {[array names isbusy] eq {}} {
4992 . config -cursor $maincursor
4993 settextcursor $textcursor
4997 proc findmatches {f} {
4998 global findtype findstring
4999 if {$findtype == [mc "Regexp"]} {
5000 set matches [regexp -indices -all -inline $findstring $f]
5003 if {$findtype == [mc "IgnCase"]} {
5004 set f [string tolower $f]
5005 set fs [string tolower $fs]
5009 set l [string length $fs]
5010 while {[set j [string first $fs $f $i]] >= 0} {
5011 lappend matches [list $j [expr {$j+$l-1}]]
5012 set i [expr {$j + $l}]
5018 proc dofind {{dirn 1} {wrap 1}} {
5019 global findstring findstartline findcurline selectedline numcommits
5020 global gdttype filehighlight fh_serial find_dirn findallowwrap
5022 if {[info exists find_dirn]} {
5023 if {$find_dirn == $dirn} return
5027 if {$findstring eq {} || $numcommits == 0} return
5028 if {![info exists selectedline]} {
5029 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5031 set findstartline $selectedline
5033 set findcurline $findstartline
5034 nowbusy finding [mc "Searching"]
5035 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5036 after cancel do_file_hl $fh_serial
5037 do_file_hl $fh_serial
5040 set findallowwrap $wrap
5044 proc stopfinding {} {
5045 global find_dirn findcurline fprogcoord
5047 if {[info exists find_dirn]} {
5057 global commitdata commitinfo numcommits findpattern findloc
5058 global findstartline findcurline findallowwrap
5059 global find_dirn gdttype fhighlights fprogcoord
5060 global curview varcorder vrownum varccommits vrowmod
5062 if {![info exists find_dirn]} {
5065 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5068 if {$find_dirn > 0} {
5070 if {$l >= $numcommits} {
5073 if {$l <= $findstartline} {
5074 set lim [expr {$findstartline + 1}]
5077 set moretodo $findallowwrap
5084 if {$l >= $findstartline} {
5085 set lim [expr {$findstartline - 1}]
5088 set moretodo $findallowwrap
5091 set n [expr {($lim - $l) * $find_dirn}]
5096 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5097 update_arcrows $curview
5101 set ai [bsearch $vrownum($curview) $l]
5102 set a [lindex $varcorder($curview) $ai]
5103 set arow [lindex $vrownum($curview) $ai]
5104 set ids [lindex $varccommits($curview,$a)]
5105 set arowend [expr {$arow + [llength $ids]}]
5106 if {$gdttype eq [mc "containing:"]} {
5107 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5108 if {$l < $arow || $l >= $arowend} {
5110 set a [lindex $varcorder($curview) $ai]
5111 set arow [lindex $vrownum($curview) $ai]
5112 set ids [lindex $varccommits($curview,$a)]
5113 set arowend [expr {$arow + [llength $ids]}]
5115 set id [lindex $ids [expr {$l - $arow}]]
5116 # shouldn't happen unless git log doesn't give all the commits...
5117 if {![info exists commitdata($id)] ||
5118 ![doesmatch $commitdata($id)]} {
5121 if {![info exists commitinfo($id)]} {
5124 set info $commitinfo($id)
5125 foreach f $info ty $fldtypes {
5126 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5135 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5136 if {$l < $arow || $l >= $arowend} {
5138 set a [lindex $varcorder($curview) $ai]
5139 set arow [lindex $vrownum($curview) $ai]
5140 set ids [lindex $varccommits($curview,$a)]
5141 set arowend [expr {$arow + [llength $ids]}]
5143 set id [lindex $ids [expr {$l - $arow}]]
5144 if {![info exists fhighlights($id)]} {
5145 # this sets fhighlights($id) to -1
5146 askfilehighlight $l $id
5148 if {$fhighlights($id) > 0} {
5152 if {$fhighlights($id) < 0} {
5155 set findcurline [expr {$l - $find_dirn}]
5160 if {$found || ($domore && !$moretodo)} {
5176 set findcurline [expr {$l - $find_dirn}]
5178 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5182 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5187 proc findselectline {l} {
5188 global findloc commentend ctext findcurline markingmatches gdttype
5190 set markingmatches 1
5193 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5194 # highlight the matches in the comments
5195 set f [$ctext get 1.0 $commentend]
5196 set matches [findmatches $f]
5197 foreach match $matches {
5198 set start [lindex $match 0]
5199 set end [expr {[lindex $match 1] + 1}]
5200 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5206 # mark the bits of a headline or author that match a find string
5207 proc markmatches {canv l str tag matches font row} {
5210 set bbox [$canv bbox $tag]
5211 set x0 [lindex $bbox 0]
5212 set y0 [lindex $bbox 1]
5213 set y1 [lindex $bbox 3]
5214 foreach match $matches {
5215 set start [lindex $match 0]
5216 set end [lindex $match 1]
5217 if {$start > $end} continue
5218 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5219 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5220 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5221 [expr {$x0+$xlen+2}] $y1 \
5222 -outline {} -tags [list match$l matches] -fill yellow]
5224 if {[info exists selectedline] && $row == $selectedline} {
5225 $canv raise $t secsel
5230 proc unmarkmatches {} {
5231 global markingmatches
5233 allcanvs delete matches
5234 set markingmatches 0
5238 proc selcanvline {w x y} {
5239 global canv canvy0 ctext linespc
5241 set ymax [lindex [$canv cget -scrollregion] 3]
5242 if {$ymax == {}} return
5243 set yfrac [lindex [$canv yview] 0]
5244 set y [expr {$y + $yfrac * $ymax}]
5245 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5250 set xmax [lindex [$canv cget -scrollregion] 2]
5251 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5252 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5258 proc commit_descriptor {p} {
5260 if {![info exists commitinfo($p)]} {
5264 if {[llength $commitinfo($p)] > 1} {
5265 set l [lindex $commitinfo($p) 0]
5270 # append some text to the ctext widget, and make any SHA1 ID
5271 # that we know about be a clickable link.
5272 proc appendwithlinks {text tags} {
5273 global ctext linknum curview pendinglinks
5275 set start [$ctext index "end - 1c"]
5276 $ctext insert end $text $tags
5277 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5281 set linkid [string range $text $s $e]
5283 $ctext tag delete link$linknum
5284 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5285 setlink $linkid link$linknum
5290 proc setlink {id lk} {
5291 global curview ctext pendinglinks commitinterest
5293 if {[commitinview $id $curview]} {
5294 $ctext tag conf $lk -foreground blue -underline 1
5295 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5296 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5297 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5299 lappend pendinglinks($id) $lk
5300 lappend commitinterest($id) {makelink %I}
5304 proc makelink {id} {
5307 if {![info exists pendinglinks($id)]} return
5308 foreach lk $pendinglinks($id) {
5311 unset pendinglinks($id)
5314 proc linkcursor {w inc} {
5315 global linkentercount curtextcursor
5317 if {[incr linkentercount $inc] > 0} {
5318 $w configure -cursor hand2
5320 $w configure -cursor $curtextcursor
5321 if {$linkentercount < 0} {
5322 set linkentercount 0
5327 proc viewnextline {dir} {
5331 set ymax [lindex [$canv cget -scrollregion] 3]
5332 set wnow [$canv yview]
5333 set wtop [expr {[lindex $wnow 0] * $ymax}]
5334 set newtop [expr {$wtop + $dir * $linespc}]
5337 } elseif {$newtop > $ymax} {
5340 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5343 # add a list of tag or branch names at position pos
5344 # returns the number of names inserted
5345 proc appendrefs {pos ids var} {
5346 global ctext linknum curview $var maxrefs
5348 if {[catch {$ctext index $pos}]} {
5351 $ctext conf -state normal
5352 $ctext delete $pos "$pos lineend"
5355 foreach tag [set $var\($id\)] {
5356 lappend tags [list $tag $id]
5359 if {[llength $tags] > $maxrefs} {
5360 $ctext insert $pos "many ([llength $tags])"
5362 set tags [lsort -index 0 -decreasing $tags]
5365 set id [lindex $ti 1]
5368 $ctext tag delete $lk
5369 $ctext insert $pos $sep
5370 $ctext insert $pos [lindex $ti 0] $lk
5375 $ctext conf -state disabled
5376 return [llength $tags]
5379 # called when we have finished computing the nearby tags
5380 proc dispneartags {delay} {
5381 global selectedline currentid showneartags tagphase
5383 if {![info exists selectedline] || !$showneartags} return
5384 after cancel dispnexttag
5386 after 200 dispnexttag
5389 after idle dispnexttag
5394 proc dispnexttag {} {
5395 global selectedline currentid showneartags tagphase ctext
5397 if {![info exists selectedline] || !$showneartags} return
5398 switch -- $tagphase {
5400 set dtags [desctags $currentid]
5402 appendrefs precedes $dtags idtags
5406 set atags [anctags $currentid]
5408 appendrefs follows $atags idtags
5412 set dheads [descheads $currentid]
5413 if {$dheads ne {}} {
5414 if {[appendrefs branch $dheads idheads] > 1
5415 && [$ctext get "branch -3c"] eq "h"} {
5416 # turn "Branch" into "Branches"
5417 $ctext conf -state normal
5418 $ctext insert "branch -2c" "es"
5419 $ctext conf -state disabled
5424 if {[incr tagphase] <= 2} {
5425 after idle dispnexttag
5429 proc make_secsel {l} {
5430 global linehtag linentag linedtag canv canv2 canv3
5432 if {![info exists linehtag($l)]} return
5434 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5435 -tags secsel -fill [$canv cget -selectbackground]]
5437 $canv2 delete secsel
5438 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5439 -tags secsel -fill [$canv2 cget -selectbackground]]
5441 $canv3 delete secsel
5442 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5443 -tags secsel -fill [$canv3 cget -selectbackground]]
5447 proc selectline {l isnew} {
5448 global canv ctext commitinfo selectedline
5449 global canvy0 linespc parents children curview
5450 global currentid sha1entry
5451 global commentend idtags linknum
5452 global mergemax numcommits pending_select
5453 global cmitmode showneartags allcommits
5454 global targetrow targetid
5456 catch {unset pending_select}
5461 if {$l < 0 || $l >= $numcommits} return
5462 set y [expr {$canvy0 + $l * $linespc}]
5463 set ymax [lindex [$canv cget -scrollregion] 3]
5464 set ytop [expr {$y - $linespc - 1}]
5465 set ybot [expr {$y + $linespc + 1}]
5466 set wnow [$canv yview]
5467 set wtop [expr {[lindex $wnow 0] * $ymax}]
5468 set wbot [expr {[lindex $wnow 1] * $ymax}]
5469 set wh [expr {$wbot - $wtop}]
5471 if {$ytop < $wtop} {
5472 if {$ybot < $wtop} {
5473 set newtop [expr {$y - $wh / 2.0}]
5476 if {$newtop > $wtop - $linespc} {
5477 set newtop [expr {$wtop - $linespc}]
5480 } elseif {$ybot > $wbot} {
5481 if {$ytop > $wbot} {
5482 set newtop [expr {$y - $wh / 2.0}]
5484 set newtop [expr {$ybot - $wh}]
5485 if {$newtop < $wtop + $linespc} {
5486 set newtop [expr {$wtop + $linespc}]
5490 if {$newtop != $wtop} {
5494 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5500 set id [commitonrow $l]
5502 addtohistory [list selbyid $id]
5509 $sha1entry delete 0 end
5510 $sha1entry insert 0 $id
5511 $sha1entry selection from 0
5512 $sha1entry selection to end
5515 $ctext conf -state normal
5518 set info $commitinfo($id)
5519 set date [formatdate [lindex $info 2]]
5520 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5521 set date [formatdate [lindex $info 4]]
5522 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5523 if {[info exists idtags($id)]} {
5524 $ctext insert end [mc "Tags:"]
5525 foreach tag $idtags($id) {
5526 $ctext insert end " $tag"
5528 $ctext insert end "\n"
5532 set olds $parents($curview,$id)
5533 if {[llength $olds] > 1} {
5536 if {$np >= $mergemax} {
5541 $ctext insert end "[mc "Parent"]: " $tag
5542 appendwithlinks [commit_descriptor $p] {}
5547 append headers "[mc "Parent"]: [commit_descriptor $p]"
5551 foreach c $children($curview,$id) {
5552 append headers "[mc "Child"]: [commit_descriptor $c]"
5555 # make anything that looks like a SHA1 ID be a clickable link
5556 appendwithlinks $headers {}
5557 if {$showneartags} {
5558 if {![info exists allcommits]} {
5561 $ctext insert end "[mc "Branch"]: "
5562 $ctext mark set branch "end -1c"
5563 $ctext mark gravity branch left
5564 $ctext insert end "\n[mc "Follows"]: "
5565 $ctext mark set follows "end -1c"
5566 $ctext mark gravity follows left
5567 $ctext insert end "\n[mc "Precedes"]: "
5568 $ctext mark set precedes "end -1c"
5569 $ctext mark gravity precedes left
5570 $ctext insert end "\n"
5573 $ctext insert end "\n"
5574 set comment [lindex $info 5]
5575 if {[string first "\r" $comment] >= 0} {
5576 set comment [string map {"\r" "\n "} $comment]
5578 appendwithlinks $comment {comment}
5580 $ctext tag remove found 1.0 end
5581 $ctext conf -state disabled
5582 set commentend [$ctext index "end - 1c"]
5584 init_flist [mc "Comments"]
5585 if {$cmitmode eq "tree"} {
5587 } elseif {[llength $olds] <= 1} {
5594 proc selfirstline {} {
5599 proc sellastline {} {
5602 set l [expr {$numcommits - 1}]
5606 proc selnextline {dir} {
5609 if {![info exists selectedline]} return
5610 set l [expr {$selectedline + $dir}]
5615 proc selnextpage {dir} {
5616 global canv linespc selectedline numcommits
5618 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5622 allcanvs yview scroll [expr {$dir * $lpp}] units
5624 if {![info exists selectedline]} return
5625 set l [expr {$selectedline + $dir * $lpp}]
5628 } elseif {$l >= $numcommits} {
5629 set l [expr $numcommits - 1]
5635 proc unselectline {} {
5636 global selectedline currentid
5638 catch {unset selectedline}
5639 catch {unset currentid}
5640 allcanvs delete secsel
5644 proc reselectline {} {
5647 if {[info exists selectedline]} {
5648 selectline $selectedline 0
5652 proc addtohistory {cmd} {
5653 global history historyindex curview
5655 set elt [list $curview $cmd]
5656 if {$historyindex > 0
5657 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5661 if {$historyindex < [llength $history]} {
5662 set history [lreplace $history $historyindex end $elt]
5664 lappend history $elt
5667 if {$historyindex > 1} {
5668 .tf.bar.leftbut conf -state normal
5670 .tf.bar.leftbut conf -state disabled
5672 .tf.bar.rightbut conf -state disabled
5678 set view [lindex $elt 0]
5679 set cmd [lindex $elt 1]
5680 if {$curview != $view} {
5687 global history historyindex
5690 if {$historyindex > 1} {
5691 incr historyindex -1
5692 godo [lindex $history [expr {$historyindex - 1}]]
5693 .tf.bar.rightbut conf -state normal
5695 if {$historyindex <= 1} {
5696 .tf.bar.leftbut conf -state disabled
5701 global history historyindex
5704 if {$historyindex < [llength $history]} {
5705 set cmd [lindex $history $historyindex]
5708 .tf.bar.leftbut conf -state normal
5710 if {$historyindex >= [llength $history]} {
5711 .tf.bar.rightbut conf -state disabled
5716 global treefilelist treeidlist diffids diffmergeid treepending
5717 global nullid nullid2
5720 catch {unset diffmergeid}
5721 if {![info exists treefilelist($id)]} {
5722 if {![info exists treepending]} {
5723 if {$id eq $nullid} {
5724 set cmd [list | git ls-files]
5725 } elseif {$id eq $nullid2} {
5726 set cmd [list | git ls-files --stage -t]
5728 set cmd [list | git ls-tree -r $id]
5730 if {[catch {set gtf [open $cmd r]}]} {
5734 set treefilelist($id) {}
5735 set treeidlist($id) {}
5736 fconfigure $gtf -blocking 0
5737 filerun $gtf [list gettreeline $gtf $id]
5744 proc gettreeline {gtf id} {
5745 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5748 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5749 if {$diffids eq $nullid} {
5752 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5753 set i [string first "\t" $line]
5754 if {$i < 0} continue
5755 set sha1 [lindex $line 2]
5756 set fname [string range $line [expr {$i+1}] end]
5757 if {[string index $fname 0] eq "\""} {
5758 set fname [lindex $fname 0]
5760 lappend treeidlist($id) $sha1
5762 lappend treefilelist($id) $fname
5765 return [expr {$nl >= 1000? 2: 1}]
5769 if {$cmitmode ne "tree"} {
5770 if {![info exists diffmergeid]} {
5771 gettreediffs $diffids
5773 } elseif {$id ne $diffids} {
5782 global treefilelist treeidlist diffids nullid nullid2
5783 global ctext commentend
5785 set i [lsearch -exact $treefilelist($diffids) $f]
5787 puts "oops, $f not in list for id $diffids"
5790 if {$diffids eq $nullid} {
5791 if {[catch {set bf [open $f r]} err]} {
5792 puts "oops, can't read $f: $err"
5796 set blob [lindex $treeidlist($diffids) $i]
5797 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5798 puts "oops, error reading blob $blob: $err"
5802 fconfigure $bf -blocking 0
5803 filerun $bf [list getblobline $bf $diffids]
5804 $ctext config -state normal
5805 clear_ctext $commentend
5806 $ctext insert end "\n"
5807 $ctext insert end "$f\n" filesep
5808 $ctext config -state disabled
5809 $ctext yview $commentend
5813 proc getblobline {bf id} {
5814 global diffids cmitmode ctext
5816 if {$id ne $diffids || $cmitmode ne "tree"} {
5820 $ctext config -state normal
5822 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5823 $ctext insert end "$line\n"
5826 # delete last newline
5827 $ctext delete "end - 2c" "end - 1c"
5831 $ctext config -state disabled
5832 return [expr {$nl >= 1000? 2: 1}]
5835 proc mergediff {id} {
5836 global diffmergeid mdifffd
5840 global limitdiffs viewfiles curview
5844 # this doesn't seem to actually affect anything...
5845 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
5846 if {$limitdiffs && $viewfiles($curview) ne {}} {
5847 set cmd [concat $cmd -- $viewfiles($curview)]
5849 if {[catch {set mdf [open $cmd r]} err]} {
5850 error_popup "[mc "Error getting merge diffs:"] $err"
5853 fconfigure $mdf -blocking 0
5854 set mdifffd($id) $mdf
5855 set np [llength $parents($curview,$id)]
5857 filerun $mdf [list getmergediffline $mdf $id $np]
5860 proc getmergediffline {mdf id np} {
5861 global diffmergeid ctext cflist mergemax
5862 global difffilestart mdifffd
5864 $ctext conf -state normal
5866 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5867 if {![info exists diffmergeid] || $id != $diffmergeid
5868 || $mdf != $mdifffd($id)} {
5872 if {[regexp {^diff --cc (.*)} $line match fname]} {
5873 # start of a new file
5874 $ctext insert end "\n"
5875 set here [$ctext index "end - 1c"]
5876 lappend difffilestart $here
5877 add_flist [list $fname]
5878 set l [expr {(78 - [string length $fname]) / 2}]
5879 set pad [string range "----------------------------------------" 1 $l]
5880 $ctext insert end "$pad $fname $pad\n" filesep
5881 } elseif {[regexp {^@@} $line]} {
5882 $ctext insert end "$line\n" hunksep
5883 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5886 # parse the prefix - one ' ', '-' or '+' for each parent
5891 for {set j 0} {$j < $np} {incr j} {
5892 set c [string range $line $j $j]
5895 } elseif {$c == "-"} {
5897 } elseif {$c == "+"} {
5906 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5907 # line doesn't appear in result, parents in $minuses have the line
5908 set num [lindex $minuses 0]
5909 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5910 # line appears in result, parents in $pluses don't have the line
5911 lappend tags mresult
5912 set num [lindex $spaces 0]
5915 if {$num >= $mergemax} {
5920 $ctext insert end "$line\n" $tags
5923 $ctext conf -state disabled
5928 return [expr {$nr >= 1000? 2: 1}]
5931 proc startdiff {ids} {
5932 global treediffs diffids treepending diffmergeid nullid nullid2
5936 catch {unset diffmergeid}
5937 if {![info exists treediffs($ids)] ||
5938 [lsearch -exact $ids $nullid] >= 0 ||
5939 [lsearch -exact $ids $nullid2] >= 0} {
5940 if {![info exists treepending]} {
5948 proc path_filter {filter name} {
5950 set l [string length $p]
5951 if {[string index $p end] eq "/"} {
5952 if {[string compare -length $l $p $name] == 0} {
5956 if {[string compare -length $l $p $name] == 0 &&
5957 ([string length $name] == $l ||
5958 [string index $name $l] eq "/")} {
5966 proc addtocflist {ids} {
5969 add_flist $treediffs($ids)
5973 proc diffcmd {ids flags} {
5974 global nullid nullid2
5976 set i [lsearch -exact $ids $nullid]
5977 set j [lsearch -exact $ids $nullid2]
5979 if {[llength $ids] > 1 && $j < 0} {
5980 # comparing working directory with some specific revision
5981 set cmd [concat | git diff-index $flags]
5983 lappend cmd -R [lindex $ids 1]
5985 lappend cmd [lindex $ids 0]
5988 # comparing working directory with index
5989 set cmd [concat | git diff-files $flags]
5994 } elseif {$j >= 0} {
5995 set cmd [concat | git diff-index --cached $flags]
5996 if {[llength $ids] > 1} {
5997 # comparing index with specific revision
5999 lappend cmd -R [lindex $ids 1]
6001 lappend cmd [lindex $ids 0]
6004 # comparing index with HEAD
6008 set cmd [concat | git diff-tree -r $flags $ids]
6013 proc gettreediffs {ids} {
6014 global treediff treepending
6016 set treepending $ids
6018 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6019 fconfigure $gdtf -blocking 0
6020 filerun $gdtf [list gettreediffline $gdtf $ids]
6023 proc gettreediffline {gdtf ids} {
6024 global treediff treediffs treepending diffids diffmergeid
6025 global cmitmode viewfiles curview limitdiffs
6028 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6029 set i [string first "\t" $line]
6031 set file [string range $line [expr {$i+1}] end]
6032 if {[string index $file 0] eq "\""} {
6033 set file [lindex $file 0]
6035 lappend treediff $file
6039 return [expr {$nr >= 1000? 2: 1}]
6042 if {$limitdiffs && $viewfiles($curview) ne {}} {
6044 foreach f $treediff {
6045 if {[path_filter $viewfiles($curview) $f]} {
6049 set treediffs($ids) $flist
6051 set treediffs($ids) $treediff
6054 if {$cmitmode eq "tree"} {
6056 } elseif {$ids != $diffids} {
6057 if {![info exists diffmergeid]} {
6058 gettreediffs $diffids
6066 # empty string or positive integer
6067 proc diffcontextvalidate {v} {
6068 return [regexp {^(|[1-9][0-9]*)$} $v]
6071 proc diffcontextchange {n1 n2 op} {
6072 global diffcontextstring diffcontext
6074 if {[string is integer -strict $diffcontextstring]} {
6075 if {$diffcontextstring > 0} {
6076 set diffcontext $diffcontextstring
6082 proc changeignorespace {} {
6086 proc getblobdiffs {ids} {
6087 global blobdifffd diffids env
6088 global diffinhdr treediffs
6091 global limitdiffs viewfiles curview
6093 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6097 if {$limitdiffs && $viewfiles($curview) ne {}} {
6098 set cmd [concat $cmd -- $viewfiles($curview)]
6100 if {[catch {set bdf [open $cmd r]} err]} {
6101 puts "error getting diffs: $err"
6105 fconfigure $bdf -blocking 0
6106 set blobdifffd($ids) $bdf
6107 filerun $bdf [list getblobdiffline $bdf $diffids]
6110 proc setinlist {var i val} {
6113 while {[llength [set $var]] < $i} {
6116 if {[llength [set $var]] == $i} {
6123 proc makediffhdr {fname ids} {
6124 global ctext curdiffstart treediffs
6126 set i [lsearch -exact $treediffs($ids) $fname]
6128 setinlist difffilestart $i $curdiffstart
6130 set l [expr {(78 - [string length $fname]) / 2}]
6131 set pad [string range "----------------------------------------" 1 $l]
6132 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6135 proc getblobdiffline {bdf ids} {
6136 global diffids blobdifffd ctext curdiffstart
6137 global diffnexthead diffnextnote difffilestart
6138 global diffinhdr treediffs
6141 $ctext conf -state normal
6142 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6143 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6147 if {![string compare -length 11 "diff --git " $line]} {
6148 # trim off "diff --git "
6149 set line [string range $line 11 end]
6151 # start of a new file
6152 $ctext insert end "\n"
6153 set curdiffstart [$ctext index "end - 1c"]
6154 $ctext insert end "\n" filesep
6155 # If the name hasn't changed the length will be odd,
6156 # the middle char will be a space, and the two bits either
6157 # side will be a/name and b/name, or "a/name" and "b/name".
6158 # If the name has changed we'll get "rename from" and
6159 # "rename to" or "copy from" and "copy to" lines following this,
6160 # and we'll use them to get the filenames.
6161 # This complexity is necessary because spaces in the filename(s)
6162 # don't get escaped.
6163 set l [string length $line]
6164 set i [expr {$l / 2}]
6165 if {!(($l & 1) && [string index $line $i] eq " " &&
6166 [string range $line 2 [expr {$i - 1}]] eq \
6167 [string range $line [expr {$i + 3}] end])} {
6170 # unescape if quoted and chop off the a/ from the front
6171 if {[string index $line 0] eq "\""} {
6172 set fname [string range [lindex $line 0] 2 end]
6174 set fname [string range $line 2 [expr {$i - 1}]]
6176 makediffhdr $fname $ids
6178 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6179 $line match f1l f1c f2l f2c rest]} {
6180 $ctext insert end "$line\n" hunksep
6183 } elseif {$diffinhdr} {
6184 if {![string compare -length 12 "rename from " $line]} {
6185 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6186 if {[string index $fname 0] eq "\""} {
6187 set fname [lindex $fname 0]
6189 set i [lsearch -exact $treediffs($ids) $fname]
6191 setinlist difffilestart $i $curdiffstart
6193 } elseif {![string compare -length 10 $line "rename to "] ||
6194 ![string compare -length 8 $line "copy to "]} {
6195 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6196 if {[string index $fname 0] eq "\""} {
6197 set fname [lindex $fname 0]
6199 makediffhdr $fname $ids
6200 } elseif {[string compare -length 3 $line "---"] == 0} {
6203 } elseif {[string compare -length 3 $line "+++"] == 0} {
6207 $ctext insert end "$line\n" filesep
6210 set x [string range $line 0 0]
6211 if {$x == "-" || $x == "+"} {
6212 set tag [expr {$x == "+"}]
6213 $ctext insert end "$line\n" d$tag
6214 } elseif {$x == " "} {
6215 $ctext insert end "$line\n"
6217 # "\ No newline at end of file",
6218 # or something else we don't recognize
6219 $ctext insert end "$line\n" hunksep
6223 $ctext conf -state disabled
6228 return [expr {$nr >= 1000? 2: 1}]
6231 proc changediffdisp {} {
6232 global ctext diffelide
6234 $ctext tag conf d0 -elide [lindex $diffelide 0]
6235 $ctext tag conf d1 -elide [lindex $diffelide 1]
6239 global difffilestart ctext
6240 set prev [lindex $difffilestart 0]
6241 set here [$ctext index @0,0]
6242 foreach loc $difffilestart {
6243 if {[$ctext compare $loc >= $here]} {
6253 global difffilestart ctext
6254 set here [$ctext index @0,0]
6255 foreach loc $difffilestart {
6256 if {[$ctext compare $loc > $here]} {
6263 proc clear_ctext {{first 1.0}} {
6264 global ctext smarktop smarkbot
6267 set l [lindex [split $first .] 0]
6268 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6271 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6274 $ctext delete $first end
6275 if {$first eq "1.0"} {
6276 catch {unset pendinglinks}
6280 proc settabs {{firstab {}}} {
6281 global firsttabstop tabstop ctext have_tk85
6283 if {$firstab ne {} && $have_tk85} {
6284 set firsttabstop $firstab
6286 set w [font measure textfont "0"]
6287 if {$firsttabstop != 0} {
6288 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6289 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6290 } elseif {$have_tk85 || $tabstop != 8} {
6291 $ctext conf -tabs [expr {$tabstop * $w}]
6293 $ctext conf -tabs {}
6297 proc incrsearch {name ix op} {
6298 global ctext searchstring searchdirn
6300 $ctext tag remove found 1.0 end
6301 if {[catch {$ctext index anchor}]} {
6302 # no anchor set, use start of selection, or of visible area
6303 set sel [$ctext tag ranges sel]
6305 $ctext mark set anchor [lindex $sel 0]
6306 } elseif {$searchdirn eq "-forwards"} {
6307 $ctext mark set anchor @0,0
6309 $ctext mark set anchor @0,[winfo height $ctext]
6312 if {$searchstring ne {}} {
6313 set here [$ctext search $searchdirn -- $searchstring anchor]
6322 global sstring ctext searchstring searchdirn
6325 $sstring icursor end
6326 set searchdirn -forwards
6327 if {$searchstring ne {}} {
6328 set sel [$ctext tag ranges sel]
6330 set start "[lindex $sel 0] + 1c"
6331 } elseif {[catch {set start [$ctext index anchor]}]} {
6334 set match [$ctext search -count mlen -- $searchstring $start]
6335 $ctext tag remove sel 1.0 end
6341 set mend "$match + $mlen c"
6342 $ctext tag add sel $match $mend
6343 $ctext mark unset anchor
6347 proc dosearchback {} {
6348 global sstring ctext searchstring searchdirn
6351 $sstring icursor end
6352 set searchdirn -backwards
6353 if {$searchstring ne {}} {
6354 set sel [$ctext tag ranges sel]
6356 set start [lindex $sel 0]
6357 } elseif {[catch {set start [$ctext index anchor]}]} {
6358 set start @0,[winfo height $ctext]
6360 set match [$ctext search -backwards -count ml -- $searchstring $start]
6361 $ctext tag remove sel 1.0 end
6367 set mend "$match + $ml c"
6368 $ctext tag add sel $match $mend
6369 $ctext mark unset anchor
6373 proc searchmark {first last} {
6374 global ctext searchstring
6378 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6379 if {$match eq {}} break
6380 set mend "$match + $mlen c"
6381 $ctext tag add found $match $mend
6385 proc searchmarkvisible {doall} {
6386 global ctext smarktop smarkbot
6388 set topline [lindex [split [$ctext index @0,0] .] 0]
6389 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6390 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6391 # no overlap with previous
6392 searchmark $topline $botline
6393 set smarktop $topline
6394 set smarkbot $botline
6396 if {$topline < $smarktop} {
6397 searchmark $topline [expr {$smarktop-1}]
6398 set smarktop $topline
6400 if {$botline > $smarkbot} {
6401 searchmark [expr {$smarkbot+1}] $botline
6402 set smarkbot $botline
6407 proc scrolltext {f0 f1} {
6410 .bleft.sb set $f0 $f1
6411 if {$searchstring ne {}} {
6417 global linespc charspc canvx0 canvy0
6418 global xspc1 xspc2 lthickness
6420 set linespc [font metrics mainfont -linespace]
6421 set charspc [font measure mainfont "m"]
6422 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6423 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6424 set lthickness [expr {int($linespc / 9) + 1}]
6425 set xspc1(0) $linespc
6433 set ymax [lindex [$canv cget -scrollregion] 3]
6434 if {$ymax eq {} || $ymax == 0} return
6435 set span [$canv yview]
6438 allcanvs yview moveto [lindex $span 0]
6440 if {[info exists selectedline]} {
6441 selectline $selectedline 0
6442 allcanvs yview moveto [lindex $span 0]
6446 proc parsefont {f n} {
6449 set fontattr($f,family) [lindex $n 0]
6451 if {$s eq {} || $s == 0} {
6454 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6456 set fontattr($f,size) $s
6457 set fontattr($f,weight) normal
6458 set fontattr($f,slant) roman
6459 foreach style [lrange $n 2 end] {
6462 "bold" {set fontattr($f,weight) $style}
6464 "italic" {set fontattr($f,slant) $style}
6469 proc fontflags {f {isbold 0}} {
6472 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6473 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6474 -slant $fontattr($f,slant)]
6480 set n [list $fontattr($f,family) $fontattr($f,size)]
6481 if {$fontattr($f,weight) eq "bold"} {
6484 if {$fontattr($f,slant) eq "italic"} {
6490 proc incrfont {inc} {
6491 global mainfont textfont ctext canv cflist showrefstop
6492 global stopped entries fontattr
6495 set s $fontattr(mainfont,size)
6500 set fontattr(mainfont,size) $s
6501 font config mainfont -size $s
6502 font config mainfontbold -size $s
6503 set mainfont [fontname mainfont]
6504 set s $fontattr(textfont,size)
6509 set fontattr(textfont,size) $s
6510 font config textfont -size $s
6511 font config textfontbold -size $s
6512 set textfont [fontname textfont]
6519 global sha1entry sha1string
6520 if {[string length $sha1string] == 40} {
6521 $sha1entry delete 0 end
6525 proc sha1change {n1 n2 op} {
6526 global sha1string currentid sha1but
6527 if {$sha1string == {}
6528 || ([info exists currentid] && $sha1string == $currentid)} {
6533 if {[$sha1but cget -state] == $state} return
6534 if {$state == "normal"} {
6535 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6537 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6541 proc gotocommit {} {
6542 global sha1string tagids headids curview varcid
6544 if {$sha1string == {}
6545 || ([info exists currentid] && $sha1string == $currentid)} return
6546 if {[info exists tagids($sha1string)]} {
6547 set id $tagids($sha1string)
6548 } elseif {[info exists headids($sha1string)]} {
6549 set id $headids($sha1string)
6551 set id [string tolower $sha1string]
6552 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6553 set matches [array names varcid "$curview,$id*"]
6554 if {$matches ne {}} {
6555 if {[llength $matches] > 1} {
6556 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6559 set id [lindex [split [lindex $matches 0] ","] 1]
6563 if {[commitinview $id $curview]} {
6564 selectline [rowofcommit $id] 1
6567 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6568 set msg [mc "SHA1 id %s is not known" $sha1string]
6570 set msg [mc "Tag/Head %s is not known" $sha1string]
6575 proc lineenter {x y id} {
6576 global hoverx hovery hoverid hovertimer
6577 global commitinfo canv
6579 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6583 if {[info exists hovertimer]} {
6584 after cancel $hovertimer
6586 set hovertimer [after 500 linehover]
6590 proc linemotion {x y id} {
6591 global hoverx hovery hoverid hovertimer
6593 if {[info exists hoverid] && $id == $hoverid} {
6596 if {[info exists hovertimer]} {
6597 after cancel $hovertimer
6599 set hovertimer [after 500 linehover]
6603 proc lineleave {id} {
6604 global hoverid hovertimer canv
6606 if {[info exists hoverid] && $id == $hoverid} {
6608 if {[info exists hovertimer]} {
6609 after cancel $hovertimer
6617 global hoverx hovery hoverid hovertimer
6618 global canv linespc lthickness
6621 set text [lindex $commitinfo($hoverid) 0]
6622 set ymax [lindex [$canv cget -scrollregion] 3]
6623 if {$ymax == {}} return
6624 set yfrac [lindex [$canv yview] 0]
6625 set x [expr {$hoverx + 2 * $linespc}]
6626 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6627 set x0 [expr {$x - 2 * $lthickness}]
6628 set y0 [expr {$y - 2 * $lthickness}]
6629 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6630 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6631 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6632 -fill \#ffff80 -outline black -width 1 -tags hover]
6634 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6639 proc clickisonarrow {id y} {
6642 set ranges [rowranges $id]
6643 set thresh [expr {2 * $lthickness + 6}]
6644 set n [expr {[llength $ranges] - 1}]
6645 for {set i 1} {$i < $n} {incr i} {
6646 set row [lindex $ranges $i]
6647 if {abs([yc $row] - $y) < $thresh} {
6654 proc arrowjump {id n y} {
6657 # 1 <-> 2, 3 <-> 4, etc...
6658 set n [expr {(($n - 1) ^ 1) + 1}]
6659 set row [lindex [rowranges $id] $n]
6661 set ymax [lindex [$canv cget -scrollregion] 3]
6662 if {$ymax eq {} || $ymax <= 0} return
6663 set view [$canv yview]
6664 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6665 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6669 allcanvs yview moveto $yfrac
6672 proc lineclick {x y id isnew} {
6673 global ctext commitinfo children canv thickerline curview
6675 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6680 # draw this line thicker than normal
6684 set ymax [lindex [$canv cget -scrollregion] 3]
6685 if {$ymax eq {}} return
6686 set yfrac [lindex [$canv yview] 0]
6687 set y [expr {$y + $yfrac * $ymax}]
6689 set dirn [clickisonarrow $id $y]
6691 arrowjump $id $dirn $y
6696 addtohistory [list lineclick $x $y $id 0]
6698 # fill the details pane with info about this line
6699 $ctext conf -state normal
6702 $ctext insert end "[mc "Parent"]:\t"
6703 $ctext insert end $id link0
6705 set info $commitinfo($id)
6706 $ctext insert end "\n\t[lindex $info 0]\n"
6707 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
6708 set date [formatdate [lindex $info 2]]
6709 $ctext insert end "\t[mc "Date"]:\t$date\n"
6710 set kids $children($curview,$id)
6712 $ctext insert end "\n[mc "Children"]:"
6714 foreach child $kids {
6716 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6717 set info $commitinfo($child)
6718 $ctext insert end "\n\t"
6719 $ctext insert end $child link$i
6720 setlink $child link$i
6721 $ctext insert end "\n\t[lindex $info 0]"
6722 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
6723 set date [formatdate [lindex $info 2]]
6724 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
6727 $ctext conf -state disabled
6731 proc normalline {} {
6733 if {[info exists thickerline]} {
6742 if {[commitinview $id $curview]} {
6743 selectline [rowofcommit $id] 1
6749 if {![info exists startmstime]} {
6750 set startmstime [clock clicks -milliseconds]
6752 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6755 proc rowmenu {x y id} {
6756 global rowctxmenu selectedline rowmenuid curview
6757 global nullid nullid2 fakerowmenu mainhead
6761 if {![info exists selectedline]
6762 || [rowofcommit $id] eq $selectedline} {
6767 if {$id ne $nullid && $id ne $nullid2} {
6768 set menu $rowctxmenu
6769 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6771 set menu $fakerowmenu
6773 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6774 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6775 $menu entryconfigure [mc "Make patch"] -state $state
6776 tk_popup $menu $x $y
6779 proc diffvssel {dirn} {
6780 global rowmenuid selectedline
6782 if {![info exists selectedline]} return
6784 set oldid [commitonrow $selectedline]
6785 set newid $rowmenuid
6787 set oldid $rowmenuid
6788 set newid [commitonrow $selectedline]
6790 addtohistory [list doseldiff $oldid $newid]
6791 doseldiff $oldid $newid
6794 proc doseldiff {oldid newid} {
6798 $ctext conf -state normal
6800 init_flist [mc "Top"]
6801 $ctext insert end "[mc "From"] "
6802 $ctext insert end $oldid link0
6803 setlink $oldid link0
6804 $ctext insert end "\n "
6805 $ctext insert end [lindex $commitinfo($oldid) 0]
6806 $ctext insert end "\n\n[mc "To"] "
6807 $ctext insert end $newid link1
6808 setlink $newid link1
6809 $ctext insert end "\n "
6810 $ctext insert end [lindex $commitinfo($newid) 0]
6811 $ctext insert end "\n"
6812 $ctext conf -state disabled
6813 $ctext tag remove found 1.0 end
6814 startdiff [list $oldid $newid]
6818 global rowmenuid currentid commitinfo patchtop patchnum
6820 if {![info exists currentid]} return
6821 set oldid $currentid
6822 set oldhead [lindex $commitinfo($oldid) 0]
6823 set newid $rowmenuid
6824 set newhead [lindex $commitinfo($newid) 0]
6827 catch {destroy $top}
6829 label $top.title -text [mc "Generate patch"]
6830 grid $top.title - -pady 10
6831 label $top.from -text [mc "From:"]
6832 entry $top.fromsha1 -width 40 -relief flat
6833 $top.fromsha1 insert 0 $oldid
6834 $top.fromsha1 conf -state readonly
6835 grid $top.from $top.fromsha1 -sticky w
6836 entry $top.fromhead -width 60 -relief flat
6837 $top.fromhead insert 0 $oldhead
6838 $top.fromhead conf -state readonly
6839 grid x $top.fromhead -sticky w
6840 label $top.to -text [mc "To:"]
6841 entry $top.tosha1 -width 40 -relief flat
6842 $top.tosha1 insert 0 $newid
6843 $top.tosha1 conf -state readonly
6844 grid $top.to $top.tosha1 -sticky w
6845 entry $top.tohead -width 60 -relief flat
6846 $top.tohead insert 0 $newhead
6847 $top.tohead conf -state readonly
6848 grid x $top.tohead -sticky w
6849 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6850 grid $top.rev x -pady 10
6851 label $top.flab -text [mc "Output file:"]
6852 entry $top.fname -width 60
6853 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6855 grid $top.flab $top.fname -sticky w
6857 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6858 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6859 grid $top.buts.gen $top.buts.can
6860 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6861 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6862 grid $top.buts - -pady 10 -sticky ew
6866 proc mkpatchrev {} {
6869 set oldid [$patchtop.fromsha1 get]
6870 set oldhead [$patchtop.fromhead get]
6871 set newid [$patchtop.tosha1 get]
6872 set newhead [$patchtop.tohead get]
6873 foreach e [list fromsha1 fromhead tosha1 tohead] \
6874 v [list $newid $newhead $oldid $oldhead] {
6875 $patchtop.$e conf -state normal
6876 $patchtop.$e delete 0 end
6877 $patchtop.$e insert 0 $v
6878 $patchtop.$e conf -state readonly
6883 global patchtop nullid nullid2
6885 set oldid [$patchtop.fromsha1 get]
6886 set newid [$patchtop.tosha1 get]
6887 set fname [$patchtop.fname get]
6888 set cmd [diffcmd [list $oldid $newid] -p]
6889 # trim off the initial "|"
6890 set cmd [lrange $cmd 1 end]
6891 lappend cmd >$fname &
6892 if {[catch {eval exec $cmd} err]} {
6893 error_popup "[mc "Error creating patch:"] $err"
6895 catch {destroy $patchtop}
6899 proc mkpatchcan {} {
6902 catch {destroy $patchtop}
6907 global rowmenuid mktagtop commitinfo
6911 catch {destroy $top}
6913 label $top.title -text [mc "Create tag"]
6914 grid $top.title - -pady 10
6915 label $top.id -text [mc "ID:"]
6916 entry $top.sha1 -width 40 -relief flat
6917 $top.sha1 insert 0 $rowmenuid
6918 $top.sha1 conf -state readonly
6919 grid $top.id $top.sha1 -sticky w
6920 entry $top.head -width 60 -relief flat
6921 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6922 $top.head conf -state readonly
6923 grid x $top.head -sticky w
6924 label $top.tlab -text [mc "Tag name:"]
6925 entry $top.tag -width 60
6926 grid $top.tlab $top.tag -sticky w
6928 button $top.buts.gen -text [mc "Create"] -command mktaggo
6929 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6930 grid $top.buts.gen $top.buts.can
6931 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6932 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6933 grid $top.buts - -pady 10 -sticky ew
6938 global mktagtop env tagids idtags
6940 set id [$mktagtop.sha1 get]
6941 set tag [$mktagtop.tag get]
6943 error_popup [mc "No tag name specified"]
6946 if {[info exists tagids($tag)]} {
6947 error_popup [mc "Tag \"%s\" already exists" $tag]
6951 exec git tag $tag $id
6953 error_popup "[mc "Error creating tag:"] $err"
6957 set tagids($tag) $id
6958 lappend idtags($id) $tag
6965 proc redrawtags {id} {
6966 global canv linehtag idpos currentid curview
6967 global canvxmax iddrawn
6969 if {![commitinview $id $curview]} return
6970 if {![info exists iddrawn($id)]} return
6971 set row [rowofcommit $id]
6972 $canv delete tag.$id
6973 set xt [eval drawtags $id $idpos($id)]
6974 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
6975 set text [$canv itemcget $linehtag($row) -text]
6976 set font [$canv itemcget $linehtag($row) -font]
6977 set xr [expr {$xt + [font measure $font $text]}]
6978 if {$xr > $canvxmax} {
6982 if {[info exists currentid] && $currentid == $id} {
6990 catch {destroy $mktagtop}
6999 proc writecommit {} {
7000 global rowmenuid wrcomtop commitinfo wrcomcmd
7002 set top .writecommit
7004 catch {destroy $top}
7006 label $top.title -text [mc "Write commit to file"]
7007 grid $top.title - -pady 10
7008 label $top.id -text [mc "ID:"]
7009 entry $top.sha1 -width 40 -relief flat
7010 $top.sha1 insert 0 $rowmenuid
7011 $top.sha1 conf -state readonly
7012 grid $top.id $top.sha1 -sticky w
7013 entry $top.head -width 60 -relief flat
7014 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7015 $top.head conf -state readonly
7016 grid x $top.head -sticky w
7017 label $top.clab -text [mc "Command:"]
7018 entry $top.cmd -width 60 -textvariable wrcomcmd
7019 grid $top.clab $top.cmd -sticky w -pady 10
7020 label $top.flab -text [mc "Output file:"]
7021 entry $top.fname -width 60
7022 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7023 grid $top.flab $top.fname -sticky w
7025 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7026 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7027 grid $top.buts.gen $top.buts.can
7028 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7029 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7030 grid $top.buts - -pady 10 -sticky ew
7037 set id [$wrcomtop.sha1 get]
7038 set cmd "echo $id | [$wrcomtop.cmd get]"
7039 set fname [$wrcomtop.fname get]
7040 if {[catch {exec sh -c $cmd >$fname &} err]} {
7041 error_popup "[mc "Error writing commit:"] $err"
7043 catch {destroy $wrcomtop}
7050 catch {destroy $wrcomtop}
7055 global rowmenuid mkbrtop
7058 catch {destroy $top}
7060 label $top.title -text [mc "Create new branch"]
7061 grid $top.title - -pady 10
7062 label $top.id -text [mc "ID:"]
7063 entry $top.sha1 -width 40 -relief flat
7064 $top.sha1 insert 0 $rowmenuid
7065 $top.sha1 conf -state readonly
7066 grid $top.id $top.sha1 -sticky w
7067 label $top.nlab -text [mc "Name:"]
7068 entry $top.name -width 40
7069 grid $top.nlab $top.name -sticky w
7071 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7072 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7073 grid $top.buts.go $top.buts.can
7074 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7075 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7076 grid $top.buts - -pady 10 -sticky ew
7081 global headids idheads
7083 set name [$top.name get]
7084 set id [$top.sha1 get]
7086 error_popup [mc "Please specify a name for the new branch"]
7089 catch {destroy $top}
7093 exec git branch $name $id
7098 set headids($name) $id
7099 lappend idheads($id) $name
7108 proc cherrypick {} {
7109 global rowmenuid curview viewincl
7110 global mainhead mainheadid
7112 set oldhead [exec git rev-parse HEAD]
7113 set dheads [descheads $rowmenuid]
7114 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7115 set ok [confirm_popup [mc "Commit %s is already\
7116 included in branch %s -- really re-apply it?" \
7117 [string range $rowmenuid 0 7] $mainhead]]
7120 nowbusy cherrypick [mc "Cherry-picking"]
7122 # Unfortunately git-cherry-pick writes stuff to stderr even when
7123 # no error occurs, and exec takes that as an indication of error...
7124 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7129 set newhead [exec git rev-parse HEAD]
7130 if {$newhead eq $oldhead} {
7132 error_popup [mc "No changes committed"]
7135 addnewchild $newhead $oldhead
7136 if {[commitinview $oldhead $curview]} {
7137 insertrow $newhead $oldhead $curview
7138 if {$mainhead ne {}} {
7139 movehead $newhead $mainhead
7140 movedhead $newhead $mainhead
7141 set mainheadid $newhead
7143 # remove oldhead from viewincl and add newhead
7144 set i [lsearch -exact $viewincl($curview) $oldhead]
7146 set viewincl($curview) [lreplace $viewincl($curview) $i $i]
7148 lappend viewincl($curview) $newhead
7157 global mainhead rowmenuid confirm_ok resettype
7160 set w ".confirmreset"
7163 wm title $w [mc "Confirm reset"]
7164 message $w.m -text \
7165 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7166 -justify center -aspect 1000
7167 pack $w.m -side top -fill x -padx 20 -pady 20
7168 frame $w.f -relief sunken -border 2
7169 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7170 grid $w.f.rt -sticky w
7172 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7173 -text [mc "Soft: Leave working tree and index untouched"]
7174 grid $w.f.soft -sticky w
7175 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7176 -text [mc "Mixed: Leave working tree untouched, reset index"]
7177 grid $w.f.mixed -sticky w
7178 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7179 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7180 grid $w.f.hard -sticky w
7181 pack $w.f -side top -fill x
7182 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7183 pack $w.ok -side left -fill x -padx 20 -pady 20
7184 button $w.cancel -text [mc Cancel] -command "destroy $w"
7185 pack $w.cancel -side right -fill x -padx 20 -pady 20
7186 bind $w <Visibility> "grab $w; focus $w"
7188 if {!$confirm_ok} return
7189 if {[catch {set fd [open \
7190 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
7194 filerun $fd [list readresetstat $fd]
7195 nowbusy reset [mc "Resetting"]
7200 proc readresetstat {fd} {
7201 global mainhead mainheadid showlocalchanges rprogcoord
7203 if {[gets $fd line] >= 0} {
7204 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7205 set rprogcoord [expr {1.0 * $m / $n}]
7213 if {[catch {close $fd} err]} {
7216 set oldhead $mainheadid
7217 set newhead [exec git rev-parse HEAD]
7218 if {$newhead ne $oldhead} {
7219 movehead $newhead $mainhead
7220 movedhead $newhead $mainhead
7221 set mainheadid $newhead
7225 if {$showlocalchanges} {
7231 # context menu for a head
7232 proc headmenu {x y id head} {
7233 global headmenuid headmenuhead headctxmenu mainhead
7237 set headmenuhead $head
7239 if {$head eq $mainhead} {
7242 $headctxmenu entryconfigure 0 -state $state
7243 $headctxmenu entryconfigure 1 -state $state
7244 tk_popup $headctxmenu $x $y
7248 global headmenuid headmenuhead mainhead headids
7249 global showlocalchanges mainheadid
7251 # check the tree is clean first??
7252 set oldmainhead $mainhead
7253 nowbusy checkout [mc "Checking out"]
7257 exec git checkout -q $headmenuhead
7263 set mainhead $headmenuhead
7264 set mainheadid $headmenuid
7265 if {[info exists headids($oldmainhead)]} {
7266 redrawtags $headids($oldmainhead)
7268 redrawtags $headmenuid
7271 if {$showlocalchanges} {
7277 global headmenuid headmenuhead mainhead
7280 set head $headmenuhead
7282 # this check shouldn't be needed any more...
7283 if {$head eq $mainhead} {
7284 error_popup [mc "Cannot delete the currently checked-out branch"]
7287 set dheads [descheads $id]
7288 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7289 # the stuff on this branch isn't on any other branch
7290 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7291 branch.\nReally delete branch %s?" $head $head]]} return
7295 if {[catch {exec git branch -D $head} err]} {
7300 removehead $id $head
7301 removedhead $id $head
7308 # Display a list of tags and heads
7310 global showrefstop bgcolor fgcolor selectbgcolor
7311 global bglist fglist reflistfilter reflist maincursor
7314 set showrefstop $top
7315 if {[winfo exists $top]} {
7321 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7322 text $top.list -background $bgcolor -foreground $fgcolor \
7323 -selectbackground $selectbgcolor -font mainfont \
7324 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7325 -width 30 -height 20 -cursor $maincursor \
7326 -spacing1 1 -spacing3 1 -state disabled
7327 $top.list tag configure highlight -background $selectbgcolor
7328 lappend bglist $top.list
7329 lappend fglist $top.list
7330 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7331 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7332 grid $top.list $top.ysb -sticky nsew
7333 grid $top.xsb x -sticky ew
7335 label $top.f.l -text "[mc "Filter"]: "
7336 entry $top.f.e -width 20 -textvariable reflistfilter
7337 set reflistfilter "*"
7338 trace add variable reflistfilter write reflistfilter_change
7339 pack $top.f.e -side right -fill x -expand 1
7340 pack $top.f.l -side left
7341 grid $top.f - -sticky ew -pady 2
7342 button $top.close -command [list destroy $top] -text [mc "Close"]
7344 grid columnconfigure $top 0 -weight 1
7345 grid rowconfigure $top 0 -weight 1
7346 bind $top.list <1> {break}
7347 bind $top.list <B1-Motion> {break}
7348 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7353 proc sel_reflist {w x y} {
7354 global showrefstop reflist headids tagids otherrefids
7356 if {![winfo exists $showrefstop]} return
7357 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7358 set ref [lindex $reflist [expr {$l-1}]]
7359 set n [lindex $ref 0]
7360 switch -- [lindex $ref 1] {
7361 "H" {selbyid $headids($n)}
7362 "T" {selbyid $tagids($n)}
7363 "o" {selbyid $otherrefids($n)}
7365 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7368 proc unsel_reflist {} {
7371 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7372 $showrefstop.list tag remove highlight 0.0 end
7375 proc reflistfilter_change {n1 n2 op} {
7376 global reflistfilter
7378 after cancel refill_reflist
7379 after 200 refill_reflist
7382 proc refill_reflist {} {
7383 global reflist reflistfilter showrefstop headids tagids otherrefids
7384 global curview commitinterest
7386 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7388 foreach n [array names headids] {
7389 if {[string match $reflistfilter $n]} {
7390 if {[commitinview $headids($n) $curview]} {
7391 lappend refs [list $n H]
7393 set commitinterest($headids($n)) {run refill_reflist}
7397 foreach n [array names tagids] {
7398 if {[string match $reflistfilter $n]} {
7399 if {[commitinview $tagids($n) $curview]} {
7400 lappend refs [list $n T]
7402 set commitinterest($tagids($n)) {run refill_reflist}
7406 foreach n [array names otherrefids] {
7407 if {[string match $reflistfilter $n]} {
7408 if {[commitinview $otherrefids($n) $curview]} {
7409 lappend refs [list $n o]
7411 set commitinterest($otherrefids($n)) {run refill_reflist}
7415 set refs [lsort -index 0 $refs]
7416 if {$refs eq $reflist} return
7418 # Update the contents of $showrefstop.list according to the
7419 # differences between $reflist (old) and $refs (new)
7420 $showrefstop.list conf -state normal
7421 $showrefstop.list insert end "\n"
7424 while {$i < [llength $reflist] || $j < [llength $refs]} {
7425 if {$i < [llength $reflist]} {
7426 if {$j < [llength $refs]} {
7427 set cmp [string compare [lindex $reflist $i 0] \
7428 [lindex $refs $j 0]]
7430 set cmp [string compare [lindex $reflist $i 1] \
7431 [lindex $refs $j 1]]
7441 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7449 set l [expr {$j + 1}]
7450 $showrefstop.list image create $l.0 -align baseline \
7451 -image reficon-[lindex $refs $j 1] -padx 2
7452 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7458 # delete last newline
7459 $showrefstop.list delete end-2c end-1c
7460 $showrefstop.list conf -state disabled
7463 # Stuff for finding nearby tags
7464 proc getallcommits {} {
7465 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7466 global idheads idtags idotherrefs allparents tagobjid
7468 if {![info exists allcommits]} {
7474 set allccache [file join [gitdir] "gitk.cache"]
7476 set f [open $allccache r]
7485 set cmd [list | git rev-list --parents]
7486 set allcupdate [expr {$seeds ne {}}]
7490 set refs [concat [array names idheads] [array names idtags] \
7491 [array names idotherrefs]]
7494 foreach name [array names tagobjid] {
7495 lappend tagobjs $tagobjid($name)
7497 foreach id [lsort -unique $refs] {
7498 if {![info exists allparents($id)] &&
7499 [lsearch -exact $tagobjs $id] < 0} {
7510 set fd [open [concat $cmd $ids] r]
7511 fconfigure $fd -blocking 0
7514 filerun $fd [list getallclines $fd]
7520 # Since most commits have 1 parent and 1 child, we group strings of
7521 # such commits into "arcs" joining branch/merge points (BMPs), which
7522 # are commits that either don't have 1 parent or don't have 1 child.
7524 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7525 # arcout(id) - outgoing arcs for BMP
7526 # arcids(a) - list of IDs on arc including end but not start
7527 # arcstart(a) - BMP ID at start of arc
7528 # arcend(a) - BMP ID at end of arc
7529 # growing(a) - arc a is still growing
7530 # arctags(a) - IDs out of arcids (excluding end) that have tags
7531 # archeads(a) - IDs out of arcids (excluding end) that have heads
7532 # The start of an arc is at the descendent end, so "incoming" means
7533 # coming from descendents, and "outgoing" means going towards ancestors.
7535 proc getallclines {fd} {
7536 global allparents allchildren idtags idheads nextarc
7537 global arcnos arcids arctags arcout arcend arcstart archeads growing
7538 global seeds allcommits cachedarcs allcupdate
7541 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7542 set id [lindex $line 0]
7543 if {[info exists allparents($id)]} {
7548 set olds [lrange $line 1 end]
7549 set allparents($id) $olds
7550 if {![info exists allchildren($id)]} {
7551 set allchildren($id) {}
7556 if {[llength $olds] == 1 && [llength $a] == 1} {
7557 lappend arcids($a) $id
7558 if {[info exists idtags($id)]} {
7559 lappend arctags($a) $id
7561 if {[info exists idheads($id)]} {
7562 lappend archeads($a) $id
7564 if {[info exists allparents($olds)]} {
7565 # seen parent already
7566 if {![info exists arcout($olds)]} {
7569 lappend arcids($a) $olds
7570 set arcend($a) $olds
7573 lappend allchildren($olds) $id
7574 lappend arcnos($olds) $a
7578 foreach a $arcnos($id) {
7579 lappend arcids($a) $id
7586 lappend allchildren($p) $id
7587 set a [incr nextarc]
7588 set arcstart($a) $id
7595 if {[info exists allparents($p)]} {
7596 # seen it already, may need to make a new branch
7597 if {![info exists arcout($p)]} {
7600 lappend arcids($a) $p
7604 lappend arcnos($p) $a
7609 global cached_dheads cached_dtags cached_atags
7610 catch {unset cached_dheads}
7611 catch {unset cached_dtags}
7612 catch {unset cached_atags}
7615 return [expr {$nid >= 1000? 2: 1}]
7619 fconfigure $fd -blocking 1
7622 # got an error reading the list of commits
7623 # if we were updating, try rereading the whole thing again
7629 error_popup "[mc "Error reading commit topology information;\
7630 branch and preceding/following tag information\
7631 will be incomplete."]\n($err)"
7634 if {[incr allcommits -1] == 0} {
7644 proc recalcarc {a} {
7645 global arctags archeads arcids idtags idheads
7649 foreach id [lrange $arcids($a) 0 end-1] {
7650 if {[info exists idtags($id)]} {
7653 if {[info exists idheads($id)]} {
7658 set archeads($a) $ah
7662 global arcnos arcids nextarc arctags archeads idtags idheads
7663 global arcstart arcend arcout allparents growing
7666 if {[llength $a] != 1} {
7667 puts "oops splitarc called but [llength $a] arcs already"
7671 set i [lsearch -exact $arcids($a) $p]
7673 puts "oops splitarc $p not in arc $a"
7676 set na [incr nextarc]
7677 if {[info exists arcend($a)]} {
7678 set arcend($na) $arcend($a)
7680 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7681 set j [lsearch -exact $arcnos($l) $a]
7682 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7684 set tail [lrange $arcids($a) [expr {$i+1}] end]
7685 set arcids($a) [lrange $arcids($a) 0 $i]
7687 set arcstart($na) $p
7689 set arcids($na) $tail
7690 if {[info exists growing($a)]} {
7696 if {[llength $arcnos($id)] == 1} {
7699 set j [lsearch -exact $arcnos($id) $a]
7700 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7704 # reconstruct tags and heads lists
7705 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7710 set archeads($na) {}
7714 # Update things for a new commit added that is a child of one
7715 # existing commit. Used when cherry-picking.
7716 proc addnewchild {id p} {
7717 global allparents allchildren idtags nextarc
7718 global arcnos arcids arctags arcout arcend arcstart archeads growing
7719 global seeds allcommits
7721 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7722 set allparents($id) [list $p]
7723 set allchildren($id) {}
7726 lappend allchildren($p) $id
7727 set a [incr nextarc]
7728 set arcstart($a) $id
7731 set arcids($a) [list $p]
7733 if {![info exists arcout($p)]} {
7736 lappend arcnos($p) $a
7737 set arcout($id) [list $a]
7740 # This implements a cache for the topology information.
7741 # The cache saves, for each arc, the start and end of the arc,
7742 # the ids on the arc, and the outgoing arcs from the end.
7743 proc readcache {f} {
7744 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7745 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7750 if {$lim - $a > 500} {
7751 set lim [expr {$a + 500}]
7755 # finish reading the cache and setting up arctags, etc.
7757 if {$line ne "1"} {error "bad final version"}
7759 foreach id [array names idtags] {
7760 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7761 [llength $allparents($id)] == 1} {
7762 set a [lindex $arcnos($id) 0]
7763 if {$arctags($a) eq {}} {
7768 foreach id [array names idheads] {
7769 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7770 [llength $allparents($id)] == 1} {
7771 set a [lindex $arcnos($id) 0]
7772 if {$archeads($a) eq {}} {
7777 foreach id [lsort -unique $possible_seeds] {
7778 if {$arcnos($id) eq {}} {
7784 while {[incr a] <= $lim} {
7786 if {[llength $line] != 3} {error "bad line"}
7787 set s [lindex $line 0]
7789 lappend arcout($s) $a
7790 if {![info exists arcnos($s)]} {
7791 lappend possible_seeds $s
7794 set e [lindex $line 1]
7799 if {![info exists arcout($e)]} {
7803 set arcids($a) [lindex $line 2]
7804 foreach id $arcids($a) {
7805 lappend allparents($s) $id
7807 lappend arcnos($id) $a
7809 if {![info exists allparents($s)]} {
7810 set allparents($s) {}
7815 set nextarc [expr {$a - 1}]
7828 global nextarc cachedarcs possible_seeds
7832 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7833 # make sure it's an integer
7834 set cachedarcs [expr {int([lindex $line 1])}]
7835 if {$cachedarcs < 0} {error "bad number of arcs"}
7837 set possible_seeds {}
7845 proc dropcache {err} {
7846 global allcwait nextarc cachedarcs seeds
7848 #puts "dropping cache ($err)"
7849 foreach v {arcnos arcout arcids arcstart arcend growing \
7850 arctags archeads allparents allchildren} {
7861 proc writecache {f} {
7862 global cachearc cachedarcs allccache
7863 global arcstart arcend arcnos arcids arcout
7867 if {$lim - $a > 1000} {
7868 set lim [expr {$a + 1000}]
7871 while {[incr a] <= $lim} {
7872 if {[info exists arcend($a)]} {
7873 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7875 puts $f [list $arcstart($a) {} $arcids($a)]
7880 catch {file delete $allccache}
7881 #puts "writing cache failed ($err)"
7884 set cachearc [expr {$a - 1}]
7885 if {$a > $cachedarcs} {
7894 global nextarc cachedarcs cachearc allccache
7896 if {$nextarc == $cachedarcs} return
7898 set cachedarcs $nextarc
7900 set f [open $allccache w]
7901 puts $f [list 1 $cachedarcs]
7906 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7907 # or 0 if neither is true.
7908 proc anc_or_desc {a b} {
7909 global arcout arcstart arcend arcnos cached_isanc
7911 if {$arcnos($a) eq $arcnos($b)} {
7912 # Both are on the same arc(s); either both are the same BMP,
7913 # or if one is not a BMP, the other is also not a BMP or is
7914 # the BMP at end of the arc (and it only has 1 incoming arc).
7915 # Or both can be BMPs with no incoming arcs.
7916 if {$a eq $b || $arcnos($a) eq {}} {
7919 # assert {[llength $arcnos($a)] == 1}
7920 set arc [lindex $arcnos($a) 0]
7921 set i [lsearch -exact $arcids($arc) $a]
7922 set j [lsearch -exact $arcids($arc) $b]
7923 if {$i < 0 || $i > $j} {
7930 if {![info exists arcout($a)]} {
7931 set arc [lindex $arcnos($a) 0]
7932 if {[info exists arcend($arc)]} {
7933 set aend $arcend($arc)
7937 set a $arcstart($arc)
7941 if {![info exists arcout($b)]} {
7942 set arc [lindex $arcnos($b) 0]
7943 if {[info exists arcend($arc)]} {
7944 set bend $arcend($arc)
7948 set b $arcstart($arc)
7958 if {[info exists cached_isanc($a,$bend)]} {
7959 if {$cached_isanc($a,$bend)} {
7963 if {[info exists cached_isanc($b,$aend)]} {
7964 if {$cached_isanc($b,$aend)} {
7967 if {[info exists cached_isanc($a,$bend)]} {
7972 set todo [list $a $b]
7975 for {set i 0} {$i < [llength $todo]} {incr i} {
7976 set x [lindex $todo $i]
7977 if {$anc($x) eq {}} {
7980 foreach arc $arcnos($x) {
7981 set xd $arcstart($arc)
7983 set cached_isanc($a,$bend) 1
7984 set cached_isanc($b,$aend) 0
7986 } elseif {$xd eq $aend} {
7987 set cached_isanc($b,$aend) 1
7988 set cached_isanc($a,$bend) 0
7991 if {![info exists anc($xd)]} {
7992 set anc($xd) $anc($x)
7994 } elseif {$anc($xd) ne $anc($x)} {
7999 set cached_isanc($a,$bend) 0
8000 set cached_isanc($b,$aend) 0
8004 # This identifies whether $desc has an ancestor that is
8005 # a growing tip of the graph and which is not an ancestor of $anc
8006 # and returns 0 if so and 1 if not.
8007 # If we subsequently discover a tag on such a growing tip, and that
8008 # turns out to be a descendent of $anc (which it could, since we
8009 # don't necessarily see children before parents), then $desc
8010 # isn't a good choice to display as a descendent tag of
8011 # $anc (since it is the descendent of another tag which is
8012 # a descendent of $anc). Similarly, $anc isn't a good choice to
8013 # display as a ancestor tag of $desc.
8015 proc is_certain {desc anc} {
8016 global arcnos arcout arcstart arcend growing problems
8019 if {[llength $arcnos($anc)] == 1} {
8020 # tags on the same arc are certain
8021 if {$arcnos($desc) eq $arcnos($anc)} {
8024 if {![info exists arcout($anc)]} {
8025 # if $anc is partway along an arc, use the start of the arc instead
8026 set a [lindex $arcnos($anc) 0]
8027 set anc $arcstart($a)
8030 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8033 set a [lindex $arcnos($desc) 0]
8039 set anclist [list $x]
8043 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8044 set x [lindex $anclist $i]
8049 foreach a $arcout($x) {
8050 if {[info exists growing($a)]} {
8051 if {![info exists growanc($x)] && $dl($x)} {
8057 if {[info exists dl($y)]} {
8061 if {![info exists done($y)]} {
8064 if {[info exists growanc($x)]} {
8068 for {set k 0} {$k < [llength $xl]} {incr k} {
8069 set z [lindex $xl $k]
8070 foreach c $arcout($z) {
8071 if {[info exists arcend($c)]} {
8073 if {[info exists dl($v)] && $dl($v)} {
8075 if {![info exists done($v)]} {
8078 if {[info exists growanc($v)]} {
8088 } elseif {$y eq $anc || !$dl($x)} {
8099 foreach x [array names growanc] {
8108 proc validate_arctags {a} {
8109 global arctags idtags
8113 foreach id $arctags($a) {
8115 if {![info exists idtags($id)]} {
8116 set na [lreplace $na $i $i]
8123 proc validate_archeads {a} {
8124 global archeads idheads
8127 set na $archeads($a)
8128 foreach id $archeads($a) {
8130 if {![info exists idheads($id)]} {
8131 set na [lreplace $na $i $i]
8135 set archeads($a) $na
8138 # Return the list of IDs that have tags that are descendents of id,
8139 # ignoring IDs that are descendents of IDs already reported.
8140 proc desctags {id} {
8141 global arcnos arcstart arcids arctags idtags allparents
8142 global growing cached_dtags
8144 if {![info exists allparents($id)]} {
8147 set t1 [clock clicks -milliseconds]
8149 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8150 # part-way along an arc; check that arc first
8151 set a [lindex $arcnos($id) 0]
8152 if {$arctags($a) ne {}} {
8154 set i [lsearch -exact $arcids($a) $id]
8156 foreach t $arctags($a) {
8157 set j [lsearch -exact $arcids($a) $t]
8165 set id $arcstart($a)
8166 if {[info exists idtags($id)]} {
8170 if {[info exists cached_dtags($id)]} {
8171 return $cached_dtags($id)
8178 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8179 set id [lindex $todo $i]
8181 set ta [info exists hastaggedancestor($id)]
8185 # ignore tags on starting node
8186 if {!$ta && $i > 0} {
8187 if {[info exists idtags($id)]} {
8190 } elseif {[info exists cached_dtags($id)]} {
8191 set tagloc($id) $cached_dtags($id)
8195 foreach a $arcnos($id) {
8197 if {!$ta && $arctags($a) ne {}} {
8199 if {$arctags($a) ne {}} {
8200 lappend tagloc($id) [lindex $arctags($a) end]
8203 if {$ta || $arctags($a) ne {}} {
8204 set tomark [list $d]
8205 for {set j 0} {$j < [llength $tomark]} {incr j} {
8206 set dd [lindex $tomark $j]
8207 if {![info exists hastaggedancestor($dd)]} {
8208 if {[info exists done($dd)]} {
8209 foreach b $arcnos($dd) {
8210 lappend tomark $arcstart($b)
8212 if {[info exists tagloc($dd)]} {
8215 } elseif {[info exists queued($dd)]} {
8218 set hastaggedancestor($dd) 1
8222 if {![info exists queued($d)]} {
8225 if {![info exists hastaggedancestor($d)]} {
8232 foreach id [array names tagloc] {
8233 if {![info exists hastaggedancestor($id)]} {
8234 foreach t $tagloc($id) {
8235 if {[lsearch -exact $tags $t] < 0} {
8241 set t2 [clock clicks -milliseconds]
8244 # remove tags that are descendents of other tags
8245 for {set i 0} {$i < [llength $tags]} {incr i} {
8246 set a [lindex $tags $i]
8247 for {set j 0} {$j < $i} {incr j} {
8248 set b [lindex $tags $j]
8249 set r [anc_or_desc $a $b]
8251 set tags [lreplace $tags $j $j]
8254 } elseif {$r == -1} {
8255 set tags [lreplace $tags $i $i]
8262 if {[array names growing] ne {}} {
8263 # graph isn't finished, need to check if any tag could get
8264 # eclipsed by another tag coming later. Simply ignore any
8265 # tags that could later get eclipsed.
8268 if {[is_certain $t $origid]} {
8272 if {$tags eq $ctags} {
8273 set cached_dtags($origid) $tags
8278 set cached_dtags($origid) $tags
8280 set t3 [clock clicks -milliseconds]
8281 if {0 && $t3 - $t1 >= 100} {
8282 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8283 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8289 global arcnos arcids arcout arcend arctags idtags allparents
8290 global growing cached_atags
8292 if {![info exists allparents($id)]} {
8295 set t1 [clock clicks -milliseconds]
8297 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8298 # part-way along an arc; check that arc first
8299 set a [lindex $arcnos($id) 0]
8300 if {$arctags($a) ne {}} {
8302 set i [lsearch -exact $arcids($a) $id]
8303 foreach t $arctags($a) {
8304 set j [lsearch -exact $arcids($a) $t]
8310 if {![info exists arcend($a)]} {
8314 if {[info exists idtags($id)]} {
8318 if {[info exists cached_atags($id)]} {
8319 return $cached_atags($id)
8327 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8328 set id [lindex $todo $i]
8330 set td [info exists hastaggeddescendent($id)]
8334 # ignore tags on starting node
8335 if {!$td && $i > 0} {
8336 if {[info exists idtags($id)]} {
8339 } elseif {[info exists cached_atags($id)]} {
8340 set tagloc($id) $cached_atags($id)
8344 foreach a $arcout($id) {
8345 if {!$td && $arctags($a) ne {}} {
8347 if {$arctags($a) ne {}} {
8348 lappend tagloc($id) [lindex $arctags($a) 0]
8351 if {![info exists arcend($a)]} continue
8353 if {$td || $arctags($a) ne {}} {
8354 set tomark [list $d]
8355 for {set j 0} {$j < [llength $tomark]} {incr j} {
8356 set dd [lindex $tomark $j]
8357 if {![info exists hastaggeddescendent($dd)]} {
8358 if {[info exists done($dd)]} {
8359 foreach b $arcout($dd) {
8360 if {[info exists arcend($b)]} {
8361 lappend tomark $arcend($b)
8364 if {[info exists tagloc($dd)]} {
8367 } elseif {[info exists queued($dd)]} {
8370 set hastaggeddescendent($dd) 1
8374 if {![info exists queued($d)]} {
8377 if {![info exists hastaggeddescendent($d)]} {
8383 set t2 [clock clicks -milliseconds]
8386 foreach id [array names tagloc] {
8387 if {![info exists hastaggeddescendent($id)]} {
8388 foreach t $tagloc($id) {
8389 if {[lsearch -exact $tags $t] < 0} {
8396 # remove tags that are ancestors of other tags
8397 for {set i 0} {$i < [llength $tags]} {incr i} {
8398 set a [lindex $tags $i]
8399 for {set j 0} {$j < $i} {incr j} {
8400 set b [lindex $tags $j]
8401 set r [anc_or_desc $a $b]
8403 set tags [lreplace $tags $j $j]
8406 } elseif {$r == 1} {
8407 set tags [lreplace $tags $i $i]
8414 if {[array names growing] ne {}} {
8415 # graph isn't finished, need to check if any tag could get
8416 # eclipsed by another tag coming later. Simply ignore any
8417 # tags that could later get eclipsed.
8420 if {[is_certain $origid $t]} {
8424 if {$tags eq $ctags} {
8425 set cached_atags($origid) $tags
8430 set cached_atags($origid) $tags
8432 set t3 [clock clicks -milliseconds]
8433 if {0 && $t3 - $t1 >= 100} {
8434 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8435 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8440 # Return the list of IDs that have heads that are descendents of id,
8441 # including id itself if it has a head.
8442 proc descheads {id} {
8443 global arcnos arcstart arcids archeads idheads cached_dheads
8446 if {![info exists allparents($id)]} {
8450 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8451 # part-way along an arc; check it first
8452 set a [lindex $arcnos($id) 0]
8453 if {$archeads($a) ne {}} {
8454 validate_archeads $a
8455 set i [lsearch -exact $arcids($a) $id]
8456 foreach t $archeads($a) {
8457 set j [lsearch -exact $arcids($a) $t]
8462 set id $arcstart($a)
8468 for {set i 0} {$i < [llength $todo]} {incr i} {
8469 set id [lindex $todo $i]
8470 if {[info exists cached_dheads($id)]} {
8471 set ret [concat $ret $cached_dheads($id)]
8473 if {[info exists idheads($id)]} {
8476 foreach a $arcnos($id) {
8477 if {$archeads($a) ne {}} {
8478 validate_archeads $a
8479 if {$archeads($a) ne {}} {
8480 set ret [concat $ret $archeads($a)]
8484 if {![info exists seen($d)]} {
8491 set ret [lsort -unique $ret]
8492 set cached_dheads($origid) $ret
8493 return [concat $ret $aret]
8496 proc addedtag {id} {
8497 global arcnos arcout cached_dtags cached_atags
8499 if {![info exists arcnos($id)]} return
8500 if {![info exists arcout($id)]} {
8501 recalcarc [lindex $arcnos($id) 0]
8503 catch {unset cached_dtags}
8504 catch {unset cached_atags}
8507 proc addedhead {hid head} {
8508 global arcnos arcout cached_dheads
8510 if {![info exists arcnos($hid)]} return
8511 if {![info exists arcout($hid)]} {
8512 recalcarc [lindex $arcnos($hid) 0]
8514 catch {unset cached_dheads}
8517 proc removedhead {hid head} {
8518 global cached_dheads
8520 catch {unset cached_dheads}
8523 proc movedhead {hid head} {
8524 global arcnos arcout cached_dheads
8526 if {![info exists arcnos($hid)]} return
8527 if {![info exists arcout($hid)]} {
8528 recalcarc [lindex $arcnos($hid) 0]
8530 catch {unset cached_dheads}
8533 proc changedrefs {} {
8534 global cached_dheads cached_dtags cached_atags
8535 global arctags archeads arcnos arcout idheads idtags
8537 foreach id [concat [array names idheads] [array names idtags]] {
8538 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8539 set a [lindex $arcnos($id) 0]
8540 if {![info exists donearc($a)]} {
8546 catch {unset cached_dtags}
8547 catch {unset cached_atags}
8548 catch {unset cached_dheads}
8551 proc rereadrefs {} {
8552 global idtags idheads idotherrefs mainheadid
8554 set refids [concat [array names idtags] \
8555 [array names idheads] [array names idotherrefs]]
8556 foreach id $refids {
8557 if {![info exists ref($id)]} {
8558 set ref($id) [listrefs $id]
8561 set oldmainhead $mainheadid
8564 set refids [lsort -unique [concat $refids [array names idtags] \
8565 [array names idheads] [array names idotherrefs]]]
8566 foreach id $refids {
8567 set v [listrefs $id]
8568 if {![info exists ref($id)] || $ref($id) != $v ||
8569 ($id eq $oldmainhead && $id ne $mainheadid) ||
8570 ($id eq $mainheadid && $id ne $oldmainhead)} {
8577 proc listrefs {id} {
8578 global idtags idheads idotherrefs
8581 if {[info exists idtags($id)]} {
8585 if {[info exists idheads($id)]} {
8589 if {[info exists idotherrefs($id)]} {
8590 set z $idotherrefs($id)
8592 return [list $x $y $z]
8595 proc showtag {tag isnew} {
8596 global ctext tagcontents tagids linknum tagobjid
8599 addtohistory [list showtag $tag 0]
8601 $ctext conf -state normal
8605 if {![info exists tagcontents($tag)]} {
8607 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8610 if {[info exists tagcontents($tag)]} {
8611 set text $tagcontents($tag)
8613 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
8615 appendwithlinks $text {}
8616 $ctext conf -state disabled
8627 proc mkfontdisp {font top which} {
8628 global fontattr fontpref $font
8630 set fontpref($font) [set $font]
8631 button $top.${font}but -text $which -font optionfont \
8632 -command [list choosefont $font $which]
8633 label $top.$font -relief flat -font $font \
8634 -text $fontattr($font,family) -justify left
8635 grid x $top.${font}but $top.$font -sticky w
8638 proc choosefont {font which} {
8639 global fontparam fontlist fonttop fontattr
8641 set fontparam(which) $which
8642 set fontparam(font) $font
8643 set fontparam(family) [font actual $font -family]
8644 set fontparam(size) $fontattr($font,size)
8645 set fontparam(weight) $fontattr($font,weight)
8646 set fontparam(slant) $fontattr($font,slant)
8649 if {![winfo exists $top]} {
8651 eval font config sample [font actual $font]
8653 wm title $top [mc "Gitk font chooser"]
8654 label $top.l -textvariable fontparam(which)
8655 pack $top.l -side top
8656 set fontlist [lsort [font families]]
8658 listbox $top.f.fam -listvariable fontlist \
8659 -yscrollcommand [list $top.f.sb set]
8660 bind $top.f.fam <<ListboxSelect>> selfontfam
8661 scrollbar $top.f.sb -command [list $top.f.fam yview]
8662 pack $top.f.sb -side right -fill y
8663 pack $top.f.fam -side left -fill both -expand 1
8664 pack $top.f -side top -fill both -expand 1
8666 spinbox $top.g.size -from 4 -to 40 -width 4 \
8667 -textvariable fontparam(size) \
8668 -validatecommand {string is integer -strict %s}
8669 checkbutton $top.g.bold -padx 5 \
8670 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8671 -variable fontparam(weight) -onvalue bold -offvalue normal
8672 checkbutton $top.g.ital -padx 5 \
8673 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8674 -variable fontparam(slant) -onvalue italic -offvalue roman
8675 pack $top.g.size $top.g.bold $top.g.ital -side left
8676 pack $top.g -side top
8677 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8679 $top.c create text 100 25 -anchor center -text $which -font sample \
8680 -fill black -tags text
8681 bind $top.c <Configure> [list centertext $top.c]
8682 pack $top.c -side top -fill x
8684 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8685 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8686 grid $top.buts.ok $top.buts.can
8687 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8688 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8689 pack $top.buts -side bottom -fill x
8690 trace add variable fontparam write chg_fontparam
8693 $top.c itemconf text -text $which
8695 set i [lsearch -exact $fontlist $fontparam(family)]
8697 $top.f.fam selection set $i
8702 proc centertext {w} {
8703 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8707 global fontparam fontpref prefstop
8709 set f $fontparam(font)
8710 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8711 if {$fontparam(weight) eq "bold"} {
8712 lappend fontpref($f) "bold"
8714 if {$fontparam(slant) eq "italic"} {
8715 lappend fontpref($f) "italic"
8718 $w conf -text $fontparam(family) -font $fontpref($f)
8724 global fonttop fontparam
8726 if {[info exists fonttop]} {
8727 catch {destroy $fonttop}
8728 catch {font delete sample}
8734 proc selfontfam {} {
8735 global fonttop fontparam
8737 set i [$fonttop.f.fam curselection]
8739 set fontparam(family) [$fonttop.f.fam get $i]
8743 proc chg_fontparam {v sub op} {
8746 font config sample -$sub $fontparam($sub)
8750 global maxwidth maxgraphpct
8751 global oldprefs prefstop showneartags showlocalchanges
8752 global bgcolor fgcolor ctext diffcolors selectbgcolor
8753 global tabstop limitdiffs
8757 if {[winfo exists $top]} {
8761 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8762 limitdiffs tabstop} {
8763 set oldprefs($v) [set $v]
8766 wm title $top [mc "Gitk preferences"]
8767 label $top.ldisp -text [mc "Commit list display options"]
8768 grid $top.ldisp - -sticky w -pady 10
8769 label $top.spacer -text " "
8770 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8772 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8773 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8774 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8776 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8777 grid x $top.maxpctl $top.maxpct -sticky w
8778 frame $top.showlocal
8779 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8780 checkbutton $top.showlocal.b -variable showlocalchanges
8781 pack $top.showlocal.b $top.showlocal.l -side left
8782 grid x $top.showlocal -sticky w
8784 label $top.ddisp -text [mc "Diff display options"]
8785 grid $top.ddisp - -sticky w -pady 10
8786 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8787 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8788 grid x $top.tabstopl $top.tabstop -sticky w
8790 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8791 checkbutton $top.ntag.b -variable showneartags
8792 pack $top.ntag.b $top.ntag.l -side left
8793 grid x $top.ntag -sticky w
8795 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8796 checkbutton $top.ldiff.b -variable limitdiffs
8797 pack $top.ldiff.b $top.ldiff.l -side left
8798 grid x $top.ldiff -sticky w
8800 label $top.cdisp -text [mc "Colors: press to choose"]
8801 grid $top.cdisp - -sticky w -pady 10
8802 label $top.bg -padx 40 -relief sunk -background $bgcolor
8803 button $top.bgbut -text [mc "Background"] -font optionfont \
8804 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8805 grid x $top.bgbut $top.bg -sticky w
8806 label $top.fg -padx 40 -relief sunk -background $fgcolor
8807 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8808 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8809 grid x $top.fgbut $top.fg -sticky w
8810 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8811 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8812 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8813 [list $ctext tag conf d0 -foreground]]
8814 grid x $top.diffoldbut $top.diffold -sticky w
8815 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8816 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8817 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8818 [list $ctext tag conf d1 -foreground]]
8819 grid x $top.diffnewbut $top.diffnew -sticky w
8820 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8821 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8822 -command [list choosecolor diffcolors 2 $top.hunksep \
8823 "diff hunk header" \
8824 [list $ctext tag conf hunksep -foreground]]
8825 grid x $top.hunksepbut $top.hunksep -sticky w
8826 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8827 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8828 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8829 grid x $top.selbgbut $top.selbgsep -sticky w
8831 label $top.cfont -text [mc "Fonts: press to choose"]
8832 grid $top.cfont - -sticky w -pady 10
8833 mkfontdisp mainfont $top [mc "Main font"]
8834 mkfontdisp textfont $top [mc "Diff display font"]
8835 mkfontdisp uifont $top [mc "User interface font"]
8838 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8839 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8840 grid $top.buts.ok $top.buts.can
8841 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8842 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8843 grid $top.buts - - -pady 10 -sticky ew
8844 bind $top <Visibility> "focus $top.buts.ok"
8847 proc choosecolor {v vi w x cmd} {
8850 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8851 -title [mc "Gitk: choose color for %s" $x]]
8852 if {$c eq {}} return
8853 $w conf -background $c
8859 global bglist cflist
8861 $w configure -selectbackground $c
8863 $cflist tag configure highlight \
8864 -background [$cflist cget -selectbackground]
8865 allcanvs itemconf secsel -fill $c
8872 $w conf -background $c
8880 $w conf -foreground $c
8882 allcanvs itemconf text -fill $c
8883 $canv itemconf circle -outline $c
8887 global oldprefs prefstop
8889 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8890 limitdiffs tabstop} {
8892 set $v $oldprefs($v)
8894 catch {destroy $prefstop}
8900 global maxwidth maxgraphpct
8901 global oldprefs prefstop showneartags showlocalchanges
8902 global fontpref mainfont textfont uifont
8903 global limitdiffs treediffs
8905 catch {destroy $prefstop}
8909 if {$mainfont ne $fontpref(mainfont)} {
8910 set mainfont $fontpref(mainfont)
8911 parsefont mainfont $mainfont
8912 eval font configure mainfont [fontflags mainfont]
8913 eval font configure mainfontbold [fontflags mainfont 1]
8917 if {$textfont ne $fontpref(textfont)} {
8918 set textfont $fontpref(textfont)
8919 parsefont textfont $textfont
8920 eval font configure textfont [fontflags textfont]
8921 eval font configure textfontbold [fontflags textfont 1]
8923 if {$uifont ne $fontpref(uifont)} {
8924 set uifont $fontpref(uifont)
8925 parsefont uifont $uifont
8926 eval font configure uifont [fontflags uifont]
8929 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8930 if {$showlocalchanges} {
8936 if {$limitdiffs != $oldprefs(limitdiffs)} {
8937 # treediffs elements are limited by path
8938 catch {unset treediffs}
8940 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8941 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8943 } elseif {$showneartags != $oldprefs(showneartags) ||
8944 $limitdiffs != $oldprefs(limitdiffs)} {
8949 proc formatdate {d} {
8950 global datetimeformat
8952 set d [clock format $d -format $datetimeformat]
8957 # This list of encoding names and aliases is distilled from
8958 # http://www.iana.org/assignments/character-sets.
8959 # Not all of them are supported by Tcl.
8960 set encoding_aliases {
8961 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8962 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8963 { ISO-10646-UTF-1 csISO10646UTF1 }
8964 { ISO_646.basic:1983 ref csISO646basic1983 }
8965 { INVARIANT csINVARIANT }
8966 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8967 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8968 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8969 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8970 { NATS-DANO iso-ir-9-1 csNATSDANO }
8971 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8972 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8973 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8974 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8975 { ISO-2022-KR csISO2022KR }
8977 { ISO-2022-JP csISO2022JP }
8978 { ISO-2022-JP-2 csISO2022JP2 }
8979 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8981 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8982 { IT iso-ir-15 ISO646-IT csISO15Italian }
8983 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8984 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8985 { greek7-old iso-ir-18 csISO18Greek7Old }
8986 { latin-greek iso-ir-19 csISO19LatinGreek }
8987 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8988 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8989 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8990 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8991 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8992 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8993 { INIS iso-ir-49 csISO49INIS }
8994 { INIS-8 iso-ir-50 csISO50INIS8 }
8995 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8996 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8997 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8998 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8999 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9000 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9002 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9003 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9004 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9005 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9006 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9007 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9008 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9009 { greek7 iso-ir-88 csISO88Greek7 }
9010 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9011 { iso-ir-90 csISO90 }
9012 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9013 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9014 csISO92JISC62991984b }
9015 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9016 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9017 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9018 csISO95JIS62291984handadd }
9019 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9020 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9021 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9022 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9024 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9025 { T.61-7bit iso-ir-102 csISO102T617bit }
9026 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9027 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9028 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9029 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9030 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9031 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9032 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9033 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9034 arabic csISOLatinArabic }
9035 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9036 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9037 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9038 greek greek8 csISOLatinGreek }
9039 { T.101-G2 iso-ir-128 csISO128T101G2 }
9040 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9042 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9043 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9044 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9045 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9046 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9047 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9048 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9049 csISOLatinCyrillic }
9050 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9051 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9052 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9053 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9054 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9055 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9056 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9057 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9058 { ISO_10367-box iso-ir-155 csISO10367Box }
9059 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9060 { latin-lap lap iso-ir-158 csISO158Lap }
9061 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9062 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9065 { JIS_X0201 X0201 csHalfWidthKatakana }
9066 { KSC5636 ISO646-KR csKSC5636 }
9067 { ISO-10646-UCS-2 csUnicode }
9068 { ISO-10646-UCS-4 csUCS4 }
9069 { DEC-MCS dec csDECMCS }
9070 { hp-roman8 roman8 r8 csHPRoman8 }
9071 { macintosh mac csMacintosh }
9072 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9074 { IBM038 EBCDIC-INT cp038 csIBM038 }
9075 { IBM273 CP273 csIBM273 }
9076 { IBM274 EBCDIC-BE CP274 csIBM274 }
9077 { IBM275 EBCDIC-BR cp275 csIBM275 }
9078 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9079 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9080 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9081 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9082 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9083 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9084 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9085 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9086 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9087 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9088 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9089 { IBM437 cp437 437 csPC8CodePage437 }
9090 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9091 { IBM775 cp775 csPC775Baltic }
9092 { IBM850 cp850 850 csPC850Multilingual }
9093 { IBM851 cp851 851 csIBM851 }
9094 { IBM852 cp852 852 csPCp852 }
9095 { IBM855 cp855 855 csIBM855 }
9096 { IBM857 cp857 857 csIBM857 }
9097 { IBM860 cp860 860 csIBM860 }
9098 { IBM861 cp861 861 cp-is csIBM861 }
9099 { IBM862 cp862 862 csPC862LatinHebrew }
9100 { IBM863 cp863 863 csIBM863 }
9101 { IBM864 cp864 csIBM864 }
9102 { IBM865 cp865 865 csIBM865 }
9103 { IBM866 cp866 866 csIBM866 }
9104 { IBM868 CP868 cp-ar csIBM868 }
9105 { IBM869 cp869 869 cp-gr csIBM869 }
9106 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9107 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9108 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9109 { IBM891 cp891 csIBM891 }
9110 { IBM903 cp903 csIBM903 }
9111 { IBM904 cp904 904 csIBBM904 }
9112 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9113 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9114 { IBM1026 CP1026 csIBM1026 }
9115 { EBCDIC-AT-DE csIBMEBCDICATDE }
9116 { EBCDIC-AT-DE-A csEBCDICATDEA }
9117 { EBCDIC-CA-FR csEBCDICCAFR }
9118 { EBCDIC-DK-NO csEBCDICDKNO }
9119 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9120 { EBCDIC-FI-SE csEBCDICFISE }
9121 { EBCDIC-FI-SE-A csEBCDICFISEA }
9122 { EBCDIC-FR csEBCDICFR }
9123 { EBCDIC-IT csEBCDICIT }
9124 { EBCDIC-PT csEBCDICPT }
9125 { EBCDIC-ES csEBCDICES }
9126 { EBCDIC-ES-A csEBCDICESA }
9127 { EBCDIC-ES-S csEBCDICESS }
9128 { EBCDIC-UK csEBCDICUK }
9129 { EBCDIC-US csEBCDICUS }
9130 { UNKNOWN-8BIT csUnknown8BiT }
9131 { MNEMONIC csMnemonic }
9136 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9137 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9138 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9139 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9140 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9141 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9142 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9143 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9144 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9145 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9146 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9147 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9148 { IBM1047 IBM-1047 }
9149 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9150 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9151 { UNICODE-1-1 csUnicode11 }
9154 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9155 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9157 { ISO-8859-15 ISO_8859-15 Latin-9 }
9158 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9159 { GBK CP936 MS936 windows-936 }
9160 { JIS_Encoding csJISEncoding }
9161 { Shift_JIS MS_Kanji csShiftJIS }
9162 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9164 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9165 { ISO-10646-UCS-Basic csUnicodeASCII }
9166 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9167 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9168 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9169 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9170 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9171 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9172 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9173 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9174 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9175 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9176 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9177 { Ventura-US csVenturaUS }
9178 { Ventura-International csVenturaInternational }
9179 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9180 { PC8-Turkish csPC8Turkish }
9181 { IBM-Symbols csIBMSymbols }
9182 { IBM-Thai csIBMThai }
9183 { HP-Legal csHPLegal }
9184 { HP-Pi-font csHPPiFont }
9185 { HP-Math8 csHPMath8 }
9186 { Adobe-Symbol-Encoding csHPPSMath }
9187 { HP-DeskTop csHPDesktop }
9188 { Ventura-Math csVenturaMath }
9189 { Microsoft-Publishing csMicrosoftPublishing }
9190 { Windows-31J csWindows31J }
9195 proc tcl_encoding {enc} {
9196 global encoding_aliases
9197 set names [encoding names]
9198 set lcnames [string tolower $names]
9199 set enc [string tolower $enc]
9200 set i [lsearch -exact $lcnames $enc]
9202 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9203 if {[regsub {^iso[-_]} $enc iso encx]} {
9204 set i [lsearch -exact $lcnames $encx]
9208 foreach l $encoding_aliases {
9209 set ll [string tolower $l]
9210 if {[lsearch -exact $ll $enc] < 0} continue
9211 # look through the aliases for one that tcl knows about
9213 set i [lsearch -exact $lcnames $e]
9215 if {[regsub {^iso[-_]} $e iso ex]} {
9216 set i [lsearch -exact $lcnames $ex]
9225 return [lindex $names $i]
9230 # First check that Tcl/Tk is recent enough
9231 if {[catch {package require Tk 8.4} err]} {
9232 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9233 Gitk requires at least Tcl/Tk 8.4."]
9239 set wrcomcmd "git diff-tree --stdin -p --pretty"
9243 set gitencoding [exec git config --get i18n.commitencoding]
9245 if {$gitencoding == ""} {
9246 set gitencoding "utf-8"
9248 set tclencoding [tcl_encoding $gitencoding]
9249 if {$tclencoding == {}} {
9250 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9253 set mainfont {Helvetica 9}
9254 set textfont {Courier 9}
9255 set uifont {Helvetica 9 bold}
9257 set findmergefiles 0
9265 set cmitmode "patch"
9266 set wrapcomment "none"
9270 set showlocalchanges 1
9272 set datetimeformat "%Y-%m-%d %H:%M:%S"
9274 set colors {green red blue magenta darkgrey brown orange}
9277 set diffcolors {red "#00a000" blue}
9280 set selectbgcolor gray85
9282 ## For msgcat loading, first locate the installation location.
9283 if { [info exists ::env(GITK_MSGSDIR)] } {
9284 ## Msgsdir was manually set in the environment.
9285 set gitk_msgsdir $::env(GITK_MSGSDIR)
9287 ## Let's guess the prefix from argv0.
9288 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9289 set gitk_libdir [file join $gitk_prefix share gitk lib]
9290 set gitk_msgsdir [file join $gitk_libdir msgs]
9294 ## Internationalization (i18n) through msgcat and gettext. See
9295 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9296 package require msgcat
9297 namespace import ::msgcat::mc
9298 ## And eventually load the actual message catalog
9299 ::msgcat::mcload $gitk_msgsdir
9301 catch {source ~/.gitk}
9303 font create optionfont -family sans-serif -size -12
9305 parsefont mainfont $mainfont
9306 eval font create mainfont [fontflags mainfont]
9307 eval font create mainfontbold [fontflags mainfont 1]
9309 parsefont textfont $textfont
9310 eval font create textfont [fontflags textfont]
9311 eval font create textfontbold [fontflags textfont 1]
9313 parsefont uifont $uifont
9314 eval font create uifont [fontflags uifont]
9318 # check that we can find a .git directory somewhere...
9319 if {[catch {set gitdir [gitdir]}]} {
9320 show_error {} . [mc "Cannot find a git repository here."]
9323 if {![file isdirectory $gitdir]} {
9324 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9330 set cmdline_files {}
9335 "-d" { set datemode 1 }
9338 lappend revtreeargs $arg
9341 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9345 lappend revtreeargs $arg
9351 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9352 # no -- on command line, but some arguments (other than -d)
9354 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9355 set cmdline_files [split $f "\n"]
9356 set n [llength $cmdline_files]
9357 set revtreeargs [lrange $revtreeargs 0 end-$n]
9358 # Unfortunately git rev-parse doesn't produce an error when
9359 # something is both a revision and a filename. To be consistent
9360 # with git log and git rev-list, check revtreeargs for filenames.
9361 foreach arg $revtreeargs {
9362 if {[file exists $arg]} {
9363 show_error {} . [mc "Ambiguous argument '%s': both revision\
9369 # unfortunately we get both stdout and stderr in $err,
9370 # so look for "fatal:".
9371 set i [string first "fatal:" $err]
9373 set err [string range $err [expr {$i + 6}] end]
9375 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9381 # find the list of unmerged files
9385 set fd [open "| git ls-files -u" r]
9387 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9390 while {[gets $fd line] >= 0} {
9391 set i [string first "\t" $line]
9392 if {$i < 0} continue
9393 set fname [string range $line [expr {$i+1}] end]
9394 if {[lsearch -exact $mlist $fname] >= 0} continue
9396 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9397 lappend mlist $fname
9402 if {$nr_unmerged == 0} {
9403 show_error {} . [mc "No files selected: --merge specified but\
9404 no files are unmerged."]
9406 show_error {} . [mc "No files selected: --merge specified but\
9407 no unmerged files are within file limit."]
9411 set cmdline_files $mlist
9414 set nullid "0000000000000000000000000000000000000000"
9415 set nullid2 "0000000000000000000000000000000000000001"
9417 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9424 set highlight_paths {}
9426 set searchdirn -forwards
9430 set markingmatches 0
9431 set linkentercount 0
9432 set need_redisplay 0
9439 set selectedhlview [mc "None"]
9440 set highlight_related [mc "None"]
9441 set highlight_files {}
9454 # wait for the window to become visible
9456 wm title . "[file tail $argv0]: [file tail [pwd]]"
9459 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9460 # create a view for the files/dirs specified on the command line
9464 set viewname(1) [mc "Command line"]
9465 set viewfiles(1) $cmdline_files
9466 set viewargs(1) $revtreeargs
9469 .bar.view entryconf [mc "Edit view..."] -state normal
9470 .bar.view entryconf [mc "Delete view"] -state normal
9473 if {[info exists permviews]} {
9474 foreach v $permviews {
9477 set viewname($n) [lindex $v 0]
9478 set viewfiles($n) [lindex $v 1]
9479 set viewargs($n) [lindex $v 2]