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 log process and arrange to read its output
94 proc start_rev_list
{view
} {
96 global commfd leftover tclencoding datemode
97 global viewargs viewargscmd viewfiles commitidx viewcomplete
98 global showlocalchanges commitinterest mainheadid
99 global progressdirn progresscoords proglastnc curview
100 global 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
109 set args
$viewargs($view)
110 if {$viewargscmd($view) ne
{}} {
112 set str
[exec sh
-c $viewargscmd($view)]
114 error_popup
"Error executing --argscmd command: $err"
117 set args
[concat
$args [split $str "\n"]]
120 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
121 --boundary $args "--" $viewfiles($view)] r
]
123 error_popup
"[mc "Error executing git log
:"] $err"
126 set i
[incr loginstance
]
127 set viewinstances
($view) [list
$i]
130 if {$showlocalchanges} {
131 lappend commitinterest
($mainheadid) {dodiffindex
}
133 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
134 if {$tclencoding != {}} {
135 fconfigure
$fd -encoding $tclencoding
137 filerun
$fd [list getcommitlines
$fd $i $view 0]
138 nowbusy
$view [mc
"Reading"]
139 if {$view == $curview} {
141 set progresscoords
{0 0}
143 set pending_select
$mainheadid
147 proc stop_rev_list
{view
} {
148 global commfd viewinstances leftover
150 foreach inst
$viewinstances($view) {
151 set fd
$commfd($inst)
159 unset leftover
($inst)
161 set viewinstances
($view) {}
165 global canv curview need_redisplay
168 start_rev_list
$curview
169 show_status
[mc
"Reading commits..."]
173 proc updatecommits
{} {
174 global curview viewargs viewfiles viewinstances
175 global viewactive viewcomplete loginstance tclencoding mainheadid
176 global startmsecs commfd showneartags showlocalchanges leftover
177 global mainheadid pending_select
180 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
181 set oldmainid
$mainheadid
183 if {$showlocalchanges} {
184 if {$mainheadid ne
$oldmainid} {
187 if {[commitinview
$mainheadid $curview]} {
193 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
194 --boundary $viewargs($view) --not [seeds
$view] \
195 "--" $viewfiles($view)] r
]
197 error_popup
"Error executing git log: $err"
200 if {$viewactive($view) == 0} {
201 set startmsecs
[clock clicks
-milliseconds]
203 set i
[incr loginstance
]
204 lappend viewinstances
($view) $i
207 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
208 if {$tclencoding != {}} {
209 fconfigure
$fd -encoding $tclencoding
211 filerun
$fd [list getcommitlines
$fd $i $view 1]
212 incr viewactive
($view)
213 set viewcomplete
($view) 0
214 set pending_select
$mainheadid
215 nowbusy
$view "Reading"
221 proc reloadcommits
{} {
222 global curview viewcomplete selectedline currentid thickerline
223 global showneartags treediffs commitinterest cached_commitrow
224 global progresscoords targetid
226 if {!$viewcomplete($curview)} {
227 stop_rev_list
$curview
228 set progresscoords
{0 0}
232 catch
{unset selectedline
}
233 catch
{unset currentid
}
234 catch
{unset thickerline
}
235 catch
{unset treediffs
}
242 catch
{unset commitinterest
}
243 catch
{unset cached_commitrow
}
244 catch
{unset targetid
}
250 # This makes a string representation of a positive integer which
251 # sorts as a string in numerical order
254 return [format
"%x" $n]
255 } elseif
{$n < 256} {
256 return [format
"x%.2x" $n]
257 } elseif
{$n < 65536} {
258 return [format
"y%.4x" $n]
260 return [format
"z%.8x" $n]
263 # Procedures used in reordering commits from git log (without
264 # --topo-order) into the order for display.
266 proc varcinit
{view
} {
267 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
268 global vtokmod varcmod vrowmod varcix vlastins
270 set varcstart
($view) {{}}
271 set vupptr
($view) {0}
272 set vdownptr
($view) {0}
273 set vleftptr
($view) {0}
274 set vbackptr
($view) {0}
275 set varctok
($view) {{}}
276 set varcrow
($view) {{}}
277 set vtokmod
($view) {}
280 set varcix
($view) {{}}
281 set vlastins
($view) {0}
284 proc resetvarcs
{view
} {
285 global varcid varccommits parents children vseedcount ordertok
287 foreach vid
[array names varcid
$view,*] {
292 # some commits might have children but haven't been seen yet
293 foreach vid
[array names children
$view,*] {
296 foreach va
[array names varccommits
$view,*] {
297 unset varccommits
($va)
299 foreach vd
[array names vseedcount
$view,*] {
300 unset vseedcount
($vd)
302 catch
{unset ordertok
}
305 # returns a list of the commits with no children
307 global vdownptr vleftptr varcstart
310 set a
[lindex
$vdownptr($v) 0]
312 lappend ret
[lindex
$varcstart($v) $a]
313 set a
[lindex
$vleftptr($v) $a]
318 proc newvarc
{view id
} {
319 global varcid varctok parents children datemode
320 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
321 global commitdata commitinfo vseedcount varccommits vlastins
323 set a
[llength
$varctok($view)]
325 if {[llength
$children($vid)] == 0 ||
$datemode} {
326 if {![info exists commitinfo
($id)]} {
327 parsecommit
$id $commitdata($id) 1
329 set cdate
[lindex
$commitinfo($id) 4]
330 if {![string is integer
-strict $cdate]} {
333 if {![info exists vseedcount
($view,$cdate)]} {
334 set vseedcount
($view,$cdate) -1
336 set c
[incr vseedcount
($view,$cdate)]
337 set cdate
[expr {$cdate ^
0xffffffff}]
338 set tok
"s[strrep $cdate][strrep $c]"
343 if {[llength
$children($vid)] > 0} {
344 set kid
[lindex
$children($vid) end
]
345 set k
$varcid($view,$kid)
346 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
349 set tok
[lindex
$varctok($view) $k]
353 set i
[lsearch
-exact $parents($view,$ki) $id]
354 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
355 append tok
[strrep
$j]
357 set c
[lindex
$vlastins($view) $ka]
358 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
360 set b
[lindex
$vdownptr($view) $ka]
362 set b
[lindex
$vleftptr($view) $c]
364 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
366 set b
[lindex
$vleftptr($view) $c]
369 lset vdownptr
($view) $ka $a
370 lappend vbackptr
($view) 0
372 lset vleftptr
($view) $c $a
373 lappend vbackptr
($view) $c
375 lset vlastins
($view) $ka $a
376 lappend vupptr
($view) $ka
377 lappend vleftptr
($view) $b
379 lset vbackptr
($view) $b $a
381 lappend varctok
($view) $tok
382 lappend varcstart
($view) $id
383 lappend vdownptr
($view) 0
384 lappend varcrow
($view) {}
385 lappend varcix
($view) {}
386 set varccommits
($view,$a) {}
387 lappend vlastins
($view) 0
391 proc splitvarc
{p v
} {
392 global varcid varcstart varccommits varctok
393 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
395 set oa
$varcid($v,$p)
396 set ac
$varccommits($v,$oa)
397 set i
[lsearch
-exact $varccommits($v,$oa) $p]
399 set na
[llength
$varctok($v)]
400 # "%" sorts before "0"...
401 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
402 lappend varctok
($v) $tok
403 lappend varcrow
($v) {}
404 lappend varcix
($v) {}
405 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
406 set varccommits
($v,$na) [lrange
$ac $i end
]
407 lappend varcstart
($v) $p
408 foreach id
$varccommits($v,$na) {
409 set varcid
($v,$id) $na
411 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
412 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
413 lset vdownptr
($v) $oa $na
414 lset vlastins
($v) $oa 0
415 lappend vupptr
($v) $oa
416 lappend vleftptr
($v) 0
417 lappend vbackptr
($v) 0
418 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
419 lset vupptr
($v) $b $na
423 proc renumbervarc
{a v
} {
424 global parents children varctok varcstart varccommits
425 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
427 set t1
[clock clicks
-milliseconds]
433 if {[info exists isrelated
($a)]} {
435 set id
[lindex
$varccommits($v,$a) end
]
436 foreach p
$parents($v,$id) {
437 if {[info exists varcid
($v,$p)]} {
438 set isrelated
($varcid($v,$p)) 1
443 set b
[lindex
$vdownptr($v) $a]
446 set b
[lindex
$vleftptr($v) $a]
448 set a
[lindex
$vupptr($v) $a]
454 if {![info exists kidchanged
($a)]} continue
455 set id
[lindex
$varcstart($v) $a]
456 if {[llength
$children($v,$id)] > 1} {
457 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
460 set oldtok
[lindex
$varctok($v) $a]
467 set kid
[last_real_child
$v,$id]
469 set k
$varcid($v,$kid)
470 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
473 set tok
[lindex
$varctok($v) $k]
477 set i
[lsearch
-exact $parents($v,$ki) $id]
478 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
479 append tok
[strrep
$j]
481 if {$tok eq
$oldtok} {
484 set id
[lindex
$varccommits($v,$a) end
]
485 foreach p
$parents($v,$id) {
486 if {[info exists varcid
($v,$p)]} {
487 set kidchanged
($varcid($v,$p)) 1
492 lset varctok
($v) $a $tok
493 set b
[lindex
$vupptr($v) $a]
495 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
498 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
501 set c
[lindex
$vbackptr($v) $a]
502 set d
[lindex
$vleftptr($v) $a]
504 lset vdownptr
($v) $b $d
506 lset vleftptr
($v) $c $d
509 lset vbackptr
($v) $d $c
511 if {[lindex
$vlastins($v) $b] == $a} {
512 lset vlastins
($v) $b $c
514 lset vupptr
($v) $a $ka
515 set c
[lindex
$vlastins($v) $ka]
517 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
519 set b
[lindex
$vdownptr($v) $ka]
521 set b
[lindex
$vleftptr($v) $c]
524 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
526 set b
[lindex
$vleftptr($v) $c]
529 lset vdownptr
($v) $ka $a
530 lset vbackptr
($v) $a 0
532 lset vleftptr
($v) $c $a
533 lset vbackptr
($v) $a $c
535 lset vleftptr
($v) $a $b
537 lset vbackptr
($v) $b $a
539 lset vlastins
($v) $ka $a
542 foreach id
[array names sortkids
] {
543 if {[llength
$children($v,$id)] > 1} {
544 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
548 set t2
[clock clicks
-milliseconds]
549 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
552 # Fix up the graph after we have found out that in view $v,
553 # $p (a commit that we have already seen) is actually the parent
554 # of the last commit in arc $a.
555 proc fix_reversal
{p a v
} {
556 global varcid varcstart varctok vupptr
558 set pa
$varcid($v,$p)
559 if {$p ne
[lindex
$varcstart($v) $pa]} {
561 set pa
$varcid($v,$p)
563 # seeds always need to be renumbered
564 if {[lindex
$vupptr($v) $pa] == 0 ||
565 [string compare
[lindex
$varctok($v) $a] \
566 [lindex
$varctok($v) $pa]] > 0} {
571 proc insertrow
{id p v
} {
572 global cmitlisted children parents varcid varctok vtokmod
573 global varccommits ordertok commitidx numcommits curview
574 global targetid targetrow
578 set cmitlisted
($vid) 1
579 set children
($vid) {}
580 set parents
($vid) [list
$p]
581 set a
[newvarc
$v $id]
583 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
586 lappend varccommits
($v,$a) $id
588 if {[llength
[lappend children
($vp) $id]] > 1} {
589 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
590 catch
{unset ordertok
}
592 fix_reversal
$p $a $v
594 if {$v == $curview} {
595 set numcommits
$commitidx($v)
597 if {[info exists targetid
]} {
598 if {![comes_before
$targetid $p]} {
605 proc insertfakerow
{id p
} {
606 global varcid varccommits parents children cmitlisted
607 global commitidx varctok vtokmod targetid targetrow curview numcommits
611 set i
[lsearch
-exact $varccommits($v,$a) $p]
613 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
616 set children
($v,$id) {}
617 set parents
($v,$id) [list
$p]
618 set varcid
($v,$id) $a
619 lappend children
($v,$p) $id
620 set cmitlisted
($v,$id) 1
621 set numcommits
[incr commitidx
($v)]
622 # note we deliberately don't update varcstart($v) even if $i == 0
623 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
625 if {[info exists targetid
]} {
626 if {![comes_before
$targetid $p]} {
634 proc removefakerow
{id
} {
635 global varcid varccommits parents children commitidx
636 global varctok vtokmod cmitlisted currentid selectedline
637 global targetid curview numcommits
640 if {[llength
$parents($v,$id)] != 1} {
641 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
644 set p
[lindex
$parents($v,$id) 0]
645 set a
$varcid($v,$id)
646 set i
[lsearch
-exact $varccommits($v,$a) $id]
648 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
652 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
653 unset parents
($v,$id)
654 unset children
($v,$id)
655 unset cmitlisted
($v,$id)
656 set numcommits
[incr commitidx
($v) -1]
657 set j
[lsearch
-exact $children($v,$p) $id]
659 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
662 if {[info exist currentid
] && $id eq
$currentid} {
666 if {[info exists targetid
] && $targetid eq
$id} {
673 proc first_real_child
{vp
} {
674 global children nullid nullid2
676 foreach id
$children($vp) {
677 if {$id ne
$nullid && $id ne
$nullid2} {
684 proc last_real_child
{vp
} {
685 global children nullid nullid2
687 set kids
$children($vp)
688 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
689 set id
[lindex
$kids $i]
690 if {$id ne
$nullid && $id ne
$nullid2} {
697 proc vtokcmp
{v a b
} {
698 global varctok varcid
700 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
701 [lindex
$varctok($v) $varcid($v,$b)]]
704 # This assumes that if lim is not given, the caller has checked that
705 # arc a's token is less than $vtokmod($v)
706 proc modify_arc
{v a
{lim
{}}} {
707 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
710 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
713 set r
[lindex
$varcrow($v) $a]
714 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
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 if {$vrowmod($v) == $commitidx($v)} return
743 if {$v == $curview} {
744 if {[llength
$displayorder] > $vrowmod($v)} {
745 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
746 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
748 catch
{unset cached_commitrow
}
750 set narctot
[expr {[llength
$varctok($v)] - 1}]
752 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
753 # go up the tree until we find something that has a row number,
754 # or we get to a seed
755 set a
[lindex
$vupptr($v) $a]
758 set a
[lindex
$vdownptr($v) 0]
761 set varcorder
($v) [list
$a]
763 lset varcrow
($v) $a 0
767 set arcn
[lindex
$varcix($v) $a]
768 if {[llength
$vrownum($v)] > $arcn + 1} {
769 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
770 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
772 set row
[lindex
$varcrow($v) $a]
776 incr row
[llength
$varccommits($v,$a)]
777 # go down if possible
778 set b
[lindex
$vdownptr($v) $a]
780 # if not, go left, or go up until we can go left
782 set b
[lindex
$vleftptr($v) $a]
784 set a
[lindex
$vupptr($v) $a]
790 lappend vrownum
($v) $row
791 lappend varcorder
($v) $a
792 lset varcix
($v) $a $arcn
793 lset varcrow
($v) $a $row
795 set vtokmod
($v) [lindex
$varctok($v) $p]
798 if {[info exists currentid
]} {
799 set selectedline
[rowofcommit
$currentid]
803 # Test whether view $v contains commit $id
804 proc commitinview
{id v
} {
807 return [info exists varcid
($v,$id)]
810 # Return the row number for commit $id in the current view
811 proc rowofcommit
{id
} {
812 global varcid varccommits varcrow curview cached_commitrow
813 global varctok vtokmod
816 if {![info exists varcid
($v,$id)]} {
817 puts
"oops rowofcommit no arc for [shortids $id]"
820 set a
$varcid($v,$id)
821 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
824 if {[info exists cached_commitrow
($id)]} {
825 return $cached_commitrow($id)
827 set i
[lsearch
-exact $varccommits($v,$a) $id]
829 puts
"oops didn't find commit [shortids $id] in arc $a"
832 incr i
[lindex
$varcrow($v) $a]
833 set cached_commitrow
($id) $i
837 # Returns 1 if a is on an earlier row than b, otherwise 0
838 proc comes_before
{a b
} {
839 global varcid varctok curview
842 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
843 ![info exists varcid
($v,$b)]} {
846 if {$varcid($v,$a) != $varcid($v,$b)} {
847 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
848 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
850 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
853 proc bsearch
{l elt
} {
854 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
859 while {$hi - $lo > 1} {
860 set mid
[expr {int
(($lo + $hi) / 2)}]
861 set t
[lindex
$l $mid]
864 } elseif
{$elt > $t} {
873 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
874 proc make_disporder
{start end
} {
875 global vrownum curview commitidx displayorder parentlist
876 global varccommits varcorder parents vrowmod varcrow
877 global d_valid_start d_valid_end
879 if {$end > $vrowmod($curview)} {
880 update_arcrows
$curview
882 set ai
[bsearch
$vrownum($curview) $start]
883 set start
[lindex
$vrownum($curview) $ai]
884 set narc
[llength
$vrownum($curview)]
885 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
886 set a
[lindex
$varcorder($curview) $ai]
887 set l
[llength
$displayorder]
888 set al
[llength
$varccommits($curview,$a)]
891 set pad
[ntimes
[expr {$r - $l}] {}]
892 set displayorder
[concat
$displayorder $pad]
893 set parentlist
[concat
$parentlist $pad]
895 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
896 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
898 foreach id
$varccommits($curview,$a) {
899 lappend displayorder
$id
900 lappend parentlist
$parents($curview,$id)
902 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
904 foreach id
$varccommits($curview,$a) {
905 lset displayorder
$i $id
906 lset parentlist
$i $parents($curview,$id)
914 proc commitonrow
{row
} {
917 set id
[lindex
$displayorder $row]
919 make_disporder
$row [expr {$row + 1}]
920 set id
[lindex
$displayorder $row]
925 proc closevarcs
{v
} {
926 global varctok varccommits varcid parents children
927 global cmitlisted commitidx commitinterest vtokmod
929 set missing_parents
0
931 set narcs
[llength
$varctok($v)]
932 for {set a
1} {$a < $narcs} {incr a
} {
933 set id
[lindex
$varccommits($v,$a) end
]
934 foreach p
$parents($v,$id) {
935 if {[info exists varcid
($v,$p)]} continue
936 # add p as a new commit
938 set cmitlisted
($v,$p) 0
939 set parents
($v,$p) {}
940 if {[llength
$children($v,$p)] == 1 &&
941 [llength
$parents($v,$id)] == 1} {
944 set b
[newvarc
$v $p]
947 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
950 lappend varccommits
($v,$b) $p
952 if {[info exists commitinterest
($p)]} {
953 foreach
script $commitinterest($p) {
954 lappend scripts
[string map
[list
"%I" $p] $script]
956 unset commitinterest
($id)
960 if {$missing_parents > 0} {
967 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
968 # Assumes we already have an arc for $rwid.
969 proc rewrite_commit
{v id rwid
} {
970 global children parents varcid varctok vtokmod varccommits
972 foreach ch
$children($v,$id) {
973 # make $rwid be $ch's parent in place of $id
974 set i
[lsearch
-exact $parents($v,$ch) $id]
976 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
978 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
979 # add $ch to $rwid's children and sort the list if necessary
980 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
981 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
984 # fix the graph after joining $id to $rwid
985 set a
$varcid($v,$ch)
986 fix_reversal
$rwid $a $v
987 # parentlist is wrong for the last element of arc $a
988 # even if displayorder is right, hence the 3rd arg here
989 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
993 proc getcommitlines
{fd inst view updating
} {
994 global cmitlisted commitinterest leftover
995 global commitidx commitdata datemode
996 global parents children curview hlview
997 global idpending ordertok
998 global varccommits varcid varctok vtokmod viewfiles
1000 set stuff
[read $fd 500000]
1001 # git log doesn't terminate the last commit with a null...
1002 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1009 global commfd viewcomplete viewactive viewname progresscoords
1010 global viewinstances
1012 set i
[lsearch
-exact $viewinstances($view) $inst]
1014 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1016 # set it blocking so we wait for the process to terminate
1017 fconfigure
$fd -blocking 1
1018 if {[catch
{close
$fd} err
]} {
1020 if {$view != $curview} {
1021 set fv
" for the \"$viewname($view)\" view"
1023 if {[string range
$err 0 4] == "usage"} {
1024 set err
"Gitk: error reading commits$fv:\
1025 bad arguments to git log."
1026 if {$viewname($view) eq
"Command line"} {
1028 " (Note: arguments to gitk are passed to git log\
1029 to allow selection of commits to be displayed.)"
1032 set err
"Error reading commits$fv: $err"
1036 if {[incr viewactive
($view) -1] <= 0} {
1037 set viewcomplete
($view) 1
1038 # Check if we have seen any ids listed as parents that haven't
1039 # appeared in the list
1042 set progresscoords
{0 0}
1045 if {$view == $curview} {
1054 set i
[string first
"\0" $stuff $start]
1056 append leftover
($inst) [string range
$stuff $start end
]
1060 set cmit
$leftover($inst)
1061 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1062 set leftover
($inst) {}
1064 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1066 set start
[expr {$i + 1}]
1067 set j
[string first
"\n" $cmit]
1070 if {$j >= 0 && [string match
"commit *" $cmit]} {
1071 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1072 if {[string match
{[-^
<>]*} $ids]} {
1073 switch
-- [string index
$ids 0] {
1079 set ids
[string range
$ids 1 end
]
1083 if {[string length
$id] != 40} {
1091 if {[string length
$shortcmit] > 80} {
1092 set shortcmit
"[string range $shortcmit 0 80]..."
1094 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1097 set id [lindex $ids 0]
1100 if {!$listed && $updating && ![info exists varcid($vid)] &&
1101 $viewfiles($view) ne {}} {
1102 # git log doesn't rewrite parents
for unlisted commits
1103 # when doing path limiting, so work around that here
1104 # by working out the rewritten parent with git rev-list
1105 # and if we already know about it, using the rewritten
1106 # parent as a substitute parent for $id's children.
1108 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1109 $id -- $viewfiles($view)]
1111 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1112 # use $rwid in place of $id
1113 rewrite_commit
$view $id $rwid
1120 if {[info exists varcid
($vid)]} {
1121 if {$cmitlisted($vid) ||
!$listed} continue
1125 set olds
[lrange
$ids 1 end
]
1129 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1130 set cmitlisted
($vid) $listed
1131 set parents
($vid) $olds
1132 if {![info exists children
($vid)]} {
1133 set children
($vid) {}
1134 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1135 set k
[lindex
$children($vid) 0]
1136 if {[llength
$parents($view,$k)] == 1 &&
1138 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1139 set a
$varcid($view,$k)
1144 set a
[newvarc
$view $id]
1146 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1149 if {![info exists varcid
($vid)]} {
1151 lappend varccommits
($view,$a) $id
1152 incr commitidx
($view)
1157 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1159 if {[llength
[lappend children
($vp) $id]] > 1 &&
1160 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1161 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1163 catch
{unset ordertok
}
1165 if {[info exists varcid
($view,$p)]} {
1166 fix_reversal
$p $a $view
1172 if {[info exists commitinterest
($id)]} {
1173 foreach
script $commitinterest($id) {
1174 lappend scripts
[string map
[list
"%I" $id] $script]
1176 unset commitinterest
($id)
1181 global numcommits hlview
1183 if {$view == $curview} {
1184 set numcommits
$commitidx($view)
1187 if {[info exists hlview
] && $view == $hlview} {
1188 # we never actually get here...
1191 foreach s
$scripts {
1194 if {$view == $curview} {
1195 # update progress bar
1196 global progressdirn progresscoords proglastnc
1197 set inc
[expr {($commitidx($view) - $proglastnc) * 0.0002}]
1198 set proglastnc
$commitidx($view)
1199 set l
[lindex
$progresscoords 0]
1200 set r
[lindex
$progresscoords 1]
1201 if {$progressdirn} {
1202 set r
[expr {$r + $inc}]
1208 set l
[expr {$r - 0.2}]
1211 set l
[expr {$l - $inc}]
1216 set r
[expr {$l + 0.2}]
1218 set progresscoords
[list
$l $r]
1225 proc chewcommits
{} {
1226 global curview hlview viewcomplete
1227 global pending_select
1230 if {$viewcomplete($curview)} {
1231 global commitidx varctok
1232 global numcommits startmsecs
1233 global mainheadid nullid
1235 if {[info exists pending_select
]} {
1236 set row
[first_real_row
]
1239 if {$commitidx($curview) > 0} {
1240 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1241 #puts "overall $ms ms for $numcommits commits"
1242 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1244 show_status
[mc
"No commits selected"]
1251 proc readcommit
{id
} {
1252 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
1253 parsecommit
$id $contents 0
1256 proc parsecommit
{id contents listed
} {
1257 global commitinfo cdate
1266 set hdrend
[string first
"\n\n" $contents]
1268 # should never happen...
1269 set hdrend
[string length
$contents]
1271 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1272 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1273 foreach line
[split $header "\n"] {
1274 set tag
[lindex
$line 0]
1275 if {$tag == "author"} {
1276 set audate
[lindex
$line end-1
]
1277 set auname
[lrange
$line 1 end-2
]
1278 } elseif
{$tag == "committer"} {
1279 set comdate
[lindex
$line end-1
]
1280 set comname
[lrange
$line 1 end-2
]
1284 # take the first non-blank line of the comment as the headline
1285 set headline
[string trimleft
$comment]
1286 set i
[string first
"\n" $headline]
1288 set headline
[string range
$headline 0 $i]
1290 set headline
[string trimright
$headline]
1291 set i
[string first
"\r" $headline]
1293 set headline
[string trimright
[string range
$headline 0 $i]]
1296 # git log indents the comment by 4 spaces;
1297 # if we got this via git cat-file, add the indentation
1299 foreach line
[split $comment "\n"] {
1300 append newcomment
" "
1301 append newcomment
$line
1302 append newcomment
"\n"
1304 set comment
$newcomment
1306 if {$comdate != {}} {
1307 set cdate
($id) $comdate
1309 set commitinfo
($id) [list
$headline $auname $audate \
1310 $comname $comdate $comment]
1313 proc getcommit
{id
} {
1314 global commitdata commitinfo
1316 if {[info exists commitdata
($id)]} {
1317 parsecommit
$id $commitdata($id) 1
1320 if {![info exists commitinfo
($id)]} {
1321 set commitinfo
($id) [list
[mc
"No commit information available"]]
1328 global tagids idtags headids idheads tagobjid
1329 global otherrefids idotherrefs mainhead mainheadid
1331 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1334 set refd
[open
[list | git show-ref
-d] r
]
1335 while {[gets
$refd line
] >= 0} {
1336 if {[string index
$line 40] ne
" "} continue
1337 set id
[string range
$line 0 39]
1338 set ref
[string range
$line 41 end
]
1339 if {![string match
"refs/*" $ref]} continue
1340 set name
[string range
$ref 5 end
]
1341 if {[string match
"remotes/*" $name]} {
1342 if {![string match
"*/HEAD" $name]} {
1343 set headids
($name) $id
1344 lappend idheads
($id) $name
1346 } elseif
{[string match
"heads/*" $name]} {
1347 set name
[string range
$name 6 end
]
1348 set headids
($name) $id
1349 lappend idheads
($id) $name
1350 } elseif
{[string match
"tags/*" $name]} {
1351 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1352 # which is what we want since the former is the commit ID
1353 set name
[string range
$name 5 end
]
1354 if {[string match
"*^{}" $name]} {
1355 set name
[string range
$name 0 end-3
]
1357 set tagobjid
($name) $id
1359 set tagids
($name) $id
1360 lappend idtags
($id) $name
1362 set otherrefids
($name) $id
1363 lappend idotherrefs
($id) $name
1370 set thehead
[exec git symbolic-ref HEAD
]
1371 if {[string match
"refs/heads/*" $thehead]} {
1372 set mainhead
[string range
$thehead 11 end
]
1373 if {[info exists headids
($mainhead)]} {
1374 set mainheadid
$headids($mainhead)
1380 # skip over fake commits
1381 proc first_real_row
{} {
1382 global nullid nullid2 numcommits
1384 for {set row
0} {$row < $numcommits} {incr row
} {
1385 set id
[commitonrow
$row]
1386 if {$id ne
$nullid && $id ne
$nullid2} {
1393 # update things for a head moved to a child of its previous location
1394 proc movehead
{id name
} {
1395 global headids idheads
1397 removehead
$headids($name) $name
1398 set headids
($name) $id
1399 lappend idheads
($id) $name
1402 # update things when a head has been removed
1403 proc removehead
{id name
} {
1404 global headids idheads
1406 if {$idheads($id) eq
$name} {
1409 set i
[lsearch
-exact $idheads($id) $name]
1411 set idheads
($id) [lreplace
$idheads($id) $i $i]
1414 unset headids
($name)
1417 proc show_error
{w top msg
} {
1418 message
$w.m
-text $msg -justify center
-aspect 400
1419 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1420 button
$w.ok
-text [mc OK
] -command "destroy $top"
1421 pack
$w.ok
-side bottom
-fill x
1422 bind $top <Visibility
> "grab $top; focus $top"
1423 bind $top <Key-Return
> "destroy $top"
1427 proc error_popup msg
{
1431 show_error
$w $w $msg
1434 proc confirm_popup msg
{
1440 message
$w.m
-text $msg -justify center
-aspect 400
1441 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1442 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1443 pack
$w.ok
-side left
-fill x
1444 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1445 pack
$w.cancel
-side right
-fill x
1446 bind $w <Visibility
> "grab $w; focus $w"
1451 proc setoptions
{} {
1452 option add
*Panedwindow.showHandle
1 startupFile
1453 option add
*Panedwindow.sashRelief raised startupFile
1454 option add
*Button.font uifont startupFile
1455 option add
*Checkbutton.font uifont startupFile
1456 option add
*Radiobutton.font uifont startupFile
1457 option add
*Menu.font uifont startupFile
1458 option add
*Menubutton.font uifont startupFile
1459 option add
*Label.font uifont startupFile
1460 option add
*Message.font uifont startupFile
1461 option add
*Entry.font uifont startupFile
1464 proc makewindow
{} {
1465 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1467 global findtype findtypemenu findloc findstring fstring geometry
1468 global entries sha1entry sha1string sha1but
1469 global diffcontextstring diffcontext
1471 global maincursor textcursor curtextcursor
1472 global rowctxmenu fakerowmenu mergemax wrapcomment
1473 global highlight_files gdttype
1474 global searchstring sstring
1475 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1476 global headctxmenu progresscanv progressitem progresscoords statusw
1477 global fprogitem fprogcoord lastprogupdate progupdatepending
1478 global rprogitem rprogcoord
1482 .bar add cascade
-label [mc
"File"] -menu .bar.
file
1484 .bar.
file add
command -label [mc
"Update"] -command updatecommits
1485 .bar.
file add
command -label [mc
"Reload"] -command reloadcommits
1486 .bar.
file add
command -label [mc
"Reread references"] -command rereadrefs
1487 .bar.
file add
command -label [mc
"List references"] -command showrefs
1488 .bar.
file add
command -label [mc
"Quit"] -command doquit
1490 .bar add cascade
-label [mc
"Edit"] -menu .bar.edit
1491 .bar.edit add
command -label [mc
"Preferences"] -command doprefs
1494 .bar add cascade
-label [mc
"View"] -menu .bar.view
1495 .bar.view add
command -label [mc
"New view..."] -command {newview
0}
1496 .bar.view add
command -label [mc
"Edit view..."] -command editview \
1498 .bar.view add
command -label [mc
"Delete view"] -command delview
-state disabled
1499 .bar.view add separator
1500 .bar.view add radiobutton
-label [mc
"All files"] -command {showview
0} \
1501 -variable selectedview
-value 0
1504 .bar add cascade
-label [mc
"Help"] -menu .bar.
help
1505 .bar.
help add
command -label [mc
"About gitk"] -command about
1506 .bar.
help add
command -label [mc
"Key bindings"] -command keys
1508 . configure
-menu .bar
1510 # the gui has upper and lower half, parts of a paned window.
1511 panedwindow .ctop
-orient vertical
1513 # possibly use assumed geometry
1514 if {![info exists geometry
(pwsash0
)]} {
1515 set geometry
(topheight
) [expr {15 * $linespc}]
1516 set geometry
(topwidth
) [expr {80 * $charspc}]
1517 set geometry
(botheight
) [expr {15 * $linespc}]
1518 set geometry
(botwidth
) [expr {50 * $charspc}]
1519 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
1520 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
1523 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1524 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
1526 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
1528 # create three canvases
1529 set cscroll .tf.histframe.csb
1530 set canv .tf.histframe.pwclist.canv
1532 -selectbackground $selectbgcolor \
1533 -background $bgcolor -bd 0 \
1534 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1535 .tf.histframe.pwclist add
$canv
1536 set canv2 .tf.histframe.pwclist.canv2
1538 -selectbackground $selectbgcolor \
1539 -background $bgcolor -bd 0 -yscrollincr $linespc
1540 .tf.histframe.pwclist add
$canv2
1541 set canv3 .tf.histframe.pwclist.canv3
1543 -selectbackground $selectbgcolor \
1544 -background $bgcolor -bd 0 -yscrollincr $linespc
1545 .tf.histframe.pwclist add
$canv3
1546 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
1547 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
1549 # a scroll bar to rule them
1550 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
1551 pack
$cscroll -side right
-fill y
1552 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
1553 lappend bglist
$canv $canv2 $canv3
1554 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
1556 # we have two button bars at bottom of top frame. Bar 1
1558 frame .tf.lbar
-height 15
1560 set sha1entry .tf.bar.sha1
1561 set entries
$sha1entry
1562 set sha1but .tf.bar.sha1label
1563 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
1564 -command gotocommit
-width 8
1565 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
1566 pack .tf.bar.sha1label
-side left
1567 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
1568 trace add variable sha1string
write sha1change
1569 pack
$sha1entry -side left
-pady 2
1571 image create bitmap bm-left
-data {
1572 #define left_width 16
1573 #define left_height 16
1574 static unsigned char left_bits
[] = {
1575 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1576 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1577 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1579 image create bitmap bm-right
-data {
1580 #define right_width 16
1581 #define right_height 16
1582 static unsigned char right_bits
[] = {
1583 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1584 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1585 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1587 button .tf.bar.leftbut
-image bm-left
-command goback \
1588 -state disabled
-width 26
1589 pack .tf.bar.leftbut
-side left
-fill y
1590 button .tf.bar.rightbut
-image bm-right
-command goforw \
1591 -state disabled
-width 26
1592 pack .tf.bar.rightbut
-side left
-fill y
1594 # Status label and progress bar
1595 set statusw .tf.bar.status
1596 label
$statusw -width 15 -relief sunken
1597 pack
$statusw -side left
-padx 5
1598 set h
[expr {[font metrics uifont
-linespace] + 2}]
1599 set progresscanv .tf.bar.progress
1600 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
1601 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
1602 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
1603 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
1604 pack
$progresscanv -side right
-expand 1 -fill x
1605 set progresscoords
{0 0}
1608 bind $progresscanv <Configure
> adjustprogress
1609 set lastprogupdate
[clock clicks
-milliseconds]
1610 set progupdatepending
0
1612 # build up the bottom bar of upper window
1613 label .tf.lbar.flabel
-text "[mc "Find
"] "
1614 button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
1615 button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
1616 label .tf.lbar.flab2
-text " [mc "commit
"] "
1617 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1619 set gdttype
[mc
"containing:"]
1620 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
1621 [mc
"containing:"] \
1622 [mc
"touching paths:"] \
1623 [mc
"adding/removing string:"]]
1624 trace add variable gdttype
write gdttype_change
1625 pack .tf.lbar.gdttype
-side left
-fill y
1628 set fstring .tf.lbar.findstring
1629 lappend entries
$fstring
1630 entry
$fstring -width 30 -font textfont
-textvariable findstring
1631 trace add variable findstring
write find_change
1632 set findtype
[mc
"Exact"]
1633 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
1634 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
1635 trace add variable findtype
write findcom_change
1636 set findloc
[mc
"All fields"]
1637 tk_optionMenu .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
1638 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
1639 trace add variable findloc
write find_change
1640 pack .tf.lbar.findloc
-side right
1641 pack .tf.lbar.findtype
-side right
1642 pack
$fstring -side left
-expand 1 -fill x
1644 # Finish putting the upper half of the viewer together
1645 pack .tf.lbar
-in .tf
-side bottom
-fill x
1646 pack .tf.bar
-in .tf
-side bottom
-fill x
1647 pack .tf.histframe
-fill both
-side top
-expand 1
1649 .ctop paneconfigure .tf
-height $geometry(topheight
)
1650 .ctop paneconfigure .tf
-width $geometry(topwidth
)
1652 # now build up the bottom
1653 panedwindow .pwbottom
-orient horizontal
1655 # lower left, a text box over search bar, scroll bar to the right
1656 # if we know window height, then that will set the lower text height, otherwise
1657 # we set lower text height which will drive window height
1658 if {[info exists geometry
(main
)]} {
1659 frame .bleft
-width $geometry(botwidth
)
1661 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.bottom.ctext
1694 text
$ctext -background $bgcolor -foreground $fgcolor \
1695 -state disabled
-font textfont \
1696 -yscrollcommand scrolltext
-wrap none \
1697 -xscrollcommand ".bleft.bottom.sbhorizontal set"
1699 $ctext conf
-tabstyle wordprocessor
1701 scrollbar .bleft.bottom.sb
-command "$ctext yview"
1702 scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h \
1704 pack .bleft.top
-side top
-fill x
1705 pack .bleft.mid
-side top
-fill x
1706 grid
$ctext .bleft.bottom.sb
-sticky nsew
1707 grid .bleft.bottom.sbhorizontal
-sticky ew
1708 grid columnconfigure .bleft.bottom
0 -weight 1
1709 grid rowconfigure .bleft.bottom
0 -weight 1
1710 grid rowconfigure .bleft.bottom
1 -weight 0
1711 pack .bleft.bottom
-side top
-fill both
-expand 1
1712 lappend bglist
$ctext
1713 lappend fglist
$ctext
1715 $ctext tag conf comment
-wrap $wrapcomment
1716 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
1717 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
1718 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
1719 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
1720 $ctext tag conf m0
-fore red
1721 $ctext tag conf m1
-fore blue
1722 $ctext tag conf m2
-fore green
1723 $ctext tag conf m3
-fore purple
1724 $ctext tag conf
m4 -fore brown
1725 $ctext tag conf m5
-fore "#009090"
1726 $ctext tag conf m6
-fore magenta
1727 $ctext tag conf m7
-fore "#808000"
1728 $ctext tag conf m8
-fore "#009000"
1729 $ctext tag conf m9
-fore "#ff0080"
1730 $ctext tag conf m10
-fore cyan
1731 $ctext tag conf m11
-fore "#b07070"
1732 $ctext tag conf m12
-fore "#70b0f0"
1733 $ctext tag conf m13
-fore "#70f0b0"
1734 $ctext tag conf m14
-fore "#f0b070"
1735 $ctext tag conf m15
-fore "#ff70b0"
1736 $ctext tag conf mmax
-fore darkgrey
1738 $ctext tag conf mresult
-font textfontbold
1739 $ctext tag conf msep
-font textfontbold
1740 $ctext tag conf found
-back yellow
1742 .pwbottom add .bleft
1743 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
1748 radiobutton .bright.mode.
patch -text [mc
"Patch"] \
1749 -command reselectline
-variable cmitmode
-value "patch"
1750 radiobutton .bright.mode.tree
-text [mc
"Tree"] \
1751 -command reselectline
-variable cmitmode
-value "tree"
1752 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
1753 pack .bright.mode
-side top
-fill x
1754 set cflist .bright.cfiles
1755 set indent
[font measure mainfont
"nn"]
1757 -selectbackground $selectbgcolor \
1758 -background $bgcolor -foreground $fgcolor \
1760 -tabs [list
$indent [expr {2 * $indent}]] \
1761 -yscrollcommand ".bright.sb set" \
1762 -cursor [. cget
-cursor] \
1763 -spacing1 1 -spacing3 1
1764 lappend bglist
$cflist
1765 lappend fglist
$cflist
1766 scrollbar .bright.sb
-command "$cflist yview"
1767 pack .bright.sb
-side right
-fill y
1768 pack
$cflist -side left
-fill both
-expand 1
1769 $cflist tag configure highlight \
1770 -background [$cflist cget
-selectbackground]
1771 $cflist tag configure bold
-font mainfontbold
1773 .pwbottom add .bright
1776 # restore window width & height if known
1777 if {[info exists geometry
(main
)]} {
1778 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
1779 if {$w > [winfo screenwidth .
]} {
1780 set w
[winfo screenwidth .
]
1782 if {$h > [winfo screenheight .
]} {
1783 set h
[winfo screenheight .
]
1785 wm geometry .
"${w}x$h"
1789 if {[tk windowingsystem
] eq
{aqua
}} {
1795 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
1796 pack .ctop
-fill both
-expand 1
1797 bindall
<1> {selcanvline
%W
%x
%y
}
1798 #bindall <B1-Motion> {selcanvline %W %x %y}
1799 if {[tk windowingsystem
] == "win32"} {
1800 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
1801 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
1803 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
1804 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
1805 if {[tk windowingsystem
] eq
"aqua"} {
1806 bindall
<MouseWheel
> {
1807 set delta
[expr {- (%D
)}]
1808 allcanvs yview scroll
$delta units
1812 bindall
<2> "canvscan mark %W %x %y"
1813 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
1814 bindkey
<Home
> selfirstline
1815 bindkey
<End
> sellastline
1816 bind .
<Key-Up
> "selnextline -1"
1817 bind .
<Key-Down
> "selnextline 1"
1818 bind .
<Shift-Key-Up
> "dofind -1 0"
1819 bind .
<Shift-Key-Down
> "dofind 1 0"
1820 bindkey
<Key-Right
> "goforw"
1821 bindkey
<Key-Left
> "goback"
1822 bind .
<Key-Prior
> "selnextpage -1"
1823 bind .
<Key-Next
> "selnextpage 1"
1824 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
1825 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
1826 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
1827 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
1828 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1829 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1830 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
1831 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
1832 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
1833 bindkey p
"selnextline -1"
1834 bindkey n
"selnextline 1"
1837 bindkey i
"selnextline -1"
1838 bindkey k
"selnextline 1"
1841 bindkey b
"$ctext yview scroll -1 pages"
1842 bindkey d
"$ctext yview scroll 18 units"
1843 bindkey u
"$ctext yview scroll -18 units"
1844 bindkey
/ {dofind
1 1}
1845 bindkey
<Key-Return
> {dofind
1 1}
1846 bindkey ?
{dofind
-1 1}
1848 bindkey
<F5
> updatecommits
1849 bind .
<$M1B-q> doquit
1850 bind .
<$M1B-f> {dofind
1 1}
1851 bind .
<$M1B-g> {dofind
1 0}
1852 bind .
<$M1B-r> dosearchback
1853 bind .
<$M1B-s> dosearch
1854 bind .
<$M1B-equal> {incrfont
1}
1855 bind .
<$M1B-plus> {incrfont
1}
1856 bind .
<$M1B-KP_Add> {incrfont
1}
1857 bind .
<$M1B-minus> {incrfont
-1}
1858 bind .
<$M1B-KP_Subtract> {incrfont
-1}
1859 wm protocol . WM_DELETE_WINDOW doquit
1860 bind .
<Button-1
> "click %W"
1861 bind $fstring <Key-Return
> {dofind
1 1}
1862 bind $sha1entry <Key-Return
> gotocommit
1863 bind $sha1entry <<PasteSelection>> clearsha1
1864 bind $cflist <1> {sel_flist %W %x %y; break}
1865 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1866 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1867 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1869 set maincursor [. cget -cursor]
1870 set textcursor [$ctext cget -cursor]
1871 set curtextcursor $textcursor
1873 set rowctxmenu .rowctxmenu
1874 menu $rowctxmenu -tearoff 0
1875 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1876 -command {diffvssel 0}
1877 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1878 -command {diffvssel 1}
1879 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1880 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1881 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1882 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1883 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1885 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1888 set fakerowmenu .fakerowmenu
1889 menu $fakerowmenu -tearoff 0
1890 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1891 -command {diffvssel 0}
1892 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1893 -command {diffvssel 1}
1894 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1895 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1896 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1897 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1899 set headctxmenu .headctxmenu
1900 menu $headctxmenu -tearoff 0
1901 $headctxmenu add command -label [mc "Check out this branch"] \
1903 $headctxmenu add command -label [mc "Remove this branch"] \
1907 set flist_menu .flistctxmenu
1908 menu $flist_menu -tearoff 0
1909 $flist_menu add command -label [mc "Highlight this too"] \
1910 -command {flist_hl 0}
1911 $flist_menu add command -label [mc "Highlight this only"] \
1912 -command {flist_hl 1}
1915 # Windows sends all mouse wheel events to the current focused window, not
1916 # the one where the mouse hovers, so bind those events here and redirect
1917 # to the correct window
1918 proc windows_mousewheel_redirector {W X Y D} {
1919 global canv canv2 canv3
1920 set w [winfo containing -displayof $W $X $Y]
1922 set u [expr {$D < 0 ? 5 : -5}]
1923 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1924 allcanvs yview scroll $u units
1927 $w yview scroll $u units
1933 # mouse-2 makes all windows scan vertically, but only the one
1934 # the cursor is in scans horizontally
1935 proc canvscan {op w x y} {
1936 global canv canv2 canv3
1937 foreach c [list $canv $canv2 $canv3] {
1946 proc scrollcanv {cscroll f0 f1} {
1947 $cscroll set $f0 $f1
1952 # when we make a key binding for the toplevel, make sure
1953 # it doesn't get triggered when that key is pressed in the
1954 # find string entry widget.
1955 proc bindkey {ev script} {
1958 set escript [bind Entry $ev]
1959 if {$escript == {}} {
1960 set escript [bind Entry <Key>]
1962 foreach e $entries {
1963 bind $e $ev "$escript; break"
1967 # set the focus back to the toplevel for any click outside
1970 global ctext entries
1971 foreach e [concat $entries $ctext] {
1972 if {$w == $e} return
1977 # Adjust the progress bar for a change in requested extent or canvas size
1978 proc adjustprogress {} {
1979 global progresscanv progressitem progresscoords
1980 global fprogitem fprogcoord lastprogupdate progupdatepending
1981 global rprogitem rprogcoord
1983 set w [expr {[winfo width $progresscanv] - 4}]
1984 set x0 [expr {$w * [lindex $progresscoords 0]}]
1985 set x1 [expr {$w * [lindex $progresscoords 1]}]
1986 set h [winfo height $progresscanv]
1987 $progresscanv coords $progressitem $x0 0 $x1 $h
1988 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1989 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1990 set now [clock clicks -milliseconds]
1991 if {$now >= $lastprogupdate + 100} {
1992 set progupdatepending 0
1994 } elseif {!$progupdatepending} {
1995 set progupdatepending 1
1996 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2000 proc doprogupdate {} {
2001 global lastprogupdate progupdatepending
2003 if {$progupdatepending} {
2004 set progupdatepending 0
2005 set lastprogupdate [clock clicks -milliseconds]
2010 proc savestuff {w} {
2011 global canv canv2 canv3 mainfont textfont uifont tabstop
2012 global stuffsaved findmergefiles maxgraphpct
2013 global maxwidth showneartags showlocalchanges
2014 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2015 global cmitmode wrapcomment datetimeformat limitdiffs
2016 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2019 if {$stuffsaved} return
2020 if {![winfo viewable .]} return
2022 set f [open "~/.gitk-new" w]
2023 puts $f [list set mainfont $mainfont]
2024 puts $f [list set textfont $textfont]
2025 puts $f [list set uifont $uifont]
2026 puts $f [list set tabstop $tabstop]
2027 puts $f [list set findmergefiles $findmergefiles]
2028 puts $f [list set maxgraphpct $maxgraphpct]
2029 puts $f [list set maxwidth $maxwidth]
2030 puts $f [list set cmitmode $cmitmode]
2031 puts $f [list set wrapcomment $wrapcomment]
2032 puts $f [list set autoselect $autoselect]
2033 puts $f [list set showneartags $showneartags]
2034 puts $f [list set showlocalchanges $showlocalchanges]
2035 puts $f [list set datetimeformat $datetimeformat]
2036 puts $f [list set limitdiffs $limitdiffs]
2037 puts $f [list set bgcolor $bgcolor]
2038 puts $f [list set fgcolor $fgcolor]
2039 puts $f [list set colors $colors]
2040 puts $f [list set diffcolors $diffcolors]
2041 puts $f [list set diffcontext $diffcontext]
2042 puts $f [list set selectbgcolor $selectbgcolor]
2044 puts $f "set geometry(main) [wm geometry .]"
2045 puts $f "set geometry(topwidth) [winfo width .tf]"
2046 puts $f "set geometry(topheight) [winfo height .tf]"
2047 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2048 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2049 puts $f "set geometry(botwidth) [winfo width .bleft]"
2050 puts $f "set geometry(botheight) [winfo height .bleft]"
2052 puts -nonewline $f "set permviews {"
2053 for {set v 0} {$v < $nextviewnum} {incr v} {
2054 if {$viewperm($v)} {
2055 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2060 file rename -force "~/.gitk-new" "~/.gitk"
2065 proc resizeclistpanes {win w} {
2067 if {[info exists oldwidth($win)]} {
2068 set s0 [$win sash coord 0]
2069 set s1 [$win sash coord 1]
2071 set sash0 [expr {int($w/2 - 2)}]
2072 set sash1 [expr {int($w*5/6 - 2)}]
2074 set factor [expr {1.0 * $w / $oldwidth($win)}]
2075 set sash0 [expr {int($factor * [lindex $s0 0])}]
2076 set sash1 [expr {int($factor * [lindex $s1 0])}]
2080 if {$sash1 < $sash0 + 20} {
2081 set sash1 [expr {$sash0 + 20}]
2083 if {$sash1 > $w - 10} {
2084 set sash1 [expr {$w - 10}]
2085 if {$sash0 > $sash1 - 20} {
2086 set sash0 [expr {$sash1 - 20}]
2090 $win sash place 0 $sash0 [lindex $s0 1]
2091 $win sash place 1 $sash1 [lindex $s1 1]
2093 set oldwidth($win) $w
2096 proc resizecdetpanes {win w} {
2098 if {[info exists oldwidth($win)]} {
2099 set s0 [$win sash coord 0]
2101 set sash0 [expr {int($w*3/4 - 2)}]
2103 set factor [expr {1.0 * $w / $oldwidth($win)}]
2104 set sash0 [expr {int($factor * [lindex $s0 0])}]
2108 if {$sash0 > $w - 15} {
2109 set sash0 [expr {$w - 15}]
2112 $win sash place 0 $sash0 [lindex $s0 1]
2114 set oldwidth($win) $w
2117 proc allcanvs args {
2118 global canv canv2 canv3
2124 proc bindall {event action} {
2125 global canv canv2 canv3
2126 bind $canv $event $action
2127 bind $canv2 $event $action
2128 bind $canv3 $event $action
2134 if {[winfo exists $w]} {
2139 wm title $w [mc "About gitk"]
2140 message $w.m -text [mc "
2141 Gitk - a commit viewer for git
2143 Copyright © 2005-2006 Paul Mackerras
2145 Use and redistribute under the terms of the GNU General Public License"] \
2146 -justify center -aspect 400 -border 2 -bg white -relief groove
2147 pack $w.m -side top -fill x -padx 2 -pady 2
2148 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2149 pack $w.ok -side bottom
2150 bind $w <Visibility> "focus $w.ok"
2151 bind $w <Key-Escape> "destroy $w"
2152 bind $w <Key-Return> "destroy $w"
2157 if {[winfo exists $w]} {
2161 if {[tk windowingsystem] eq {aqua}} {
2167 wm title $w [mc "Gitk key bindings"]
2168 message $w.m -text "
2169 [mc "Gitk key bindings:"]
2171 [mc "<%s-Q> Quit" $M1T]
2172 [mc "<Home> Move to first commit"]
2173 [mc "<End> Move to last commit"]
2174 [mc "<Up>, p, i Move up one commit"]
2175 [mc "<Down>, n, k Move down one commit"]
2176 [mc "<Left>, z, j Go back in history list"]
2177 [mc "<Right>, x, l Go forward in history list"]
2178 [mc "<PageUp> Move up one page in commit list"]
2179 [mc "<PageDown> Move down one page in commit list"]
2180 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2181 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2182 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2183 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2184 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2185 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2186 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2187 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2188 [mc "<Delete>, b Scroll diff view up one page"]
2189 [mc "<Backspace> Scroll diff view up one page"]
2190 [mc "<Space> Scroll diff view down one page"]
2191 [mc "u Scroll diff view up 18 lines"]
2192 [mc "d Scroll diff view down 18 lines"]
2193 [mc "<%s-F> Find" $M1T]
2194 [mc "<%s-G> Move to next find hit" $M1T]
2195 [mc "<Return> Move to next find hit"]
2196 [mc "/ Move to next find hit, or redo find"]
2197 [mc "? Move to previous find hit"]
2198 [mc "f Scroll diff view to next file"]
2199 [mc "<%s-S> Search for next hit in diff view" $M1T]
2200 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2201 [mc "<%s-KP+> Increase font size" $M1T]
2202 [mc "<%s-plus> Increase font size" $M1T]
2203 [mc "<%s-KP-> Decrease font size" $M1T]
2204 [mc "<%s-minus> Decrease font size" $M1T]
2207 -justify left -bg white -border 2 -relief groove
2208 pack $w.m -side top -fill both -padx 2 -pady 2
2209 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2210 pack $w.ok -side bottom
2211 bind $w <Visibility> "focus $w.ok"
2212 bind $w <Key-Escape> "destroy $w"
2213 bind $w <Key-Return> "destroy $w"
2216 # Procedures for manipulating the file list window at the
2217 # bottom right of the overall window.
2219 proc treeview {w l openlevs} {
2220 global treecontents treediropen treeheight treeparent treeindex
2230 set treecontents() {}
2231 $w conf -state normal
2233 while {[string range $f 0 $prefixend] ne $prefix} {
2234 if {$lev <= $openlevs} {
2235 $w mark set e:$treeindex($prefix) "end -1c"
2236 $w mark gravity e:$treeindex($prefix) left
2238 set treeheight($prefix) $ht
2239 incr ht [lindex $htstack end]
2240 set htstack [lreplace $htstack end end]
2241 set prefixend [lindex $prefendstack end]
2242 set prefendstack [lreplace $prefendstack end end]
2243 set prefix [string range $prefix 0 $prefixend]
2246 set tail [string range $f [expr {$prefixend+1}] end]
2247 while {[set slash [string first "/" $tail]] >= 0} {
2250 lappend prefendstack $prefixend
2251 incr prefixend [expr {$slash + 1}]
2252 set d [string range $tail 0 $slash]
2253 lappend treecontents($prefix) $d
2254 set oldprefix $prefix
2256 set treecontents($prefix) {}
2257 set treeindex($prefix) [incr ix]
2258 set treeparent($prefix) $oldprefix
2259 set tail [string range $tail [expr {$slash+1}] end]
2260 if {$lev <= $openlevs} {
2262 set treediropen($prefix) [expr {$lev < $openlevs}]
2263 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2264 $w mark set d:$ix "end -1c"
2265 $w mark gravity d:$ix left
2267 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2269 $w image create end -align center -image $bm -padx 1 \
2271 $w insert end $d [highlight_tag $prefix]
2272 $w mark set s:$ix "end -1c"
2273 $w mark gravity s:$ix left
2278 if {$lev <= $openlevs} {
2281 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2283 $w insert end $tail [highlight_tag $f]
2285 lappend treecontents($prefix) $tail
2288 while {$htstack ne {}} {
2289 set treeheight($prefix) $ht
2290 incr ht [lindex $htstack end]
2291 set htstack [lreplace $htstack end end]
2292 set prefixend [lindex $prefendstack end]
2293 set prefendstack [lreplace $prefendstack end end]
2294 set prefix [string range $prefix 0 $prefixend]
2296 $w conf -state disabled
2299 proc linetoelt {l} {
2300 global treeheight treecontents
2305 foreach e $treecontents($prefix) {
2310 if {[string index $e end] eq "/"} {
2311 set n $treeheight($prefix$e)
2323 proc highlight_tree {y prefix} {
2324 global treeheight treecontents cflist
2326 foreach e $treecontents($prefix) {
2328 if {[highlight_tag $path] ne {}} {
2329 $cflist tag add bold $y.0 "$y.0 lineend"
2332 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2333 set y [highlight_tree $y $path]
2339 proc treeclosedir {w dir} {
2340 global treediropen treeheight treeparent treeindex
2342 set ix $treeindex($dir)
2343 $w conf -state normal
2344 $w delete s:$ix e:$ix
2345 set treediropen($dir) 0
2346 $w image configure a:$ix -image tri-rt
2347 $w conf -state disabled
2348 set n [expr {1 - $treeheight($dir)}]
2349 while {$dir ne {}} {
2350 incr treeheight($dir) $n
2351 set dir $treeparent($dir)
2355 proc treeopendir {w dir} {
2356 global treediropen treeheight treeparent treecontents treeindex
2358 set ix $treeindex($dir)
2359 $w conf -state normal
2360 $w image configure a:$ix -image tri-dn
2361 $w mark set e:$ix s:$ix
2362 $w mark gravity e:$ix right
2365 set n [llength $treecontents($dir)]
2366 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2369 incr treeheight($x) $n
2371 foreach e $treecontents($dir) {
2373 if {[string index $e end] eq "/"} {
2374 set iy $treeindex($de)
2375 $w mark set d:$iy e:$ix
2376 $w mark gravity d:$iy left
2377 $w insert e:$ix $str
2378 set treediropen($de) 0
2379 $w image create e:$ix -align center -image tri-rt -padx 1 \
2381 $w insert e:$ix $e [highlight_tag $de]
2382 $w mark set s:$iy e:$ix
2383 $w mark gravity s:$iy left
2384 set treeheight($de) 1
2386 $w insert e:$ix $str
2387 $w insert e:$ix $e [highlight_tag $de]
2390 $w mark gravity e:$ix left
2391 $w conf -state disabled
2392 set treediropen($dir) 1
2393 set top [lindex [split [$w index @0,0] .] 0]
2394 set ht [$w cget -height]
2395 set l [lindex [split [$w index s:$ix] .] 0]
2398 } elseif {$l + $n + 1 > $top + $ht} {
2399 set top [expr {$l + $n + 2 - $ht}]
2407 proc treeclick {w x y} {
2408 global treediropen cmitmode ctext cflist cflist_top
2410 if {$cmitmode ne "tree"} return
2411 if {![info exists cflist_top]} return
2412 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2413 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2414 $cflist tag add highlight $l.0 "$l.0 lineend"
2420 set e [linetoelt $l]
2421 if {[string index $e end] ne "/"} {
2423 } elseif {$treediropen($e)} {
2430 proc setfilelist {id} {
2431 global treefilelist cflist
2433 treeview $cflist $treefilelist($id) 0
2436 image create bitmap tri-rt -background black -foreground blue -data {
2437 #define tri-rt_width 13
2438 #define tri-rt_height 13
2439 static unsigned char tri-rt_bits[] = {
2440 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2441 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2444 #define tri-rt-mask_width 13
2445 #define tri-rt-mask_height 13
2446 static unsigned char tri-rt-mask_bits[] = {
2447 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2448 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2451 image create bitmap tri-dn -background black -foreground blue -data {
2452 #define tri-dn_width 13
2453 #define tri-dn_height 13
2454 static unsigned char tri-dn_bits[] = {
2455 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2456 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2459 #define tri-dn-mask_width 13
2460 #define tri-dn-mask_height 13
2461 static unsigned char tri-dn-mask_bits[] = {
2462 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2463 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2467 image create bitmap reficon-T -background black -foreground yellow -data {
2468 #define tagicon_width 13
2469 #define tagicon_height 9
2470 static unsigned char tagicon_bits[] = {
2471 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2472 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2474 #define tagicon-mask_width 13
2475 #define tagicon-mask_height 9
2476 static unsigned char tagicon-mask_bits[] = {
2477 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2478 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2481 #define headicon_width 13
2482 #define headicon_height 9
2483 static unsigned char headicon_bits[] = {
2484 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2485 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2488 #define headicon-mask_width 13
2489 #define headicon-mask_height 9
2490 static unsigned char headicon-mask_bits[] = {
2491 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2492 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2494 image create bitmap reficon-H -background black -foreground green \
2495 -data $rectdata -maskdata $rectmask
2496 image create bitmap reficon-o -background black -foreground "#ddddff" \
2497 -data $rectdata -maskdata $rectmask
2499 proc init_flist {first} {
2500 global cflist cflist_top difffilestart
2502 $cflist conf -state normal
2503 $cflist delete 0.0 end
2505 $cflist insert end $first
2507 $cflist tag add highlight 1.0 "1.0 lineend"
2509 catch {unset cflist_top}
2511 $cflist conf -state disabled
2512 set difffilestart {}
2515 proc highlight_tag {f} {
2516 global highlight_paths
2518 foreach p $highlight_paths {
2519 if {[string match $p $f]} {
2526 proc highlight_filelist {} {
2527 global cmitmode cflist
2529 $cflist conf -state normal
2530 if {$cmitmode ne "tree"} {
2531 set end [lindex [split [$cflist index end] .] 0]
2532 for {set l 2} {$l < $end} {incr l} {
2533 set line [$cflist get $l.0 "$l.0 lineend"]
2534 if {[highlight_tag $line] ne {}} {
2535 $cflist tag add bold $l.0 "$l.0 lineend"
2541 $cflist conf -state disabled
2544 proc unhighlight_filelist {} {
2547 $cflist conf -state normal
2548 $cflist tag remove bold 1.0 end
2549 $cflist conf -state disabled
2552 proc add_flist {fl} {
2555 $cflist conf -state normal
2557 $cflist insert end "\n"
2558 $cflist insert end $f [highlight_tag $f]
2560 $cflist conf -state disabled
2563 proc sel_flist {w x y} {
2564 global ctext difffilestart cflist cflist_top cmitmode
2566 if {$cmitmode eq "tree"} return
2567 if {![info exists cflist_top]} return
2568 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2569 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2570 $cflist tag add highlight $l.0 "$l.0 lineend"
2575 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2579 proc pop_flist_menu {w X Y x y} {
2580 global ctext cflist cmitmode flist_menu flist_menu_file
2581 global treediffs diffids
2584 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2586 if {$cmitmode eq "tree"} {
2587 set e [linetoelt $l]
2588 if {[string index $e end] eq "/"} return
2590 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2592 set flist_menu_file $e
2593 tk_popup $flist_menu $X $Y
2596 proc flist_hl {only} {
2597 global flist_menu_file findstring gdttype
2599 set x [shellquote $flist_menu_file]
2600 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2603 append findstring " " $x
2605 set gdttype [mc "touching paths:"]
2608 # Functions for adding and removing shell-type quoting
2610 proc shellquote {str} {
2611 if {![string match "*\['\"\\ \t]*" $str]} {
2614 if {![string match "*\['\"\\]*" $str]} {
2617 if {![string match "*'*" $str]} {
2620 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2623 proc shellarglist {l} {
2629 append str [shellquote $a]
2634 proc shelldequote {str} {
2639 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2640 append ret [string range $str $used end]
2641 set used [string length $str]
2644 set first [lindex $first 0]
2645 set ch [string index $str $first]
2646 if {$first > $used} {
2647 append ret [string range $str $used [expr {$first - 1}]]
2650 if {$ch eq " " || $ch eq "\t"} break
2653 set first [string first "'" $str $used]
2655 error "unmatched single-quote"
2657 append ret [string range $str $used [expr {$first - 1}]]
2662 if {$used >= [string length $str]} {
2663 error "trailing backslash"
2665 append ret [string index $str $used]
2670 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2671 error "unmatched double-quote"
2673 set first [lindex $first 0]
2674 set ch [string index $str $first]
2675 if {$first > $used} {
2676 append ret [string range $str $used [expr {$first - 1}]]
2679 if {$ch eq "\""} break
2681 append ret [string index $str $used]
2685 return [list $used $ret]
2688 proc shellsplit {str} {
2691 set str [string trimleft $str]
2692 if {$str eq {}} break
2693 set dq [shelldequote $str]
2694 set n [lindex $dq 0]
2695 set word [lindex $dq 1]
2696 set str [string range $str $n end]
2702 # Code to implement multiple views
2704 proc newview {ishighlight} {
2705 global nextviewnum newviewname newviewperm newishighlight
2706 global newviewargs revtreeargs viewargscmd newviewargscmd curview
2708 set newishighlight $ishighlight
2710 if {[winfo exists $top]} {
2714 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
2715 set newviewperm($nextviewnum) 0
2716 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2717 set newviewargscmd($nextviewnum) $viewargscmd($curview)
2718 vieweditor $top $nextviewnum [mc "Gitk view definition"]
2723 global viewname viewperm newviewname newviewperm
2724 global viewargs newviewargs viewargscmd newviewargscmd
2726 set top .gitkvedit-$curview
2727 if {[winfo exists $top]} {
2731 set newviewname($curview) $viewname($curview)
2732 set newviewperm($curview) $viewperm($curview)
2733 set newviewargs($curview) [shellarglist $viewargs($curview)]
2734 set newviewargscmd($curview) $viewargscmd($curview)
2735 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2738 proc vieweditor {top n title} {
2739 global newviewname newviewperm viewfiles bgcolor
2742 wm title $top $title
2743 label $top.nl -text [mc "Name"]
2744 entry $top.name -width 20 -textvariable newviewname($n)
2745 grid $top.nl $top.name -sticky w -pady 5
2746 checkbutton $top.perm -text [mc "Remember this view"] \
2747 -variable newviewperm($n)
2748 grid $top.perm - -pady 5 -sticky w
2749 message $top.al -aspect 1000 \
2750 -text [mc "Commits to include (arguments to git log):"]
2751 grid $top.al - -sticky w -pady 5
2752 entry $top.args -width 50 -textvariable newviewargs($n) \
2753 -background $bgcolor
2754 grid $top.args - -sticky ew -padx 5
2756 message $top.ac -aspect 1000 \
2757 -text [mc "Command to generate more commits to include:"]
2758 grid $top.ac - -sticky w -pady 5
2759 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
2761 grid $top.argscmd - -sticky ew -padx 5
2763 message $top.l -aspect 1000 \
2764 -text [mc "Enter files and directories to include, one per line:"]
2765 grid $top.l - -sticky w
2766 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
2767 if {[info exists viewfiles($n)]} {
2768 foreach f $viewfiles($n) {
2769 $top.t insert end $f
2770 $top.t insert end "\n"
2772 $top.t delete {end - 1c} end
2773 $top.t mark set insert 0.0
2775 grid $top.t - -sticky ew -padx 5
2777 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
2778 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
2779 grid $top.buts.ok $top.buts.can
2780 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2781 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2782 grid $top.buts - -pady 10 -sticky ew
2786 proc doviewmenu {m first cmd op argv} {
2787 set nmenu [$m index end]
2788 for {set i $first} {$i <= $nmenu} {incr i} {
2789 if {[$m entrycget $i -command] eq $cmd} {
2790 eval $m $op $i $argv
2796 proc allviewmenus {n op args} {
2799 doviewmenu .bar.view 5 [list showview $n] $op $args
2800 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2803 proc newviewok {top n} {
2804 global nextviewnum newviewperm newviewname newishighlight
2805 global viewname viewfiles viewperm selectedview curview
2806 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
2809 set newargs [shellsplit $newviewargs($n)]
2811 error_popup "[mc "Error in commit selection arguments:"] $err"
2817 foreach f [split [$top.t get 0.0 end] "\n"] {
2818 set ft [string trim $f]
2823 if {![info exists viewfiles($n)]} {
2824 # creating a new view
2826 set viewname($n) $newviewname($n)
2827 set viewperm($n) $newviewperm($n)
2828 set viewfiles($n) $files
2829 set viewargs($n) $newargs
2830 set viewargscmd($n) $newviewargscmd($n)
2832 if {!$newishighlight} {
2835 run addvhighlight $n
2838 # editing an existing view
2839 set viewperm($n) $newviewperm($n)
2840 if {$newviewname($n) ne $viewname($n)} {
2841 set viewname($n) $newviewname($n)
2842 doviewmenu .bar.view 5 [list showview $n] \
2843 entryconf [list -label $viewname($n)]
2844 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2845 # entryconf [list -label $viewname($n) -value $viewname($n)]
2847 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
2848 $newviewargscmd($n) ne $viewargscmd($n)} {
2849 set viewfiles($n) $files
2850 set viewargs($n) $newargs
2851 set viewargscmd($n) $newviewargscmd($n)
2852 if {$curview == $n} {
2857 catch {destroy $top}
2861 global curview viewperm hlview selectedhlview
2863 if {$curview == 0} return
2864 if {[info exists hlview] && $hlview == $curview} {
2865 set selectedhlview [mc "None"]
2868 allviewmenus $curview delete
2869 set viewperm($curview) 0
2873 proc addviewmenu {n} {
2874 global viewname viewhlmenu
2876 .bar.view add radiobutton -label $viewname($n) \
2877 -command [list showview $n] -variable selectedview -value $n
2878 #$viewhlmenu add radiobutton -label $viewname($n) \
2879 # -command [list addvhighlight $n] -variable selectedhlview
2883 global curview viewfiles cached_commitrow ordertok
2884 global displayorder parentlist rowidlist rowisopt rowfinal
2885 global colormap rowtextx nextcolor canvxmax
2886 global numcommits viewcomplete
2887 global selectedline currentid canv canvy0
2889 global pending_select mainheadid
2892 global hlview selectedhlview commitinterest
2894 if {$n == $curview} return
2896 set ymax [lindex [$canv cget -scrollregion] 3]
2897 set span [$canv yview]
2898 set ytop [expr {[lindex $span 0] * $ymax}]
2899 set ybot [expr {[lindex $span 1] * $ymax}]
2900 set yscreen [expr {($ybot - $ytop) / 2}]
2901 if {[info exists selectedline]} {
2902 set selid $currentid
2903 set y [yc $selectedline]
2904 if {$ytop < $y && $y < $ybot} {
2905 set yscreen [expr {$y - $ytop}]
2907 } elseif {[info exists pending_select]} {
2908 set selid $pending_select
2909 unset pending_select
2913 catch {unset treediffs}
2915 if {[info exists hlview] && $hlview == $n} {
2917 set selectedhlview [mc "None"]
2919 catch {unset commitinterest}
2920 catch {unset cached_commitrow}
2921 catch {unset ordertok}
2925 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
2926 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
2929 if {![info exists viewcomplete($n)]} {
2931 set pending_select $selid
2942 set numcommits $commitidx($n)
2944 catch {unset colormap}
2945 catch {unset rowtextx}
2947 set canvxmax [$canv cget -width]
2953 if {$selid ne {} && [commitinview $selid $n]} {
2954 set row [rowofcommit $selid]
2955 # try to get the selected row in the same position on the screen
2956 set ymax [lindex [$canv cget -scrollregion] 3]
2957 set ytop [expr {[yc $row] - $yscreen}]
2961 set yf [expr {$ytop * 1.0 / $ymax}]
2963 allcanvs yview moveto $yf
2967 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
2968 selectline [rowofcommit $mainheadid] 1
2969 } elseif {!$viewcomplete($n)} {
2971 set pending_select $selid
2973 set pending_select $mainheadid
2976 set row [first_real_row]
2977 if {$row < $numcommits} {
2981 if {!$viewcomplete($n)} {
2982 if {$numcommits == 0} {
2983 show_status [mc "Reading commits..."]
2985 } elseif {$numcommits == 0} {
2986 show_status [mc "No commits selected"]
2990 # Stuff relating to the highlighting facility
2992 proc ishighlighted {id} {
2993 global vhighlights fhighlights nhighlights rhighlights
2995 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
2996 return $nhighlights($id)
2998 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
2999 return $vhighlights($id)
3001 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3002 return $fhighlights($id)
3004 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3005 return $rhighlights($id)
3010 proc bolden {row font} {
3011 global canv linehtag selectedline boldrows
3013 lappend boldrows $row
3014 $canv itemconf $linehtag($row) -font $font
3015 if {[info exists selectedline] && $row == $selectedline} {
3017 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3018 -outline {{}} -tags secsel \
3019 -fill [$canv cget -selectbackground]]
3024 proc bolden_name {row font} {
3025 global canv2 linentag selectedline boldnamerows
3027 lappend boldnamerows $row
3028 $canv2 itemconf $linentag($row) -font $font
3029 if {[info exists selectedline] && $row == $selectedline} {
3030 $canv2 delete secsel
3031 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3032 -outline {{}} -tags secsel \
3033 -fill [$canv2 cget -selectbackground]]
3042 foreach row $boldrows {
3043 if {![ishighlighted [commitonrow $row]]} {
3044 bolden $row mainfont
3046 lappend stillbold $row
3049 set boldrows $stillbold
3052 proc addvhighlight {n} {
3053 global hlview viewcomplete curview vhl_done commitidx
3055 if {[info exists hlview]} {
3059 if {$n != $curview && ![info exists viewcomplete($n)]} {
3062 set vhl_done $commitidx($hlview)
3063 if {$vhl_done > 0} {
3068 proc delvhighlight {} {
3069 global hlview vhighlights
3071 if {![info exists hlview]} return
3073 catch {unset vhighlights}
3077 proc vhighlightmore {} {
3078 global hlview vhl_done commitidx vhighlights curview
3080 set max $commitidx($hlview)
3081 set vr [visiblerows]
3082 set r0 [lindex $vr 0]
3083 set r1 [lindex $vr 1]
3084 for {set i $vhl_done} {$i < $max} {incr i} {
3085 set id [commitonrow $i $hlview]
3086 if {[commitinview $id $curview]} {
3087 set row [rowofcommit $id]
3088 if {$r0 <= $row && $row <= $r1} {
3089 if {![highlighted $row]} {
3090 bolden $row mainfontbold
3092 set vhighlights($id) 1
3100 proc askvhighlight {row id} {
3101 global hlview vhighlights iddrawn
3103 if {[commitinview $id $hlview]} {
3104 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3105 bolden $row mainfontbold
3107 set vhighlights($id) 1
3109 set vhighlights($id) 0
3113 proc hfiles_change {} {
3114 global highlight_files filehighlight fhighlights fh_serial
3115 global highlight_paths gdttype
3117 if {[info exists filehighlight]} {
3118 # delete previous highlights
3119 catch {close $filehighlight}
3121 catch {unset fhighlights}
3123 unhighlight_filelist
3125 set highlight_paths {}
3126 after cancel do_file_hl $fh_serial
3128 if {$highlight_files ne {}} {
3129 after 300 do_file_hl $fh_serial
3133 proc gdttype_change {name ix op} {
3134 global gdttype highlight_files findstring findpattern
3137 if {$findstring ne {}} {
3138 if {$gdttype eq [mc "containing:"]} {
3139 if {$highlight_files ne {}} {
3140 set highlight_files {}
3145 if {$findpattern ne {}} {
3149 set highlight_files $findstring
3154 # enable/disable findtype/findloc menus too
3157 proc find_change {name ix op} {
3158 global gdttype findstring highlight_files
3161 if {$gdttype eq [mc "containing:"]} {
3164 if {$highlight_files ne $findstring} {
3165 set highlight_files $findstring
3172 proc findcom_change args {
3173 global nhighlights boldnamerows
3174 global findpattern findtype findstring gdttype
3177 # delete previous highlights, if any
3178 foreach row $boldnamerows {
3179 bolden_name $row mainfont
3182 catch {unset nhighlights}
3185 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3187 } elseif {$findtype eq [mc "Regexp"]} {
3188 set findpattern $findstring
3190 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3192 set findpattern "*$e*"
3196 proc makepatterns {l} {
3199 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3200 if {[string index $ee end] eq "/"} {
3210 proc do_file_hl {serial} {
3211 global highlight_files filehighlight highlight_paths gdttype fhl_list
3213 if {$gdttype eq [mc "touching paths:"]} {
3214 if {[catch {set paths [shellsplit $highlight_files]}]} return
3215 set highlight_paths [makepatterns $paths]
3217 set gdtargs [concat -- $paths]
3218 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3219 set gdtargs [list "-S$highlight_files"]
3221 # must be "containing:", i.e. we're searching commit info
3224 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3225 set filehighlight [open $cmd r+]
3226 fconfigure $filehighlight -blocking 0
3227 filerun $filehighlight readfhighlight
3233 proc flushhighlights {} {
3234 global filehighlight fhl_list
3236 if {[info exists filehighlight]} {
3238 puts $filehighlight ""
3239 flush $filehighlight
3243 proc askfilehighlight {row id} {
3244 global filehighlight fhighlights fhl_list
3246 lappend fhl_list $id
3247 set fhighlights($id) -1
3248 puts $filehighlight $id
3251 proc readfhighlight {} {
3252 global filehighlight fhighlights curview iddrawn
3253 global fhl_list find_dirn
3255 if {![info exists filehighlight]} {
3259 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3260 set line [string trim $line]
3261 set i [lsearch -exact $fhl_list $line]
3262 if {$i < 0} continue
3263 for {set j 0} {$j < $i} {incr j} {
3264 set id [lindex $fhl_list $j]
3265 set fhighlights($id) 0
3267 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3268 if {$line eq {}} continue
3269 if {![commitinview $line $curview]} continue
3270 set row [rowofcommit $line]
3271 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3272 bolden $row mainfontbold
3274 set fhighlights($line) 1
3276 if {[eof $filehighlight]} {
3278 puts "oops, git diff-tree died"
3279 catch {close $filehighlight}
3283 if {[info exists find_dirn]} {
3289 proc doesmatch {f} {
3290 global findtype findpattern
3292 if {$findtype eq [mc "Regexp"]} {
3293 return [regexp $findpattern $f]
3294 } elseif {$findtype eq [mc "IgnCase"]} {
3295 return [string match -nocase $findpattern $f]
3297 return [string match $findpattern $f]
3301 proc askfindhighlight {row id} {
3302 global nhighlights commitinfo iddrawn
3304 global markingmatches
3306 if {![info exists commitinfo($id)]} {
3309 set info $commitinfo($id)
3311 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3312 foreach f $info ty $fldtypes {
3313 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3315 if {$ty eq [mc "Author"]} {
3322 if {$isbold && [info exists iddrawn($id)]} {
3323 if {![ishighlighted $id]} {
3324 bolden $row mainfontbold
3326 bolden_name $row mainfontbold
3329 if {$markingmatches} {
3330 markrowmatches $row $id
3333 set nhighlights($id) $isbold
3336 proc markrowmatches {row id} {
3337 global canv canv2 linehtag linentag commitinfo findloc
3339 set headline [lindex $commitinfo($id) 0]
3340 set author [lindex $commitinfo($id) 1]
3341 $canv delete match$row
3342 $canv2 delete match$row
3343 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3344 set m [findmatches $headline]
3346 markmatches $canv $row $headline $linehtag($row) $m \
3347 [$canv itemcget $linehtag($row) -font] $row
3350 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3351 set m [findmatches $author]
3353 markmatches $canv2 $row $author $linentag($row) $m \
3354 [$canv2 itemcget $linentag($row) -font] $row
3359 proc vrel_change {name ix op} {
3360 global highlight_related
3363 if {$highlight_related ne [mc "None"]} {
3368 # prepare for testing whether commits are descendents or ancestors of a
3369 proc rhighlight_sel {a} {
3370 global descendent desc_todo ancestor anc_todo
3371 global highlight_related
3373 catch {unset descendent}
3374 set desc_todo [list $a]
3375 catch {unset ancestor}
3376 set anc_todo [list $a]
3377 if {$highlight_related ne [mc "None"]} {
3383 proc rhighlight_none {} {
3386 catch {unset rhighlights}
3390 proc is_descendent {a} {
3391 global curview children descendent desc_todo
3394 set la [rowofcommit $a]
3398 for {set i 0} {$i < [llength $todo]} {incr i} {
3399 set do [lindex $todo $i]
3400 if {[rowofcommit $do] < $la} {
3401 lappend leftover $do
3404 foreach nk $children($v,$do) {
3405 if {![info exists descendent($nk)]} {
3406 set descendent($nk) 1
3414 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3418 set descendent($a) 0
3419 set desc_todo $leftover
3422 proc is_ancestor {a} {
3423 global curview parents ancestor anc_todo
3426 set la [rowofcommit $a]
3430 for {set i 0} {$i < [llength $todo]} {incr i} {
3431 set do [lindex $todo $i]
3432 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3433 lappend leftover $do
3436 foreach np $parents($v,$do) {
3437 if {![info exists ancestor($np)]} {
3446 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3451 set anc_todo $leftover
3454 proc askrelhighlight {row id} {
3455 global descendent highlight_related iddrawn rhighlights
3456 global selectedline ancestor
3458 if {![info exists selectedline]} return
3460 if {$highlight_related eq [mc "Descendant"] ||
3461 $highlight_related eq [mc "Not descendant"]} {
3462 if {![info exists descendent($id)]} {
3465 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3468 } elseif {$highlight_related eq [mc "Ancestor"] ||
3469 $highlight_related eq [mc "Not ancestor"]} {
3470 if {![info exists ancestor($id)]} {
3473 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3477 if {[info exists iddrawn($id)]} {
3478 if {$isbold && ![ishighlighted $id]} {
3479 bolden $row mainfontbold
3482 set rhighlights($id) $isbold
3485 # Graph layout functions
3487 proc shortids {ids} {
3490 if {[llength $id] > 1} {
3491 lappend res [shortids $id]
3492 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3493 lappend res [string range $id 0 7]
3504 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3505 if {($n & $mask) != 0} {
3506 set ret [concat $ret $o]
3508 set o [concat $o $o]
3513 proc ordertoken {id} {
3514 global ordertok curview varcid varcstart varctok curview parents children
3515 global nullid nullid2
3517 if {[info exists ordertok($id)]} {
3518 return $ordertok($id)
3523 if {[info exists varcid($curview,$id)]} {
3524 set a $varcid($curview,$id)
3525 set p [lindex $varcstart($curview) $a]
3527 set p [lindex $children($curview,$id) 0]
3529 if {[info exists ordertok($p)]} {
3530 set tok $ordertok($p)
3533 set id [first_real_child $curview,$p]
3536 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3539 if {[llength $parents($curview,$id)] == 1} {
3540 lappend todo [list $p {}]
3542 set j [lsearch -exact $parents($curview,$id) $p]
3544 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3546 lappend todo [list $p [strrep $j]]
3549 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3550 set p [lindex $todo $i 0]
3551 append tok [lindex $todo $i 1]
3552 set ordertok($p) $tok
3554 set ordertok($origid) $tok
3558 # Work out where id should go in idlist so that order-token
3559 # values increase from left to right
3560 proc idcol {idlist id {i 0}} {
3561 set t [ordertoken $id]
3565 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3566 if {$i > [llength $idlist]} {
3567 set i [llength $idlist]
3569 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3572 if {$t > [ordertoken [lindex $idlist $i]]} {
3573 while {[incr i] < [llength $idlist] &&
3574 $t >= [ordertoken [lindex $idlist $i]]} {}
3580 proc initlayout {} {
3581 global rowidlist rowisopt rowfinal displayorder parentlist
3582 global numcommits canvxmax canv
3584 global colormap rowtextx
3593 set canvxmax [$canv cget -width]
3594 catch {unset colormap}
3595 catch {unset rowtextx}
3599 proc setcanvscroll {} {
3600 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3601 global lastscrollset lastscrollrows
3603 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3604 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3605 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3606 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3607 set lastscrollset [clock clicks -milliseconds]
3608 set lastscrollrows $numcommits
3611 proc visiblerows {} {
3612 global canv numcommits linespc
3614 set ymax [lindex [$canv cget -scrollregion] 3]
3615 if {$ymax eq {} || $ymax == 0} return
3617 set y0 [expr {int([lindex $f 0] * $ymax)}]
3618 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3622 set y1 [expr {int([lindex $f 1] * $ymax)}]
3623 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3624 if {$r1 >= $numcommits} {
3625 set r1 [expr {$numcommits - 1}]
3627 return [list $r0 $r1]
3630 proc layoutmore {} {
3631 global commitidx viewcomplete curview
3632 global numcommits pending_select selectedline curview
3633 global lastscrollset lastscrollrows commitinterest
3635 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
3636 [clock clicks -milliseconds] - $lastscrollset > 500} {
3639 if {[info exists pending_select] &&
3640 [commitinview $pending_select $curview]} {
3641 selectline [rowofcommit $pending_select] 1
3646 proc doshowlocalchanges {} {
3647 global curview mainheadid
3649 if {[commitinview $mainheadid $curview]} {
3652 lappend commitinterest($mainheadid) {dodiffindex}
3656 proc dohidelocalchanges {} {
3657 global nullid nullid2 lserial curview
3659 if {[commitinview $nullid $curview]} {
3660 removefakerow $nullid
3662 if {[commitinview $nullid2 $curview]} {
3663 removefakerow $nullid2
3668 # spawn off a process to do git diff-index --cached HEAD
3669 proc dodiffindex {} {
3670 global lserial showlocalchanges
3673 if {!$showlocalchanges || !$isworktree} return
3675 set fd [open "|git diff-index --cached HEAD" r]
3676 fconfigure $fd -blocking 0
3677 filerun $fd [list readdiffindex $fd $lserial]
3680 proc readdiffindex {fd serial} {
3681 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3684 if {[gets $fd line] < 0} {
3690 # we only need to see one line and we don't really care what it says...
3693 if {$serial != $lserial} {
3697 # now see if there are any local changes not checked in to the index
3698 set fd [open "|git diff-files" r]
3699 fconfigure $fd -blocking 0
3700 filerun $fd [list readdifffiles $fd $serial]
3702 if {$isdiff && ![commitinview $nullid2 $curview]} {
3703 # add the line for the changes in the index to the graph
3704 set hl [mc "Local changes checked in to index but not committed"]
3705 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3706 set commitdata($nullid2) "\n $hl\n"
3707 if {[commitinview $nullid $curview]} {
3708 removefakerow $nullid
3710 insertfakerow $nullid2 $mainheadid
3711 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
3712 removefakerow $nullid2
3717 proc readdifffiles {fd serial} {
3718 global mainheadid nullid nullid2 curview
3719 global commitinfo commitdata lserial
3722 if {[gets $fd line] < 0} {
3728 # we only need to see one line and we don't really care what it says...
3731 if {$serial != $lserial} {
3735 if {$isdiff && ![commitinview $nullid $curview]} {
3736 # add the line for the local diff to the graph
3737 set hl [mc "Local uncommitted changes, not checked in to index"]
3738 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3739 set commitdata($nullid) "\n $hl\n"
3740 if {[commitinview $nullid2 $curview]} {
3745 insertfakerow $nullid $p
3746 } elseif {!$isdiff && [commitinview $nullid $curview]} {
3747 removefakerow $nullid
3752 proc nextuse {id row} {
3753 global curview children
3755 if {[info exists children($curview,$id)]} {
3756 foreach kid $children($curview,$id) {
3757 if {![commitinview $kid $curview]} {
3760 if {[rowofcommit $kid] > $row} {
3761 return [rowofcommit $kid]
3765 if {[commitinview $id $curview]} {
3766 return [rowofcommit $id]
3771 proc prevuse {id row} {
3772 global curview children
3775 if {[info exists children($curview,$id)]} {
3776 foreach kid $children($curview,$id) {
3777 if {![commitinview $kid $curview]} break
3778 if {[rowofcommit $kid] < $row} {
3779 set ret [rowofcommit $kid]
3786 proc make_idlist {row} {
3787 global displayorder parentlist uparrowlen downarrowlen mingaplen
3788 global commitidx curview children
3790 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3794 set ra [expr {$row - $downarrowlen}]
3798 set rb [expr {$row + $uparrowlen}]
3799 if {$rb > $commitidx($curview)} {
3800 set rb $commitidx($curview)
3802 make_disporder $r [expr {$rb + 1}]
3804 for {} {$r < $ra} {incr r} {
3805 set nextid [lindex $displayorder [expr {$r + 1}]]
3806 foreach p [lindex $parentlist $r] {
3807 if {$p eq $nextid} continue
3808 set rn [nextuse $p $r]
3810 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3811 lappend ids [list [ordertoken $p] $p]
3815 for {} {$r < $row} {incr r} {
3816 set nextid [lindex $displayorder [expr {$r + 1}]]
3817 foreach p [lindex $parentlist $r] {
3818 if {$p eq $nextid} continue
3819 set rn [nextuse $p $r]
3820 if {$rn < 0 || $rn >= $row} {
3821 lappend ids [list [ordertoken $p] $p]
3825 set id [lindex $displayorder $row]
3826 lappend ids [list [ordertoken $id] $id]
3828 foreach p [lindex $parentlist $r] {
3829 set firstkid [lindex $children($curview,$p) 0]
3830 if {[rowofcommit $firstkid] < $row} {
3831 lappend ids [list [ordertoken $p] $p]
3835 set id [lindex $displayorder $r]
3837 set firstkid [lindex $children($curview,$id) 0]
3838 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3839 lappend ids [list [ordertoken $id] $id]
3844 foreach idx [lsort -unique $ids] {
3845 lappend idlist [lindex $idx 1]
3850 proc rowsequal {a b} {
3851 while {[set i [lsearch -exact $a {}]] >= 0} {
3852 set a [lreplace $a $i $i]
3854 while {[set i [lsearch -exact $b {}]] >= 0} {
3855 set b [lreplace $b $i $i]
3857 return [expr {$a eq $b}]
3860 proc makeupline {id row rend col} {
3861 global rowidlist uparrowlen downarrowlen mingaplen
3863 for {set r $rend} {1} {set r $rstart} {
3864 set rstart [prevuse $id $r]
3865 if {$rstart < 0} return
3866 if {$rstart < $row} break
3868 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3869 set rstart [expr {$rend - $uparrowlen - 1}]
3871 for {set r $rstart} {[incr r] <= $row} {} {
3872 set idlist [lindex $rowidlist $r]
3873 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3874 set col [idcol $idlist $id $col]
3875 lset rowidlist $r [linsert $idlist $col $id]
3881 proc layoutrows {row endrow} {
3882 global rowidlist rowisopt rowfinal displayorder
3883 global uparrowlen downarrowlen maxwidth mingaplen
3884 global children parentlist
3885 global commitidx viewcomplete curview
3887 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3890 set rm1 [expr {$row - 1}]
3891 foreach id [lindex $rowidlist $rm1] {
3896 set final [lindex $rowfinal $rm1]
3898 for {} {$row < $endrow} {incr row} {
3899 set rm1 [expr {$row - 1}]
3900 if {$rm1 < 0 || $idlist eq {}} {
3901 set idlist [make_idlist $row]
3904 set id [lindex $displayorder $rm1]
3905 set col [lsearch -exact $idlist $id]
3906 set idlist [lreplace $idlist $col $col]
3907 foreach p [lindex $parentlist $rm1] {
3908 if {[lsearch -exact $idlist $p] < 0} {
3909 set col [idcol $idlist $p $col]
3910 set idlist [linsert $idlist $col $p]
3911 # if not the first child, we have to insert a line going up
3912 if {$id ne [lindex $children($curview,$p) 0]} {
3913 makeupline $p $rm1 $row $col
3917 set id [lindex $displayorder $row]
3918 if {$row > $downarrowlen} {
3919 set termrow [expr {$row - $downarrowlen - 1}]
3920 foreach p [lindex $parentlist $termrow] {
3921 set i [lsearch -exact $idlist $p]
3922 if {$i < 0} continue
3923 set nr [nextuse $p $termrow]
3924 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3925 set idlist [lreplace $idlist $i $i]
3929 set col [lsearch -exact $idlist $id]
3931 set col [idcol $idlist $id]
3932 set idlist [linsert $idlist $col $id]
3933 if {$children($curview,$id) ne {}} {
3934 makeupline $id $rm1 $row $col
3937 set r [expr {$row + $uparrowlen - 1}]
3938 if {$r < $commitidx($curview)} {
3940 foreach p [lindex $parentlist $r] {
3941 if {[lsearch -exact $idlist $p] >= 0} continue
3942 set fk [lindex $children($curview,$p) 0]
3943 if {[rowofcommit $fk] < $row} {
3944 set x [idcol $idlist $p $x]
3945 set idlist [linsert $idlist $x $p]
3948 if {[incr r] < $commitidx($curview)} {
3949 set p [lindex $displayorder $r]
3950 if {[lsearch -exact $idlist $p] < 0} {
3951 set fk [lindex $children($curview,$p) 0]
3952 if {$fk ne {} && [rowofcommit $fk] < $row} {
3953 set x [idcol $idlist $p $x]
3954 set idlist [linsert $idlist $x $p]
3960 if {$final && !$viewcomplete($curview) &&
3961 $row + $uparrowlen + $mingaplen + $downarrowlen
3962 >= $commitidx($curview)} {
3965 set l [llength $rowidlist]
3967 lappend rowidlist $idlist
3969 lappend rowfinal $final
3970 } elseif {$row < $l} {
3971 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3972 lset rowidlist $row $idlist
3975 lset rowfinal $row $final
3977 set pad [ntimes [expr {$row - $l}] {}]
3978 set rowidlist [concat $rowidlist $pad]
3979 lappend rowidlist $idlist
3980 set rowfinal [concat $rowfinal $pad]
3981 lappend rowfinal $final
3982 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3988 proc changedrow {row} {
3989 global displayorder iddrawn rowisopt need_redisplay
3991 set l [llength $rowisopt]
3993 lset rowisopt $row 0
3994 if {$row + 1 < $l} {
3995 lset rowisopt [expr {$row + 1}] 0
3996 if {$row + 2 < $l} {
3997 lset rowisopt [expr {$row + 2}] 0
4001 set id [lindex $displayorder $row]
4002 if {[info exists iddrawn($id)]} {
4003 set need_redisplay 1
4007 proc insert_pad {row col npad} {
4010 set pad [ntimes $npad {}]
4011 set idlist [lindex $rowidlist $row]
4012 set bef [lrange $idlist 0 [expr {$col - 1}]]
4013 set aft [lrange $idlist $col end]
4014 set i [lsearch -exact $aft {}]
4016 set aft [lreplace $aft $i $i]
4018 lset rowidlist $row [concat $bef $pad $aft]
4022 proc optimize_rows {row col endrow} {
4023 global rowidlist rowisopt displayorder curview children
4028 for {} {$row < $endrow} {incr row; set col 0} {
4029 if {[lindex $rowisopt $row]} continue
4031 set y0 [expr {$row - 1}]
4032 set ym [expr {$row - 2}]
4033 set idlist [lindex $rowidlist $row]
4034 set previdlist [lindex $rowidlist $y0]
4035 if {$idlist eq {} || $previdlist eq {}} continue
4037 set pprevidlist [lindex $rowidlist $ym]
4038 if {$pprevidlist eq {}} continue
4044 for {} {$col < [llength $idlist]} {incr col} {
4045 set id [lindex $idlist $col]
4046 if {[lindex $previdlist $col] eq $id} continue
4051 set x0 [lsearch -exact $previdlist $id]
4052 if {$x0 < 0} continue
4053 set z [expr {$x0 - $col}]
4057 set xm [lsearch -exact $pprevidlist $id]
4059 set z0 [expr {$xm - $x0}]
4063 # if row y0 is the first child of $id then it's not an arrow
4064 if {[lindex $children($curview,$id) 0] ne
4065 [lindex $displayorder $y0]} {
4069 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4070 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4073 # Looking at lines from this row to the previous row,
4074 # make them go straight up if they end in an arrow on
4075 # the previous row; otherwise make them go straight up
4077 if {$z < -1 || ($z < 0 && $isarrow)} {
4078 # Line currently goes left too much;
4079 # insert pads in the previous row, then optimize it
4080 set npad [expr {-1 - $z + $isarrow}]
4081 insert_pad $y0 $x0 $npad
4083 optimize_rows $y0 $x0 $row
4085 set previdlist [lindex $rowidlist $y0]
4086 set x0 [lsearch -exact $previdlist $id]
4087 set z [expr {$x0 - $col}]
4089 set pprevidlist [lindex $rowidlist $ym]
4090 set xm [lsearch -exact $pprevidlist $id]
4091 set z0 [expr {$xm - $x0}]
4093 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4094 # Line currently goes right too much;
4095 # insert pads in this line
4096 set npad [expr {$z - 1 + $isarrow}]
4097 insert_pad $row $col $npad
4098 set idlist [lindex $rowidlist $row]
4100 set z [expr {$x0 - $col}]
4103 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4104 # this line links to its first child on row $row-2
4105 set id [lindex $displayorder $ym]
4106 set xc [lsearch -exact $pprevidlist $id]
4108 set z0 [expr {$xc - $x0}]
4111 # avoid lines jigging left then immediately right
4112 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4113 insert_pad $y0 $x0 1
4115 optimize_rows $y0 $x0 $row
4116 set previdlist [lindex $rowidlist $y0]
4120 # Find the first column that doesn't have a line going right
4121 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4122 set id [lindex $idlist $col]
4123 if {$id eq {}} break
4124 set x0 [lsearch -exact $previdlist $id]
4126 # check if this is the link to the first child
4127 set kid [lindex $displayorder $y0]
4128 if {[lindex $children($curview,$id) 0] eq $kid} {
4129 # it is, work out offset to child
4130 set x0 [lsearch -exact $previdlist $kid]
4133 if {$x0 <= $col} break
4135 # Insert a pad at that column as long as it has a line and
4136 # isn't the last column
4137 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4138 set idlist [linsert $idlist $col {}]
4139 lset rowidlist $row $idlist
4147 global canvx0 linespc
4148 return [expr {$canvx0 + $col * $linespc}]
4152 global canvy0 linespc
4153 return [expr {$canvy0 + $row * $linespc}]
4156 proc linewidth {id} {
4157 global thickerline lthickness
4160 if {[info exists thickerline] && $id eq $thickerline} {
4161 set wid [expr {2 * $lthickness}]
4166 proc rowranges {id} {
4167 global curview children uparrowlen downarrowlen
4170 set kids $children($curview,$id)
4176 foreach child $kids {
4177 if {![commitinview $child $curview]} break
4178 set row [rowofcommit $child]
4179 if {![info exists prev]} {
4180 lappend ret [expr {$row + 1}]
4182 if {$row <= $prevrow} {
4183 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4185 # see if the line extends the whole way from prevrow to row
4186 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4187 [lsearch -exact [lindex $rowidlist \
4188 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4189 # it doesn't, see where it ends
4190 set r [expr {$prevrow + $downarrowlen}]
4191 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4192 while {[incr r -1] > $prevrow &&
4193 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4195 while {[incr r] <= $row &&
4196 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4200 # see where it starts up again
4201 set r [expr {$row - $uparrowlen}]
4202 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4203 while {[incr r] < $row &&
4204 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4206 while {[incr r -1] >= $prevrow &&
4207 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4213 if {$child eq $id} {
4222 proc drawlineseg {id row endrow arrowlow} {
4223 global rowidlist displayorder iddrawn linesegs
4224 global canv colormap linespc curview maxlinelen parentlist
4226 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4227 set le [expr {$row + 1}]
4230 set c [lsearch -exact [lindex $rowidlist $le] $id]
4236 set x [lindex $displayorder $le]
4241 if {[info exists iddrawn($x)] || $le == $endrow} {
4242 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4258 if {[info exists linesegs($id)]} {
4259 set lines $linesegs($id)
4261 set r0 [lindex $li 0]
4263 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4273 set li [lindex $lines [expr {$i-1}]]
4274 set r1 [lindex $li 1]
4275 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4280 set x [lindex $cols [expr {$le - $row}]]
4281 set xp [lindex $cols [expr {$le - 1 - $row}]]
4282 set dir [expr {$xp - $x}]
4284 set ith [lindex $lines $i 2]
4285 set coords [$canv coords $ith]
4286 set ah [$canv itemcget $ith -arrow]
4287 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4288 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4289 if {$x2 ne {} && $x - $x2 == $dir} {
4290 set coords [lrange $coords 0 end-2]
4293 set coords [list [xc $le $x] [yc $le]]
4296 set itl [lindex $lines [expr {$i-1}] 2]
4297 set al [$canv itemcget $itl -arrow]
4298 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4299 } elseif {$arrowlow} {
4300 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4301 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4305 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4306 for {set y $le} {[incr y -1] > $row} {} {
4308 set xp [lindex $cols [expr {$y - 1 - $row}]]
4309 set ndir [expr {$xp - $x}]
4310 if {$dir != $ndir || $xp < 0} {
4311 lappend coords [xc $y $x] [yc $y]
4317 # join parent line to first child
4318 set ch [lindex $displayorder $row]
4319 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4321 puts "oops: drawlineseg: child $ch not on row $row"
4322 } elseif {$xc != $x} {
4323 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4324 set d [expr {int(0.5 * $linespc)}]
4327 set x2 [expr {$x1 - $d}]
4329 set x2 [expr {$x1 + $d}]
4332 set y1 [expr {$y2 + $d}]
4333 lappend coords $x1 $y1 $x2 $y2
4334 } elseif {$xc < $x - 1} {
4335 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4336 } elseif {$xc > $x + 1} {
4337 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4341 lappend coords [xc $row $x] [yc $row]
4343 set xn [xc $row $xp]
4345 lappend coords $xn $yn
4349 set t [$canv create line $coords -width [linewidth $id] \
4350 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4353 set lines [linsert $lines $i [list $row $le $t]]
4355 $canv coords $ith $coords
4356 if {$arrow ne $ah} {
4357 $canv itemconf $ith -arrow $arrow
4359 lset lines $i 0 $row
4362 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4363 set ndir [expr {$xo - $xp}]
4364 set clow [$canv coords $itl]
4365 if {$dir == $ndir} {
4366 set clow [lrange $clow 2 end]
4368 set coords [concat $coords $clow]
4370 lset lines [expr {$i-1}] 1 $le
4372 # coalesce two pieces
4374 set b [lindex $lines [expr {$i-1}] 0]
4375 set e [lindex $lines $i 1]
4376 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4378 $canv coords $itl $coords
4379 if {$arrow ne $al} {
4380 $canv itemconf $itl -arrow $arrow
4384 set linesegs($id) $lines
4388 proc drawparentlinks {id row} {
4389 global rowidlist canv colormap curview parentlist
4390 global idpos linespc
4392 set rowids [lindex $rowidlist $row]
4393 set col [lsearch -exact $rowids $id]
4394 if {$col < 0} return
4395 set olds [lindex $parentlist $row]
4396 set row2 [expr {$row + 1}]
4397 set x [xc $row $col]
4400 set d [expr {int(0.5 * $linespc)}]
4401 set ymid [expr {$y + $d}]
4402 set ids [lindex $rowidlist $row2]
4403 # rmx = right-most X coord used
4406 set i [lsearch -exact $ids $p]
4408 puts "oops, parent $p of $id not in list"
4411 set x2 [xc $row2 $i]
4415 set j [lsearch -exact $rowids $p]
4417 # drawlineseg will do this one for us
4421 # should handle duplicated parents here...
4422 set coords [list $x $y]
4424 # if attaching to a vertical segment, draw a smaller
4425 # slant for visual distinctness
4428 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4430 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4432 } elseif {$i < $col && $i < $j} {
4433 # segment slants towards us already
4434 lappend coords [xc $row $j] $y
4436 if {$i < $col - 1} {
4437 lappend coords [expr {$x2 + $linespc}] $y
4438 } elseif {$i > $col + 1} {
4439 lappend coords [expr {$x2 - $linespc}] $y
4441 lappend coords $x2 $y2
4444 lappend coords $x2 $y2
4446 set t [$canv create line $coords -width [linewidth $p] \
4447 -fill $colormap($p) -tags lines.$p]
4451 if {$rmx > [lindex $idpos($id) 1]} {
4452 lset idpos($id) 1 $rmx
4457 proc drawlines {id} {
4460 $canv itemconf lines.$id -width [linewidth $id]
4463 proc drawcmittext {id row col} {
4464 global linespc canv canv2 canv3 fgcolor curview
4465 global cmitlisted commitinfo rowidlist parentlist
4466 global rowtextx idpos idtags idheads idotherrefs
4467 global linehtag linentag linedtag selectedline
4468 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4470 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4471 set listed $cmitlisted($curview,$id)
4472 if {$id eq $nullid} {
4474 } elseif {$id eq $nullid2} {
4477 set ofill [expr {$listed != 0 ? $listed == 2 ? "gray" : "blue" : "white"}]
4479 set x [xc $row $col]
4481 set orad [expr {$linespc / 3}]
4483 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4484 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4485 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4486 } elseif {$listed == 3} {
4487 # triangle pointing left for left-side commits
4488 set t [$canv create polygon \
4489 [expr {$x - $orad}] $y \
4490 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4491 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4492 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4494 # triangle pointing right for right-side commits
4495 set t [$canv create polygon \
4496 [expr {$x + $orad - 1}] $y \
4497 [expr {$x - $orad}] [expr {$y - $orad}] \
4498 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4499 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4502 $canv bind $t <1> {selcanvline {} %x %y}
4503 set rmx [llength [lindex $rowidlist $row]]
4504 set olds [lindex $parentlist $row]
4506 set nextids [lindex $rowidlist [expr {$row + 1}]]
4508 set i [lsearch -exact $nextids $p]
4514 set xt [xc $row $rmx]
4515 set rowtextx($row) $xt
4516 set idpos($id) [list $x $xt $y]
4517 if {[info exists idtags($id)] || [info exists idheads($id)]
4518 || [info exists idotherrefs($id)]} {
4519 set xt [drawtags $id $x $xt $y]
4521 set headline [lindex $commitinfo($id) 0]
4522 set name [lindex $commitinfo($id) 1]
4523 set date [lindex $commitinfo($id) 2]
4524 set date [formatdate $date]
4527 set isbold [ishighlighted $id]
4529 lappend boldrows $row
4530 set font mainfontbold
4532 lappend boldnamerows $row
4533 set nfont mainfontbold
4536 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4537 -text $headline -font $font -tags text]
4538 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4539 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4540 -text $name -font $nfont -tags text]
4541 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4542 -text $date -font mainfont -tags text]
4543 if {[info exists selectedline] && $selectedline == $row} {
4546 set xr [expr {$xt + [font measure $font $headline]}]
4547 if {$xr > $canvxmax} {
4553 proc drawcmitrow {row} {
4554 global displayorder rowidlist nrows_drawn
4555 global iddrawn markingmatches
4556 global commitinfo numcommits
4557 global filehighlight fhighlights findpattern nhighlights
4558 global hlview vhighlights
4559 global highlight_related rhighlights
4561 if {$row >= $numcommits} return
4563 set id [lindex $displayorder $row]
4564 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4565 askvhighlight $row $id
4567 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4568 askfilehighlight $row $id
4570 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4571 askfindhighlight $row $id
4573 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4574 askrelhighlight $row $id
4576 if {![info exists iddrawn($id)]} {
4577 set col [lsearch -exact [lindex $rowidlist $row] $id]
4579 puts "oops, row $row id $id not in list"
4582 if {![info exists commitinfo($id)]} {
4586 drawcmittext $id $row $col
4590 if {$markingmatches} {
4591 markrowmatches $row $id
4595 proc drawcommits {row {endrow {}}} {
4596 global numcommits iddrawn displayorder curview need_redisplay
4597 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4602 if {$endrow eq {}} {
4605 if {$endrow >= $numcommits} {
4606 set endrow [expr {$numcommits - 1}]
4609 set rl1 [expr {$row - $downarrowlen - 3}]
4613 set ro1 [expr {$row - 3}]
4617 set r2 [expr {$endrow + $uparrowlen + 3}]
4618 if {$r2 > $numcommits} {
4621 for {set r $rl1} {$r < $r2} {incr r} {
4622 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4626 set rl1 [expr {$r + 1}]
4632 optimize_rows $ro1 0 $r2
4633 if {$need_redisplay || $nrows_drawn > 2000} {
4638 # make the lines join to already-drawn rows either side
4639 set r [expr {$row - 1}]
4640 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4643 set er [expr {$endrow + 1}]
4644 if {$er >= $numcommits ||
4645 ![info exists iddrawn([lindex $displayorder $er])]} {
4648 for {} {$r <= $er} {incr r} {
4649 set id [lindex $displayorder $r]
4650 set wasdrawn [info exists iddrawn($id)]
4652 if {$r == $er} break
4653 set nextid [lindex $displayorder [expr {$r + 1}]]
4654 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4655 drawparentlinks $id $r
4657 set rowids [lindex $rowidlist $r]
4658 foreach lid $rowids {
4659 if {$lid eq {}} continue
4660 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4662 # see if this is the first child of any of its parents
4663 foreach p [lindex $parentlist $r] {
4664 if {[lsearch -exact $rowids $p] < 0} {
4665 # make this line extend up to the child
4666 set lineend($p) [drawlineseg $p $r $er 0]
4670 set lineend($lid) [drawlineseg $lid $r $er 1]
4676 proc undolayout {row} {
4677 global uparrowlen mingaplen downarrowlen
4678 global rowidlist rowisopt rowfinal need_redisplay
4680 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4684 if {[llength $rowidlist] > $r} {
4686 set rowidlist [lrange $rowidlist 0 $r]
4687 set rowfinal [lrange $rowfinal 0 $r]
4688 set rowisopt [lrange $rowisopt 0 $r]
4689 set need_redisplay 1
4694 proc drawvisible {} {
4695 global canv linespc curview vrowmod selectedline targetrow targetid
4696 global need_redisplay cscroll numcommits
4698 set fs [$canv yview]
4699 set ymax [lindex [$canv cget -scrollregion] 3]
4700 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
4701 set f0 [lindex $fs 0]
4702 set f1 [lindex $fs 1]
4703 set y0 [expr {int($f0 * $ymax)}]
4704 set y1 [expr {int($f1 * $ymax)}]
4706 if {[info exists targetid]} {
4707 if {[commitinview $targetid $curview]} {
4708 set r [rowofcommit $targetid]
4709 if {$r != $targetrow} {
4710 # Fix up the scrollregion and change the scrolling position
4711 # now that our target row has moved.
4712 set diff [expr {($r - $targetrow) * $linespc}]
4715 set ymax [lindex [$canv cget -scrollregion] 3]
4718 set f0 [expr {$y0 / $ymax}]
4719 set f1 [expr {$y1 / $ymax}]
4720 allcanvs yview moveto $f0
4721 $cscroll set $f0 $f1
4722 set need_redisplay 1
4729 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4730 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4731 if {$endrow >= $vrowmod($curview)} {
4732 update_arcrows $curview
4734 if {[info exists selectedline] &&
4735 $row <= $selectedline && $selectedline <= $endrow} {
4736 set targetrow $selectedline
4737 } elseif {[info exists targetid]} {
4738 set targetrow [expr {int(($row + $endrow) / 2)}]
4740 if {[info exists targetrow]} {
4741 if {$targetrow >= $numcommits} {
4742 set targetrow [expr {$numcommits - 1}]
4744 set targetid [commitonrow $targetrow]
4746 drawcommits $row $endrow
4749 proc clear_display {} {
4750 global iddrawn linesegs need_redisplay nrows_drawn
4751 global vhighlights fhighlights nhighlights rhighlights
4754 catch {unset iddrawn}
4755 catch {unset linesegs}
4756 catch {unset vhighlights}
4757 catch {unset fhighlights}
4758 catch {unset nhighlights}
4759 catch {unset rhighlights}
4760 set need_redisplay 0
4764 proc findcrossings {id} {
4765 global rowidlist parentlist numcommits displayorder
4769 foreach {s e} [rowranges $id] {
4770 if {$e >= $numcommits} {
4771 set e [expr {$numcommits - 1}]
4773 if {$e <= $s} continue
4774 for {set row $e} {[incr row -1] >= $s} {} {
4775 set x [lsearch -exact [lindex $rowidlist $row] $id]
4777 set olds [lindex $parentlist $row]
4778 set kid [lindex $displayorder $row]
4779 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4780 if {$kidx < 0} continue
4781 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4783 set px [lsearch -exact $nextrow $p]
4784 if {$px < 0} continue
4785 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4786 if {[lsearch -exact $ccross $p] >= 0} continue
4787 if {$x == $px + ($kidx < $px? -1: 1)} {
4789 } elseif {[lsearch -exact $cross $p] < 0} {
4796 return [concat $ccross {{}} $cross]
4799 proc assigncolor {id} {
4800 global colormap colors nextcolor
4801 global parents children children curview
4803 if {[info exists colormap($id)]} return
4804 set ncolors [llength $colors]
4805 if {[info exists children($curview,$id)]} {
4806 set kids $children($curview,$id)
4810 if {[llength $kids] == 1} {
4811 set child [lindex $kids 0]
4812 if {[info exists colormap($child)]
4813 && [llength $parents($curview,$child)] == 1} {
4814 set colormap($id) $colormap($child)
4820 foreach x [findcrossings $id] {
4822 # delimiter between corner crossings and other crossings
4823 if {[llength $badcolors] >= $ncolors - 1} break
4824 set origbad $badcolors
4826 if {[info exists colormap($x)]
4827 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4828 lappend badcolors $colormap($x)
4831 if {[llength $badcolors] >= $ncolors} {
4832 set badcolors $origbad
4834 set origbad $badcolors
4835 if {[llength $badcolors] < $ncolors - 1} {
4836 foreach child $kids {
4837 if {[info exists colormap($child)]
4838 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4839 lappend badcolors $colormap($child)
4841 foreach p $parents($curview,$child) {
4842 if {[info exists colormap($p)]
4843 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4844 lappend badcolors $colormap($p)
4848 if {[llength $badcolors] >= $ncolors} {
4849 set badcolors $origbad
4852 for {set i 0} {$i <= $ncolors} {incr i} {
4853 set c [lindex $colors $nextcolor]
4854 if {[incr nextcolor] >= $ncolors} {
4857 if {[lsearch -exact $badcolors $c]} break
4859 set colormap($id) $c
4862 proc bindline {t id} {
4865 $canv bind $t <Enter> "lineenter %x %y $id"
4866 $canv bind $t <Motion> "linemotion %x %y $id"
4867 $canv bind $t <Leave> "lineleave $id"
4868 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4871 proc drawtags {id x xt y1} {
4872 global idtags idheads idotherrefs mainhead
4873 global linespc lthickness
4874 global canv rowtextx curview fgcolor bgcolor
4879 if {[info exists idtags($id)]} {
4880 set marks $idtags($id)
4881 set ntags [llength $marks]
4883 if {[info exists idheads($id)]} {
4884 set marks [concat $marks $idheads($id)]
4885 set nheads [llength $idheads($id)]
4887 if {[info exists idotherrefs($id)]} {
4888 set marks [concat $marks $idotherrefs($id)]
4894 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4895 set yt [expr {$y1 - 0.5 * $linespc}]
4896 set yb [expr {$yt + $linespc - 1}]
4900 foreach tag $marks {
4902 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4903 set wid [font measure mainfontbold $tag]
4905 set wid [font measure mainfont $tag]
4909 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4911 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4912 -width $lthickness -fill black -tags tag.$id]
4914 foreach tag $marks x $xvals wid $wvals {
4915 set xl [expr {$x + $delta}]
4916 set xr [expr {$x + $delta + $wid + $lthickness}]
4918 if {[incr ntags -1] >= 0} {
4920 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4921 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4922 -width 1 -outline black -fill yellow -tags tag.$id]
4923 $canv bind $t <1> [list showtag $tag 1]
4924 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4926 # draw a head or other ref
4927 if {[incr nheads -1] >= 0} {
4929 if {$tag eq $mainhead} {
4930 set font mainfontbold
4935 set xl [expr {$xl - $delta/2}]
4936 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4937 -width 1 -outline black -fill $col -tags tag.$id
4938 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4939 set rwid [font measure mainfont $remoteprefix]
4940 set xi [expr {$x + 1}]
4941 set yti [expr {$yt + 1}]
4942 set xri [expr {$x + $rwid}]
4943 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4944 -width 0 -fill "#ffddaa" -tags tag.$id
4947 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4948 -font $font -tags [list tag.$id text]]
4950 $canv bind $t <1> [list showtag $tag 1]
4951 } elseif {$nheads >= 0} {
4952 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4958 proc xcoord {i level ln} {
4959 global canvx0 xspc1 xspc2
4961 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4962 if {$i > 0 && $i == $level} {
4963 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4964 } elseif {$i > $level} {
4965 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4970 proc show_status {msg} {
4974 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4975 -tags text -fill $fgcolor
4978 # Don't change the text pane cursor if it is currently the hand cursor,
4979 # showing that we are over a sha1 ID link.
4980 proc settextcursor {c} {
4981 global ctext curtextcursor
4983 if {[$ctext cget -cursor] == $curtextcursor} {
4984 $ctext config -cursor $c
4986 set curtextcursor $c
4989 proc nowbusy {what {name {}}} {
4990 global isbusy busyname statusw
4992 if {[array names isbusy] eq {}} {
4993 . config -cursor watch
4997 set busyname($what) $name
4999 $statusw conf -text $name
5003 proc notbusy {what} {
5004 global isbusy maincursor textcursor busyname statusw
5008 if {$busyname($what) ne {} &&
5009 [$statusw cget -text] eq $busyname($what)} {
5010 $statusw conf -text {}
5013 if {[array names isbusy] eq {}} {
5014 . config -cursor $maincursor
5015 settextcursor $textcursor
5019 proc findmatches {f} {
5020 global findtype findstring
5021 if {$findtype == [mc "Regexp"]} {
5022 set matches [regexp -indices -all -inline $findstring $f]
5025 if {$findtype == [mc "IgnCase"]} {
5026 set f [string tolower $f]
5027 set fs [string tolower $fs]
5031 set l [string length $fs]
5032 while {[set j [string first $fs $f $i]] >= 0} {
5033 lappend matches [list $j [expr {$j+$l-1}]]
5034 set i [expr {$j + $l}]
5040 proc dofind {{dirn 1} {wrap 1}} {
5041 global findstring findstartline findcurline selectedline numcommits
5042 global gdttype filehighlight fh_serial find_dirn findallowwrap
5044 if {[info exists find_dirn]} {
5045 if {$find_dirn == $dirn} return
5049 if {$findstring eq {} || $numcommits == 0} return
5050 if {![info exists selectedline]} {
5051 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5053 set findstartline $selectedline
5055 set findcurline $findstartline
5056 nowbusy finding [mc "Searching"]
5057 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5058 after cancel do_file_hl $fh_serial
5059 do_file_hl $fh_serial
5062 set findallowwrap $wrap
5066 proc stopfinding {} {
5067 global find_dirn findcurline fprogcoord
5069 if {[info exists find_dirn]} {
5079 global commitdata commitinfo numcommits findpattern findloc
5080 global findstartline findcurline findallowwrap
5081 global find_dirn gdttype fhighlights fprogcoord
5082 global curview varcorder vrownum varccommits vrowmod
5084 if {![info exists find_dirn]} {
5087 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5090 if {$find_dirn > 0} {
5092 if {$l >= $numcommits} {
5095 if {$l <= $findstartline} {
5096 set lim [expr {$findstartline + 1}]
5099 set moretodo $findallowwrap
5106 if {$l >= $findstartline} {
5107 set lim [expr {$findstartline - 1}]
5110 set moretodo $findallowwrap
5113 set n [expr {($lim - $l) * $find_dirn}]
5118 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5119 update_arcrows $curview
5123 set ai [bsearch $vrownum($curview) $l]
5124 set a [lindex $varcorder($curview) $ai]
5125 set arow [lindex $vrownum($curview) $ai]
5126 set ids [lindex $varccommits($curview,$a)]
5127 set arowend [expr {$arow + [llength $ids]}]
5128 if {$gdttype eq [mc "containing:"]} {
5129 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5130 if {$l < $arow || $l >= $arowend} {
5132 set a [lindex $varcorder($curview) $ai]
5133 set arow [lindex $vrownum($curview) $ai]
5134 set ids [lindex $varccommits($curview,$a)]
5135 set arowend [expr {$arow + [llength $ids]}]
5137 set id [lindex $ids [expr {$l - $arow}]]
5138 # shouldn't happen unless git log doesn't give all the commits...
5139 if {![info exists commitdata($id)] ||
5140 ![doesmatch $commitdata($id)]} {
5143 if {![info exists commitinfo($id)]} {
5146 set info $commitinfo($id)
5147 foreach f $info ty $fldtypes {
5148 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5157 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5158 if {$l < $arow || $l >= $arowend} {
5160 set a [lindex $varcorder($curview) $ai]
5161 set arow [lindex $vrownum($curview) $ai]
5162 set ids [lindex $varccommits($curview,$a)]
5163 set arowend [expr {$arow + [llength $ids]}]
5165 set id [lindex $ids [expr {$l - $arow}]]
5166 if {![info exists fhighlights($id)]} {
5167 # this sets fhighlights($id) to -1
5168 askfilehighlight $l $id
5170 if {$fhighlights($id) > 0} {
5174 if {$fhighlights($id) < 0} {
5177 set findcurline [expr {$l - $find_dirn}]
5182 if {$found || ($domore && !$moretodo)} {
5198 set findcurline [expr {$l - $find_dirn}]
5200 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5204 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5209 proc findselectline {l} {
5210 global findloc commentend ctext findcurline markingmatches gdttype
5212 set markingmatches 1
5215 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5216 # highlight the matches in the comments
5217 set f [$ctext get 1.0 $commentend]
5218 set matches [findmatches $f]
5219 foreach match $matches {
5220 set start [lindex $match 0]
5221 set end [expr {[lindex $match 1] + 1}]
5222 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5228 # mark the bits of a headline or author that match a find string
5229 proc markmatches {canv l str tag matches font row} {
5232 set bbox [$canv bbox $tag]
5233 set x0 [lindex $bbox 0]
5234 set y0 [lindex $bbox 1]
5235 set y1 [lindex $bbox 3]
5236 foreach match $matches {
5237 set start [lindex $match 0]
5238 set end [lindex $match 1]
5239 if {$start > $end} continue
5240 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5241 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5242 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5243 [expr {$x0+$xlen+2}] $y1 \
5244 -outline {} -tags [list match$l matches] -fill yellow]
5246 if {[info exists selectedline] && $row == $selectedline} {
5247 $canv raise $t secsel
5252 proc unmarkmatches {} {
5253 global markingmatches
5255 allcanvs delete matches
5256 set markingmatches 0
5260 proc selcanvline {w x y} {
5261 global canv canvy0 ctext linespc
5263 set ymax [lindex [$canv cget -scrollregion] 3]
5264 if {$ymax == {}} return
5265 set yfrac [lindex [$canv yview] 0]
5266 set y [expr {$y + $yfrac * $ymax}]
5267 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5272 set xmax [lindex [$canv cget -scrollregion] 2]
5273 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5274 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5280 proc commit_descriptor {p} {
5282 if {![info exists commitinfo($p)]} {
5286 if {[llength $commitinfo($p)] > 1} {
5287 set l [lindex $commitinfo($p) 0]
5292 # append some text to the ctext widget, and make any SHA1 ID
5293 # that we know about be a clickable link.
5294 proc appendwithlinks {text tags} {
5295 global ctext linknum curview pendinglinks
5297 set start [$ctext index "end - 1c"]
5298 $ctext insert end $text $tags
5299 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5303 set linkid [string range $text $s $e]
5305 $ctext tag delete link$linknum
5306 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5307 setlink $linkid link$linknum
5312 proc setlink {id lk} {
5313 global curview ctext pendinglinks commitinterest
5315 if {[commitinview $id $curview]} {
5316 $ctext tag conf $lk -foreground blue -underline 1
5317 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5318 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5319 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5321 lappend pendinglinks($id) $lk
5322 lappend commitinterest($id) {makelink %I}
5326 proc makelink {id} {
5329 if {![info exists pendinglinks($id)]} return
5330 foreach lk $pendinglinks($id) {
5333 unset pendinglinks($id)
5336 proc linkcursor {w inc} {
5337 global linkentercount curtextcursor
5339 if {[incr linkentercount $inc] > 0} {
5340 $w configure -cursor hand2
5342 $w configure -cursor $curtextcursor
5343 if {$linkentercount < 0} {
5344 set linkentercount 0
5349 proc viewnextline {dir} {
5353 set ymax [lindex [$canv cget -scrollregion] 3]
5354 set wnow [$canv yview]
5355 set wtop [expr {[lindex $wnow 0] * $ymax}]
5356 set newtop [expr {$wtop + $dir * $linespc}]
5359 } elseif {$newtop > $ymax} {
5362 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5365 # add a list of tag or branch names at position pos
5366 # returns the number of names inserted
5367 proc appendrefs {pos ids var} {
5368 global ctext linknum curview $var maxrefs
5370 if {[catch {$ctext index $pos}]} {
5373 $ctext conf -state normal
5374 $ctext delete $pos "$pos lineend"
5377 foreach tag [set $var\($id\)] {
5378 lappend tags [list $tag $id]
5381 if {[llength $tags] > $maxrefs} {
5382 $ctext insert $pos "many ([llength $tags])"
5384 set tags [lsort -index 0 -decreasing $tags]
5387 set id [lindex $ti 1]
5390 $ctext tag delete $lk
5391 $ctext insert $pos $sep
5392 $ctext insert $pos [lindex $ti 0] $lk
5397 $ctext conf -state disabled
5398 return [llength $tags]
5401 # called when we have finished computing the nearby tags
5402 proc dispneartags {delay} {
5403 global selectedline currentid showneartags tagphase
5405 if {![info exists selectedline] || !$showneartags} return
5406 after cancel dispnexttag
5408 after 200 dispnexttag
5411 after idle dispnexttag
5416 proc dispnexttag {} {
5417 global selectedline currentid showneartags tagphase ctext
5419 if {![info exists selectedline] || !$showneartags} return
5420 switch -- $tagphase {
5422 set dtags [desctags $currentid]
5424 appendrefs precedes $dtags idtags
5428 set atags [anctags $currentid]
5430 appendrefs follows $atags idtags
5434 set dheads [descheads $currentid]
5435 if {$dheads ne {}} {
5436 if {[appendrefs branch $dheads idheads] > 1
5437 && [$ctext get "branch -3c"] eq "h"} {
5438 # turn "Branch" into "Branches"
5439 $ctext conf -state normal
5440 $ctext insert "branch -2c" "es"
5441 $ctext conf -state disabled
5446 if {[incr tagphase] <= 2} {
5447 after idle dispnexttag
5451 proc make_secsel {l} {
5452 global linehtag linentag linedtag canv canv2 canv3
5454 if {![info exists linehtag($l)]} return
5456 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5457 -tags secsel -fill [$canv cget -selectbackground]]
5459 $canv2 delete secsel
5460 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5461 -tags secsel -fill [$canv2 cget -selectbackground]]
5463 $canv3 delete secsel
5464 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5465 -tags secsel -fill [$canv3 cget -selectbackground]]
5469 proc selectline {l isnew} {
5470 global canv ctext commitinfo selectedline
5471 global canvy0 linespc parents children curview
5472 global currentid sha1entry
5473 global commentend idtags linknum
5474 global mergemax numcommits pending_select
5475 global cmitmode showneartags allcommits
5476 global targetrow targetid lastscrollrows
5479 catch {unset pending_select}
5484 if {$l < 0 || $l >= $numcommits} return
5485 set id [commitonrow $l]
5490 if {$lastscrollrows < $numcommits} {
5494 set y [expr {$canvy0 + $l * $linespc}]
5495 set ymax [lindex [$canv cget -scrollregion] 3]
5496 set ytop [expr {$y - $linespc - 1}]
5497 set ybot [expr {$y + $linespc + 1}]
5498 set wnow [$canv yview]
5499 set wtop [expr {[lindex $wnow 0] * $ymax}]
5500 set wbot [expr {[lindex $wnow 1] * $ymax}]
5501 set wh [expr {$wbot - $wtop}]
5503 if {$ytop < $wtop} {
5504 if {$ybot < $wtop} {
5505 set newtop [expr {$y - $wh / 2.0}]
5508 if {$newtop > $wtop - $linespc} {
5509 set newtop [expr {$wtop - $linespc}]
5512 } elseif {$ybot > $wbot} {
5513 if {$ytop > $wbot} {
5514 set newtop [expr {$y - $wh / 2.0}]
5516 set newtop [expr {$ybot - $wh}]
5517 if {$newtop < $wtop + $linespc} {
5518 set newtop [expr {$wtop + $linespc}]
5522 if {$newtop != $wtop} {
5526 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5533 addtohistory [list selbyid $id]
5536 $sha1entry delete 0 end
5537 $sha1entry insert 0 $id
5539 $sha1entry selection from 0
5540 $sha1entry selection to end
5544 $ctext conf -state normal
5547 if {![info exists commitinfo($id)]} {
5550 set info $commitinfo($id)
5551 set date [formatdate [lindex $info 2]]
5552 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5553 set date [formatdate [lindex $info 4]]
5554 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5555 if {[info exists idtags($id)]} {
5556 $ctext insert end [mc "Tags:"]
5557 foreach tag $idtags($id) {
5558 $ctext insert end " $tag"
5560 $ctext insert end "\n"
5564 set olds $parents($curview,$id)
5565 if {[llength $olds] > 1} {
5568 if {$np >= $mergemax} {
5573 $ctext insert end "[mc "Parent"]: " $tag
5574 appendwithlinks [commit_descriptor $p] {}
5579 append headers "[mc "Parent"]: [commit_descriptor $p]"
5583 foreach c $children($curview,$id) {
5584 append headers "[mc "Child"]: [commit_descriptor $c]"
5587 # make anything that looks like a SHA1 ID be a clickable link
5588 appendwithlinks $headers {}
5589 if {$showneartags} {
5590 if {![info exists allcommits]} {
5593 $ctext insert end "[mc "Branch"]: "
5594 $ctext mark set branch "end -1c"
5595 $ctext mark gravity branch left
5596 $ctext insert end "\n[mc "Follows"]: "
5597 $ctext mark set follows "end -1c"
5598 $ctext mark gravity follows left
5599 $ctext insert end "\n[mc "Precedes"]: "
5600 $ctext mark set precedes "end -1c"
5601 $ctext mark gravity precedes left
5602 $ctext insert end "\n"
5605 $ctext insert end "\n"
5606 set comment [lindex $info 5]
5607 if {[string first "\r" $comment] >= 0} {
5608 set comment [string map {"\r" "\n "} $comment]
5610 appendwithlinks $comment {comment}
5612 $ctext tag remove found 1.0 end
5613 $ctext conf -state disabled
5614 set commentend [$ctext index "end - 1c"]
5616 init_flist [mc "Comments"]
5617 if {$cmitmode eq "tree"} {
5619 } elseif {[llength $olds] <= 1} {
5626 proc selfirstline {} {
5631 proc sellastline {} {
5634 set l [expr {$numcommits - 1}]
5638 proc selnextline {dir} {
5641 if {![info exists selectedline]} return
5642 set l [expr {$selectedline + $dir}]
5647 proc selnextpage {dir} {
5648 global canv linespc selectedline numcommits
5650 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5654 allcanvs yview scroll [expr {$dir * $lpp}] units
5656 if {![info exists selectedline]} return
5657 set l [expr {$selectedline + $dir * $lpp}]
5660 } elseif {$l >= $numcommits} {
5661 set l [expr $numcommits - 1]
5667 proc unselectline {} {
5668 global selectedline currentid
5670 catch {unset selectedline}
5671 catch {unset currentid}
5672 allcanvs delete secsel
5676 proc reselectline {} {
5679 if {[info exists selectedline]} {
5680 selectline $selectedline 0
5684 proc addtohistory {cmd} {
5685 global history historyindex curview
5687 set elt [list $curview $cmd]
5688 if {$historyindex > 0
5689 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5693 if {$historyindex < [llength $history]} {
5694 set history [lreplace $history $historyindex end $elt]
5696 lappend history $elt
5699 if {$historyindex > 1} {
5700 .tf.bar.leftbut conf -state normal
5702 .tf.bar.leftbut conf -state disabled
5704 .tf.bar.rightbut conf -state disabled
5710 set view [lindex $elt 0]
5711 set cmd [lindex $elt 1]
5712 if {$curview != $view} {
5719 global history historyindex
5722 if {$historyindex > 1} {
5723 incr historyindex -1
5724 godo [lindex $history [expr {$historyindex - 1}]]
5725 .tf.bar.rightbut conf -state normal
5727 if {$historyindex <= 1} {
5728 .tf.bar.leftbut conf -state disabled
5733 global history historyindex
5736 if {$historyindex < [llength $history]} {
5737 set cmd [lindex $history $historyindex]
5740 .tf.bar.leftbut conf -state normal
5742 if {$historyindex >= [llength $history]} {
5743 .tf.bar.rightbut conf -state disabled
5748 global treefilelist treeidlist diffids diffmergeid treepending
5749 global nullid nullid2
5752 catch {unset diffmergeid}
5753 if {![info exists treefilelist($id)]} {
5754 if {![info exists treepending]} {
5755 if {$id eq $nullid} {
5756 set cmd [list | git ls-files]
5757 } elseif {$id eq $nullid2} {
5758 set cmd [list | git ls-files --stage -t]
5760 set cmd [list | git ls-tree -r $id]
5762 if {[catch {set gtf [open $cmd r]}]} {
5766 set treefilelist($id) {}
5767 set treeidlist($id) {}
5768 fconfigure $gtf -blocking 0
5769 filerun $gtf [list gettreeline $gtf $id]
5776 proc gettreeline {gtf id} {
5777 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5780 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5781 if {$diffids eq $nullid} {
5784 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5785 set i [string first "\t" $line]
5786 if {$i < 0} continue
5787 set sha1 [lindex $line 2]
5788 set fname [string range $line [expr {$i+1}] end]
5789 if {[string index $fname 0] eq "\""} {
5790 set fname [lindex $fname 0]
5792 lappend treeidlist($id) $sha1
5794 lappend treefilelist($id) $fname
5797 return [expr {$nl >= 1000? 2: 1}]
5801 if {$cmitmode ne "tree"} {
5802 if {![info exists diffmergeid]} {
5803 gettreediffs $diffids
5805 } elseif {$id ne $diffids} {
5814 global treefilelist treeidlist diffids nullid nullid2
5815 global ctext commentend
5817 set i [lsearch -exact $treefilelist($diffids) $f]
5819 puts "oops, $f not in list for id $diffids"
5822 if {$diffids eq $nullid} {
5823 if {[catch {set bf [open $f r]} err]} {
5824 puts "oops, can't read $f: $err"
5828 set blob [lindex $treeidlist($diffids) $i]
5829 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5830 puts "oops, error reading blob $blob: $err"
5834 fconfigure $bf -blocking 0
5835 filerun $bf [list getblobline $bf $diffids]
5836 $ctext config -state normal
5837 clear_ctext $commentend
5838 $ctext insert end "\n"
5839 $ctext insert end "$f\n" filesep
5840 $ctext config -state disabled
5841 $ctext yview $commentend
5845 proc getblobline {bf id} {
5846 global diffids cmitmode ctext
5848 if {$id ne $diffids || $cmitmode ne "tree"} {
5852 $ctext config -state normal
5854 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5855 $ctext insert end "$line\n"
5858 # delete last newline
5859 $ctext delete "end - 2c" "end - 1c"
5863 $ctext config -state disabled
5864 return [expr {$nl >= 1000? 2: 1}]
5867 proc mergediff {id} {
5868 global diffmergeid mdifffd
5872 global limitdiffs viewfiles curview
5876 # this doesn't seem to actually affect anything...
5877 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
5878 if {$limitdiffs && $viewfiles($curview) ne {}} {
5879 set cmd [concat $cmd -- $viewfiles($curview)]
5881 if {[catch {set mdf [open $cmd r]} err]} {
5882 error_popup "[mc "Error getting merge diffs:"] $err"
5885 fconfigure $mdf -blocking 0
5886 set mdifffd($id) $mdf
5887 set np [llength $parents($curview,$id)]
5889 filerun $mdf [list getmergediffline $mdf $id $np]
5892 proc getmergediffline {mdf id np} {
5893 global diffmergeid ctext cflist mergemax
5894 global difffilestart mdifffd
5896 $ctext conf -state normal
5898 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5899 if {![info exists diffmergeid] || $id != $diffmergeid
5900 || $mdf != $mdifffd($id)} {
5904 if {[regexp {^diff --cc (.*)} $line match fname]} {
5905 # start of a new file
5906 $ctext insert end "\n"
5907 set here [$ctext index "end - 1c"]
5908 lappend difffilestart $here
5909 add_flist [list $fname]
5910 set l [expr {(78 - [string length $fname]) / 2}]
5911 set pad [string range "----------------------------------------" 1 $l]
5912 $ctext insert end "$pad $fname $pad\n" filesep
5913 } elseif {[regexp {^@@} $line]} {
5914 $ctext insert end "$line\n" hunksep
5915 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5918 # parse the prefix - one ' ', '-' or '+' for each parent
5923 for {set j 0} {$j < $np} {incr j} {
5924 set c [string range $line $j $j]
5927 } elseif {$c == "-"} {
5929 } elseif {$c == "+"} {
5938 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5939 # line doesn't appear in result, parents in $minuses have the line
5940 set num [lindex $minuses 0]
5941 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5942 # line appears in result, parents in $pluses don't have the line
5943 lappend tags mresult
5944 set num [lindex $spaces 0]
5947 if {$num >= $mergemax} {
5952 $ctext insert end "$line\n" $tags
5955 $ctext conf -state disabled
5960 return [expr {$nr >= 1000? 2: 1}]
5963 proc startdiff {ids} {
5964 global treediffs diffids treepending diffmergeid nullid nullid2
5968 catch {unset diffmergeid}
5969 if {![info exists treediffs($ids)] ||
5970 [lsearch -exact $ids $nullid] >= 0 ||
5971 [lsearch -exact $ids $nullid2] >= 0} {
5972 if {![info exists treepending]} {
5980 proc path_filter {filter name} {
5982 set l [string length $p]
5983 if {[string index $p end] eq "/"} {
5984 if {[string compare -length $l $p $name] == 0} {
5988 if {[string compare -length $l $p $name] == 0 &&
5989 ([string length $name] == $l ||
5990 [string index $name $l] eq "/")} {
5998 proc addtocflist {ids} {
6001 add_flist $treediffs($ids)
6005 proc diffcmd {ids flags} {
6006 global nullid nullid2
6008 set i [lsearch -exact $ids $nullid]
6009 set j [lsearch -exact $ids $nullid2]
6011 if {[llength $ids] > 1 && $j < 0} {
6012 # comparing working directory with some specific revision
6013 set cmd [concat | git diff-index $flags]
6015 lappend cmd -R [lindex $ids 1]
6017 lappend cmd [lindex $ids 0]
6020 # comparing working directory with index
6021 set cmd [concat | git diff-files $flags]
6026 } elseif {$j >= 0} {
6027 set cmd [concat | git diff-index --cached $flags]
6028 if {[llength $ids] > 1} {
6029 # comparing index with specific revision
6031 lappend cmd -R [lindex $ids 1]
6033 lappend cmd [lindex $ids 0]
6036 # comparing index with HEAD
6040 set cmd [concat | git diff-tree -r $flags $ids]
6045 proc gettreediffs {ids} {
6046 global treediff treepending
6048 set treepending $ids
6050 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6051 fconfigure $gdtf -blocking 0
6052 filerun $gdtf [list gettreediffline $gdtf $ids]
6055 proc gettreediffline {gdtf ids} {
6056 global treediff treediffs treepending diffids diffmergeid
6057 global cmitmode viewfiles curview limitdiffs
6060 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6061 set i [string first "\t" $line]
6063 set file [string range $line [expr {$i+1}] end]
6064 if {[string index $file 0] eq "\""} {
6065 set file [lindex $file 0]
6067 lappend treediff $file
6071 return [expr {$nr >= 1000? 2: 1}]
6074 if {$limitdiffs && $viewfiles($curview) ne {}} {
6076 foreach f $treediff {
6077 if {[path_filter $viewfiles($curview) $f]} {
6081 set treediffs($ids) $flist
6083 set treediffs($ids) $treediff
6086 if {$cmitmode eq "tree"} {
6088 } elseif {$ids != $diffids} {
6089 if {![info exists diffmergeid]} {
6090 gettreediffs $diffids
6098 # empty string or positive integer
6099 proc diffcontextvalidate {v} {
6100 return [regexp {^(|[1-9][0-9]*)$} $v]
6103 proc diffcontextchange {n1 n2 op} {
6104 global diffcontextstring diffcontext
6106 if {[string is integer -strict $diffcontextstring]} {
6107 if {$diffcontextstring > 0} {
6108 set diffcontext $diffcontextstring
6114 proc changeignorespace {} {
6118 proc getblobdiffs {ids} {
6119 global blobdifffd diffids env
6120 global diffinhdr treediffs
6123 global limitdiffs viewfiles curview
6125 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6129 if {$limitdiffs && $viewfiles($curview) ne {}} {
6130 set cmd [concat $cmd -- $viewfiles($curview)]
6132 if {[catch {set bdf [open $cmd r]} err]} {
6133 puts "error getting diffs: $err"
6137 fconfigure $bdf -blocking 0
6138 set blobdifffd($ids) $bdf
6139 filerun $bdf [list getblobdiffline $bdf $diffids]
6142 proc setinlist {var i val} {
6145 while {[llength [set $var]] < $i} {
6148 if {[llength [set $var]] == $i} {
6155 proc makediffhdr {fname ids} {
6156 global ctext curdiffstart treediffs
6158 set i [lsearch -exact $treediffs($ids) $fname]
6160 setinlist difffilestart $i $curdiffstart
6162 set l [expr {(78 - [string length $fname]) / 2}]
6163 set pad [string range "----------------------------------------" 1 $l]
6164 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6167 proc getblobdiffline {bdf ids} {
6168 global diffids blobdifffd ctext curdiffstart
6169 global diffnexthead diffnextnote difffilestart
6170 global diffinhdr treediffs
6173 $ctext conf -state normal
6174 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6175 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6179 if {![string compare -length 11 "diff --git " $line]} {
6180 # trim off "diff --git "
6181 set line [string range $line 11 end]
6183 # start of a new file
6184 $ctext insert end "\n"
6185 set curdiffstart [$ctext index "end - 1c"]
6186 $ctext insert end "\n" filesep
6187 # If the name hasn't changed the length will be odd,
6188 # the middle char will be a space, and the two bits either
6189 # side will be a/name and b/name, or "a/name" and "b/name".
6190 # If the name has changed we'll get "rename from" and
6191 # "rename to" or "copy from" and "copy to" lines following this,
6192 # and we'll use them to get the filenames.
6193 # This complexity is necessary because spaces in the filename(s)
6194 # don't get escaped.
6195 set l [string length $line]
6196 set i [expr {$l / 2}]
6197 if {!(($l & 1) && [string index $line $i] eq " " &&
6198 [string range $line 2 [expr {$i - 1}]] eq \
6199 [string range $line [expr {$i + 3}] end])} {
6202 # unescape if quoted and chop off the a/ from the front
6203 if {[string index $line 0] eq "\""} {
6204 set fname [string range [lindex $line 0] 2 end]
6206 set fname [string range $line 2 [expr {$i - 1}]]
6208 makediffhdr $fname $ids
6210 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6211 $line match f1l f1c f2l f2c rest]} {
6212 $ctext insert end "$line\n" hunksep
6215 } elseif {$diffinhdr} {
6216 if {![string compare -length 12 "rename from " $line]} {
6217 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6218 if {[string index $fname 0] eq "\""} {
6219 set fname [lindex $fname 0]
6221 set i [lsearch -exact $treediffs($ids) $fname]
6223 setinlist difffilestart $i $curdiffstart
6225 } elseif {![string compare -length 10 $line "rename to "] ||
6226 ![string compare -length 8 $line "copy to "]} {
6227 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6228 if {[string index $fname 0] eq "\""} {
6229 set fname [lindex $fname 0]
6231 makediffhdr $fname $ids
6232 } elseif {[string compare -length 3 $line "---"] == 0} {
6235 } elseif {[string compare -length 3 $line "+++"] == 0} {
6239 $ctext insert end "$line\n" filesep
6242 set x [string range $line 0 0]
6243 if {$x == "-" || $x == "+"} {
6244 set tag [expr {$x == "+"}]
6245 $ctext insert end "$line\n" d$tag
6246 } elseif {$x == " "} {
6247 $ctext insert end "$line\n"
6249 # "\ No newline at end of file",
6250 # or something else we don't recognize
6251 $ctext insert end "$line\n" hunksep
6255 $ctext conf -state disabled
6260 return [expr {$nr >= 1000? 2: 1}]
6263 proc changediffdisp {} {
6264 global ctext diffelide
6266 $ctext tag conf d0 -elide [lindex $diffelide 0]
6267 $ctext tag conf d1 -elide [lindex $diffelide 1]
6271 global difffilestart ctext
6272 set prev [lindex $difffilestart 0]
6273 set here [$ctext index @0,0]
6274 foreach loc $difffilestart {
6275 if {[$ctext compare $loc >= $here]} {
6285 global difffilestart ctext
6286 set here [$ctext index @0,0]
6287 foreach loc $difffilestart {
6288 if {[$ctext compare $loc > $here]} {
6295 proc clear_ctext {{first 1.0}} {
6296 global ctext smarktop smarkbot
6299 set l [lindex [split $first .] 0]
6300 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6303 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6306 $ctext delete $first end
6307 if {$first eq "1.0"} {
6308 catch {unset pendinglinks}
6312 proc settabs {{firstab {}}} {
6313 global firsttabstop tabstop ctext have_tk85
6315 if {$firstab ne {} && $have_tk85} {
6316 set firsttabstop $firstab
6318 set w [font measure textfont "0"]
6319 if {$firsttabstop != 0} {
6320 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6321 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6322 } elseif {$have_tk85 || $tabstop != 8} {
6323 $ctext conf -tabs [expr {$tabstop * $w}]
6325 $ctext conf -tabs {}
6329 proc incrsearch {name ix op} {
6330 global ctext searchstring searchdirn
6332 $ctext tag remove found 1.0 end
6333 if {[catch {$ctext index anchor}]} {
6334 # no anchor set, use start of selection, or of visible area
6335 set sel [$ctext tag ranges sel]
6337 $ctext mark set anchor [lindex $sel 0]
6338 } elseif {$searchdirn eq "-forwards"} {
6339 $ctext mark set anchor @0,0
6341 $ctext mark set anchor @0,[winfo height $ctext]
6344 if {$searchstring ne {}} {
6345 set here [$ctext search $searchdirn -- $searchstring anchor]
6354 global sstring ctext searchstring searchdirn
6357 $sstring icursor end
6358 set searchdirn -forwards
6359 if {$searchstring ne {}} {
6360 set sel [$ctext tag ranges sel]
6362 set start "[lindex $sel 0] + 1c"
6363 } elseif {[catch {set start [$ctext index anchor]}]} {
6366 set match [$ctext search -count mlen -- $searchstring $start]
6367 $ctext tag remove sel 1.0 end
6373 set mend "$match + $mlen c"
6374 $ctext tag add sel $match $mend
6375 $ctext mark unset anchor
6379 proc dosearchback {} {
6380 global sstring ctext searchstring searchdirn
6383 $sstring icursor end
6384 set searchdirn -backwards
6385 if {$searchstring ne {}} {
6386 set sel [$ctext tag ranges sel]
6388 set start [lindex $sel 0]
6389 } elseif {[catch {set start [$ctext index anchor]}]} {
6390 set start @0,[winfo height $ctext]
6392 set match [$ctext search -backwards -count ml -- $searchstring $start]
6393 $ctext tag remove sel 1.0 end
6399 set mend "$match + $ml c"
6400 $ctext tag add sel $match $mend
6401 $ctext mark unset anchor
6405 proc searchmark {first last} {
6406 global ctext searchstring
6410 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6411 if {$match eq {}} break
6412 set mend "$match + $mlen c"
6413 $ctext tag add found $match $mend
6417 proc searchmarkvisible {doall} {
6418 global ctext smarktop smarkbot
6420 set topline [lindex [split [$ctext index @0,0] .] 0]
6421 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6422 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6423 # no overlap with previous
6424 searchmark $topline $botline
6425 set smarktop $topline
6426 set smarkbot $botline
6428 if {$topline < $smarktop} {
6429 searchmark $topline [expr {$smarktop-1}]
6430 set smarktop $topline
6432 if {$botline > $smarkbot} {
6433 searchmark [expr {$smarkbot+1}] $botline
6434 set smarkbot $botline
6439 proc scrolltext {f0 f1} {
6442 .bleft.bottom.sb set $f0 $f1
6443 if {$searchstring ne {}} {
6449 global linespc charspc canvx0 canvy0
6450 global xspc1 xspc2 lthickness
6452 set linespc [font metrics mainfont -linespace]
6453 set charspc [font measure mainfont "m"]
6454 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6455 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6456 set lthickness [expr {int($linespc / 9) + 1}]
6457 set xspc1(0) $linespc
6465 set ymax [lindex [$canv cget -scrollregion] 3]
6466 if {$ymax eq {} || $ymax == 0} return
6467 set span [$canv yview]
6470 allcanvs yview moveto [lindex $span 0]
6472 if {[info exists selectedline]} {
6473 selectline $selectedline 0
6474 allcanvs yview moveto [lindex $span 0]
6478 proc parsefont {f n} {
6481 set fontattr($f,family) [lindex $n 0]
6483 if {$s eq {} || $s == 0} {
6486 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6488 set fontattr($f,size) $s
6489 set fontattr($f,weight) normal
6490 set fontattr($f,slant) roman
6491 foreach style [lrange $n 2 end] {
6494 "bold" {set fontattr($f,weight) $style}
6496 "italic" {set fontattr($f,slant) $style}
6501 proc fontflags {f {isbold 0}} {
6504 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6505 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6506 -slant $fontattr($f,slant)]
6512 set n [list $fontattr($f,family) $fontattr($f,size)]
6513 if {$fontattr($f,weight) eq "bold"} {
6516 if {$fontattr($f,slant) eq "italic"} {
6522 proc incrfont {inc} {
6523 global mainfont textfont ctext canv cflist showrefstop
6524 global stopped entries fontattr
6527 set s $fontattr(mainfont,size)
6532 set fontattr(mainfont,size) $s
6533 font config mainfont -size $s
6534 font config mainfontbold -size $s
6535 set mainfont [fontname mainfont]
6536 set s $fontattr(textfont,size)
6541 set fontattr(textfont,size) $s
6542 font config textfont -size $s
6543 font config textfontbold -size $s
6544 set textfont [fontname textfont]
6551 global sha1entry sha1string
6552 if {[string length $sha1string] == 40} {
6553 $sha1entry delete 0 end
6557 proc sha1change {n1 n2 op} {
6558 global sha1string currentid sha1but
6559 if {$sha1string == {}
6560 || ([info exists currentid] && $sha1string == $currentid)} {
6565 if {[$sha1but cget -state] == $state} return
6566 if {$state == "normal"} {
6567 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6569 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6573 proc gotocommit {} {
6574 global sha1string tagids headids curview varcid
6576 if {$sha1string == {}
6577 || ([info exists currentid] && $sha1string == $currentid)} return
6578 if {[info exists tagids($sha1string)]} {
6579 set id $tagids($sha1string)
6580 } elseif {[info exists headids($sha1string)]} {
6581 set id $headids($sha1string)
6583 set id [string tolower $sha1string]
6584 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6585 set matches [array names varcid "$curview,$id*"]
6586 if {$matches ne {}} {
6587 if {[llength $matches] > 1} {
6588 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6591 set id [lindex [split [lindex $matches 0] ","] 1]
6595 if {[commitinview $id $curview]} {
6596 selectline [rowofcommit $id] 1
6599 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6600 set msg [mc "SHA1 id %s is not known" $sha1string]
6602 set msg [mc "Tag/Head %s is not known" $sha1string]
6607 proc lineenter {x y id} {
6608 global hoverx hovery hoverid hovertimer
6609 global commitinfo canv
6611 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6615 if {[info exists hovertimer]} {
6616 after cancel $hovertimer
6618 set hovertimer [after 500 linehover]
6622 proc linemotion {x y id} {
6623 global hoverx hovery hoverid hovertimer
6625 if {[info exists hoverid] && $id == $hoverid} {
6628 if {[info exists hovertimer]} {
6629 after cancel $hovertimer
6631 set hovertimer [after 500 linehover]
6635 proc lineleave {id} {
6636 global hoverid hovertimer canv
6638 if {[info exists hoverid] && $id == $hoverid} {
6640 if {[info exists hovertimer]} {
6641 after cancel $hovertimer
6649 global hoverx hovery hoverid hovertimer
6650 global canv linespc lthickness
6653 set text [lindex $commitinfo($hoverid) 0]
6654 set ymax [lindex [$canv cget -scrollregion] 3]
6655 if {$ymax == {}} return
6656 set yfrac [lindex [$canv yview] 0]
6657 set x [expr {$hoverx + 2 * $linespc}]
6658 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6659 set x0 [expr {$x - 2 * $lthickness}]
6660 set y0 [expr {$y - 2 * $lthickness}]
6661 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6662 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6663 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6664 -fill \#ffff80 -outline black -width 1 -tags hover]
6666 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6671 proc clickisonarrow {id y} {
6674 set ranges [rowranges $id]
6675 set thresh [expr {2 * $lthickness + 6}]
6676 set n [expr {[llength $ranges] - 1}]
6677 for {set i 1} {$i < $n} {incr i} {
6678 set row [lindex $ranges $i]
6679 if {abs([yc $row] - $y) < $thresh} {
6686 proc arrowjump {id n y} {
6689 # 1 <-> 2, 3 <-> 4, etc...
6690 set n [expr {(($n - 1) ^ 1) + 1}]
6691 set row [lindex [rowranges $id] $n]
6693 set ymax [lindex [$canv cget -scrollregion] 3]
6694 if {$ymax eq {} || $ymax <= 0} return
6695 set view [$canv yview]
6696 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6697 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6701 allcanvs yview moveto $yfrac
6704 proc lineclick {x y id isnew} {
6705 global ctext commitinfo children canv thickerline curview
6707 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6712 # draw this line thicker than normal
6716 set ymax [lindex [$canv cget -scrollregion] 3]
6717 if {$ymax eq {}} return
6718 set yfrac [lindex [$canv yview] 0]
6719 set y [expr {$y + $yfrac * $ymax}]
6721 set dirn [clickisonarrow $id $y]
6723 arrowjump $id $dirn $y
6728 addtohistory [list lineclick $x $y $id 0]
6730 # fill the details pane with info about this line
6731 $ctext conf -state normal
6734 $ctext insert end "[mc "Parent"]:\t"
6735 $ctext insert end $id link0
6737 set info $commitinfo($id)
6738 $ctext insert end "\n\t[lindex $info 0]\n"
6739 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
6740 set date [formatdate [lindex $info 2]]
6741 $ctext insert end "\t[mc "Date"]:\t$date\n"
6742 set kids $children($curview,$id)
6744 $ctext insert end "\n[mc "Children"]:"
6746 foreach child $kids {
6748 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6749 set info $commitinfo($child)
6750 $ctext insert end "\n\t"
6751 $ctext insert end $child link$i
6752 setlink $child link$i
6753 $ctext insert end "\n\t[lindex $info 0]"
6754 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
6755 set date [formatdate [lindex $info 2]]
6756 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
6759 $ctext conf -state disabled
6763 proc normalline {} {
6765 if {[info exists thickerline]} {
6774 if {[commitinview $id $curview]} {
6775 selectline [rowofcommit $id] 1
6781 if {![info exists startmstime]} {
6782 set startmstime [clock clicks -milliseconds]
6784 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6787 proc rowmenu {x y id} {
6788 global rowctxmenu selectedline rowmenuid curview
6789 global nullid nullid2 fakerowmenu mainhead
6793 if {![info exists selectedline]
6794 || [rowofcommit $id] eq $selectedline} {
6799 if {$id ne $nullid && $id ne $nullid2} {
6800 set menu $rowctxmenu
6801 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6803 set menu $fakerowmenu
6805 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6806 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6807 $menu entryconfigure [mc "Make patch"] -state $state
6808 tk_popup $menu $x $y
6811 proc diffvssel {dirn} {
6812 global rowmenuid selectedline
6814 if {![info exists selectedline]} return
6816 set oldid [commitonrow $selectedline]
6817 set newid $rowmenuid
6819 set oldid $rowmenuid
6820 set newid [commitonrow $selectedline]
6822 addtohistory [list doseldiff $oldid $newid]
6823 doseldiff $oldid $newid
6826 proc doseldiff {oldid newid} {
6830 $ctext conf -state normal
6832 init_flist [mc "Top"]
6833 $ctext insert end "[mc "From"] "
6834 $ctext insert end $oldid link0
6835 setlink $oldid link0
6836 $ctext insert end "\n "
6837 $ctext insert end [lindex $commitinfo($oldid) 0]
6838 $ctext insert end "\n\n[mc "To"] "
6839 $ctext insert end $newid link1
6840 setlink $newid link1
6841 $ctext insert end "\n "
6842 $ctext insert end [lindex $commitinfo($newid) 0]
6843 $ctext insert end "\n"
6844 $ctext conf -state disabled
6845 $ctext tag remove found 1.0 end
6846 startdiff [list $oldid $newid]
6850 global rowmenuid currentid commitinfo patchtop patchnum
6852 if {![info exists currentid]} return
6853 set oldid $currentid
6854 set oldhead [lindex $commitinfo($oldid) 0]
6855 set newid $rowmenuid
6856 set newhead [lindex $commitinfo($newid) 0]
6859 catch {destroy $top}
6861 label $top.title -text [mc "Generate patch"]
6862 grid $top.title - -pady 10
6863 label $top.from -text [mc "From:"]
6864 entry $top.fromsha1 -width 40 -relief flat
6865 $top.fromsha1 insert 0 $oldid
6866 $top.fromsha1 conf -state readonly
6867 grid $top.from $top.fromsha1 -sticky w
6868 entry $top.fromhead -width 60 -relief flat
6869 $top.fromhead insert 0 $oldhead
6870 $top.fromhead conf -state readonly
6871 grid x $top.fromhead -sticky w
6872 label $top.to -text [mc "To:"]
6873 entry $top.tosha1 -width 40 -relief flat
6874 $top.tosha1 insert 0 $newid
6875 $top.tosha1 conf -state readonly
6876 grid $top.to $top.tosha1 -sticky w
6877 entry $top.tohead -width 60 -relief flat
6878 $top.tohead insert 0 $newhead
6879 $top.tohead conf -state readonly
6880 grid x $top.tohead -sticky w
6881 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6882 grid $top.rev x -pady 10
6883 label $top.flab -text [mc "Output file:"]
6884 entry $top.fname -width 60
6885 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6887 grid $top.flab $top.fname -sticky w
6889 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6890 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6891 grid $top.buts.gen $top.buts.can
6892 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6893 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6894 grid $top.buts - -pady 10 -sticky ew
6898 proc mkpatchrev {} {
6901 set oldid [$patchtop.fromsha1 get]
6902 set oldhead [$patchtop.fromhead get]
6903 set newid [$patchtop.tosha1 get]
6904 set newhead [$patchtop.tohead get]
6905 foreach e [list fromsha1 fromhead tosha1 tohead] \
6906 v [list $newid $newhead $oldid $oldhead] {
6907 $patchtop.$e conf -state normal
6908 $patchtop.$e delete 0 end
6909 $patchtop.$e insert 0 $v
6910 $patchtop.$e conf -state readonly
6915 global patchtop nullid nullid2
6917 set oldid [$patchtop.fromsha1 get]
6918 set newid [$patchtop.tosha1 get]
6919 set fname [$patchtop.fname get]
6920 set cmd [diffcmd [list $oldid $newid] -p]
6921 # trim off the initial "|"
6922 set cmd [lrange $cmd 1 end]
6923 lappend cmd >$fname &
6924 if {[catch {eval exec $cmd} err]} {
6925 error_popup "[mc "Error creating patch:"] $err"
6927 catch {destroy $patchtop}
6931 proc mkpatchcan {} {
6934 catch {destroy $patchtop}
6939 global rowmenuid mktagtop commitinfo
6943 catch {destroy $top}
6945 label $top.title -text [mc "Create tag"]
6946 grid $top.title - -pady 10
6947 label $top.id -text [mc "ID:"]
6948 entry $top.sha1 -width 40 -relief flat
6949 $top.sha1 insert 0 $rowmenuid
6950 $top.sha1 conf -state readonly
6951 grid $top.id $top.sha1 -sticky w
6952 entry $top.head -width 60 -relief flat
6953 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6954 $top.head conf -state readonly
6955 grid x $top.head -sticky w
6956 label $top.tlab -text [mc "Tag name:"]
6957 entry $top.tag -width 60
6958 grid $top.tlab $top.tag -sticky w
6960 button $top.buts.gen -text [mc "Create"] -command mktaggo
6961 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6962 grid $top.buts.gen $top.buts.can
6963 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6964 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6965 grid $top.buts - -pady 10 -sticky ew
6970 global mktagtop env tagids idtags
6972 set id [$mktagtop.sha1 get]
6973 set tag [$mktagtop.tag get]
6975 error_popup [mc "No tag name specified"]
6978 if {[info exists tagids($tag)]} {
6979 error_popup [mc "Tag \"%s\" already exists" $tag]
6983 exec git tag $tag $id
6985 error_popup "[mc "Error creating tag:"] $err"
6989 set tagids($tag) $id
6990 lappend idtags($id) $tag
6997 proc redrawtags {id} {
6998 global canv linehtag idpos currentid curview
6999 global canvxmax iddrawn
7001 if {![commitinview $id $curview]} return
7002 if {![info exists iddrawn($id)]} return
7003 set row [rowofcommit $id]
7004 $canv delete tag.$id
7005 set xt [eval drawtags $id $idpos($id)]
7006 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7007 set text [$canv itemcget $linehtag($row) -text]
7008 set font [$canv itemcget $linehtag($row) -font]
7009 set xr [expr {$xt + [font measure $font $text]}]
7010 if {$xr > $canvxmax} {
7014 if {[info exists currentid] && $currentid == $id} {
7022 catch {destroy $mktagtop}
7031 proc writecommit {} {
7032 global rowmenuid wrcomtop commitinfo wrcomcmd
7034 set top .writecommit
7036 catch {destroy $top}
7038 label $top.title -text [mc "Write commit to file"]
7039 grid $top.title - -pady 10
7040 label $top.id -text [mc "ID:"]
7041 entry $top.sha1 -width 40 -relief flat
7042 $top.sha1 insert 0 $rowmenuid
7043 $top.sha1 conf -state readonly
7044 grid $top.id $top.sha1 -sticky w
7045 entry $top.head -width 60 -relief flat
7046 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7047 $top.head conf -state readonly
7048 grid x $top.head -sticky w
7049 label $top.clab -text [mc "Command:"]
7050 entry $top.cmd -width 60 -textvariable wrcomcmd
7051 grid $top.clab $top.cmd -sticky w -pady 10
7052 label $top.flab -text [mc "Output file:"]
7053 entry $top.fname -width 60
7054 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7055 grid $top.flab $top.fname -sticky w
7057 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7058 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7059 grid $top.buts.gen $top.buts.can
7060 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7061 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7062 grid $top.buts - -pady 10 -sticky ew
7069 set id [$wrcomtop.sha1 get]
7070 set cmd "echo $id | [$wrcomtop.cmd get]"
7071 set fname [$wrcomtop.fname get]
7072 if {[catch {exec sh -c $cmd >$fname &} err]} {
7073 error_popup "[mc "Error writing commit:"] $err"
7075 catch {destroy $wrcomtop}
7082 catch {destroy $wrcomtop}
7087 global rowmenuid mkbrtop
7090 catch {destroy $top}
7092 label $top.title -text [mc "Create new branch"]
7093 grid $top.title - -pady 10
7094 label $top.id -text [mc "ID:"]
7095 entry $top.sha1 -width 40 -relief flat
7096 $top.sha1 insert 0 $rowmenuid
7097 $top.sha1 conf -state readonly
7098 grid $top.id $top.sha1 -sticky w
7099 label $top.nlab -text [mc "Name:"]
7100 entry $top.name -width 40
7101 grid $top.nlab $top.name -sticky w
7103 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7104 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7105 grid $top.buts.go $top.buts.can
7106 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7107 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7108 grid $top.buts - -pady 10 -sticky ew
7113 global headids idheads
7115 set name [$top.name get]
7116 set id [$top.sha1 get]
7118 error_popup [mc "Please specify a name for the new branch"]
7121 catch {destroy $top}
7125 exec git branch $name $id
7130 set headids($name) $id
7131 lappend idheads($id) $name
7140 proc cherrypick {} {
7141 global rowmenuid curview
7142 global mainhead mainheadid
7144 set oldhead [exec git rev-parse HEAD]
7145 set dheads [descheads $rowmenuid]
7146 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7147 set ok [confirm_popup [mc "Commit %s is already\
7148 included in branch %s -- really re-apply it?" \
7149 [string range $rowmenuid 0 7] $mainhead]]
7152 nowbusy cherrypick [mc "Cherry-picking"]
7154 # Unfortunately git-cherry-pick writes stuff to stderr even when
7155 # no error occurs, and exec takes that as an indication of error...
7156 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7161 set newhead [exec git rev-parse HEAD]
7162 if {$newhead eq $oldhead} {
7164 error_popup [mc "No changes committed"]
7167 addnewchild $newhead $oldhead
7168 if {[commitinview $oldhead $curview]} {
7169 insertrow $newhead $oldhead $curview
7170 if {$mainhead ne {}} {
7171 movehead $newhead $mainhead
7172 movedhead $newhead $mainhead
7173 set mainheadid $newhead
7183 global mainhead rowmenuid confirm_ok resettype
7186 set w ".confirmreset"
7189 wm title $w [mc "Confirm reset"]
7190 message $w.m -text \
7191 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7192 -justify center -aspect 1000
7193 pack $w.m -side top -fill x -padx 20 -pady 20
7194 frame $w.f -relief sunken -border 2
7195 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7196 grid $w.f.rt -sticky w
7198 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7199 -text [mc "Soft: Leave working tree and index untouched"]
7200 grid $w.f.soft -sticky w
7201 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7202 -text [mc "Mixed: Leave working tree untouched, reset index"]
7203 grid $w.f.mixed -sticky w
7204 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7205 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7206 grid $w.f.hard -sticky w
7207 pack $w.f -side top -fill x
7208 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7209 pack $w.ok -side left -fill x -padx 20 -pady 20
7210 button $w.cancel -text [mc Cancel] -command "destroy $w"
7211 pack $w.cancel -side right -fill x -padx 20 -pady 20
7212 bind $w <Visibility> "grab $w; focus $w"
7214 if {!$confirm_ok} return
7215 if {[catch {set fd [open \
7216 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
7220 filerun $fd [list readresetstat $fd]
7221 nowbusy reset [mc "Resetting"]
7226 proc readresetstat {fd} {
7227 global mainhead mainheadid showlocalchanges rprogcoord
7229 if {[gets $fd line] >= 0} {
7230 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7231 set rprogcoord [expr {1.0 * $m / $n}]
7239 if {[catch {close $fd} err]} {
7242 set oldhead $mainheadid
7243 set newhead [exec git rev-parse HEAD]
7244 if {$newhead ne $oldhead} {
7245 movehead $newhead $mainhead
7246 movedhead $newhead $mainhead
7247 set mainheadid $newhead
7251 if {$showlocalchanges} {
7257 # context menu for a head
7258 proc headmenu {x y id head} {
7259 global headmenuid headmenuhead headctxmenu mainhead
7263 set headmenuhead $head
7265 if {$head eq $mainhead} {
7268 $headctxmenu entryconfigure 0 -state $state
7269 $headctxmenu entryconfigure 1 -state $state
7270 tk_popup $headctxmenu $x $y
7274 global headmenuid headmenuhead mainhead headids
7275 global showlocalchanges mainheadid
7277 # check the tree is clean first??
7278 set oldmainhead $mainhead
7279 nowbusy checkout [mc "Checking out"]
7283 exec git checkout -q $headmenuhead
7289 set mainhead $headmenuhead
7290 set mainheadid $headmenuid
7291 if {[info exists headids($oldmainhead)]} {
7292 redrawtags $headids($oldmainhead)
7294 redrawtags $headmenuid
7297 if {$showlocalchanges} {
7303 global headmenuid headmenuhead mainhead
7306 set head $headmenuhead
7308 # this check shouldn't be needed any more...
7309 if {$head eq $mainhead} {
7310 error_popup [mc "Cannot delete the currently checked-out branch"]
7313 set dheads [descheads $id]
7314 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7315 # the stuff on this branch isn't on any other branch
7316 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7317 branch.\nReally delete branch %s?" $head $head]]} return
7321 if {[catch {exec git branch -D $head} err]} {
7326 removehead $id $head
7327 removedhead $id $head
7334 # Display a list of tags and heads
7336 global showrefstop bgcolor fgcolor selectbgcolor
7337 global bglist fglist reflistfilter reflist maincursor
7340 set showrefstop $top
7341 if {[winfo exists $top]} {
7347 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7348 text $top.list -background $bgcolor -foreground $fgcolor \
7349 -selectbackground $selectbgcolor -font mainfont \
7350 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7351 -width 30 -height 20 -cursor $maincursor \
7352 -spacing1 1 -spacing3 1 -state disabled
7353 $top.list tag configure highlight -background $selectbgcolor
7354 lappend bglist $top.list
7355 lappend fglist $top.list
7356 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7357 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7358 grid $top.list $top.ysb -sticky nsew
7359 grid $top.xsb x -sticky ew
7361 label $top.f.l -text "[mc "Filter"]: "
7362 entry $top.f.e -width 20 -textvariable reflistfilter
7363 set reflistfilter "*"
7364 trace add variable reflistfilter write reflistfilter_change
7365 pack $top.f.e -side right -fill x -expand 1
7366 pack $top.f.l -side left
7367 grid $top.f - -sticky ew -pady 2
7368 button $top.close -command [list destroy $top] -text [mc "Close"]
7370 grid columnconfigure $top 0 -weight 1
7371 grid rowconfigure $top 0 -weight 1
7372 bind $top.list <1> {break}
7373 bind $top.list <B1-Motion> {break}
7374 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7379 proc sel_reflist {w x y} {
7380 global showrefstop reflist headids tagids otherrefids
7382 if {![winfo exists $showrefstop]} return
7383 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7384 set ref [lindex $reflist [expr {$l-1}]]
7385 set n [lindex $ref 0]
7386 switch -- [lindex $ref 1] {
7387 "H" {selbyid $headids($n)}
7388 "T" {selbyid $tagids($n)}
7389 "o" {selbyid $otherrefids($n)}
7391 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7394 proc unsel_reflist {} {
7397 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7398 $showrefstop.list tag remove highlight 0.0 end
7401 proc reflistfilter_change {n1 n2 op} {
7402 global reflistfilter
7404 after cancel refill_reflist
7405 after 200 refill_reflist
7408 proc refill_reflist {} {
7409 global reflist reflistfilter showrefstop headids tagids otherrefids
7410 global curview commitinterest
7412 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7414 foreach n [array names headids] {
7415 if {[string match $reflistfilter $n]} {
7416 if {[commitinview $headids($n) $curview]} {
7417 lappend refs [list $n H]
7419 set commitinterest($headids($n)) {run refill_reflist}
7423 foreach n [array names tagids] {
7424 if {[string match $reflistfilter $n]} {
7425 if {[commitinview $tagids($n) $curview]} {
7426 lappend refs [list $n T]
7428 set commitinterest($tagids($n)) {run refill_reflist}
7432 foreach n [array names otherrefids] {
7433 if {[string match $reflistfilter $n]} {
7434 if {[commitinview $otherrefids($n) $curview]} {
7435 lappend refs [list $n o]
7437 set commitinterest($otherrefids($n)) {run refill_reflist}
7441 set refs [lsort -index 0 $refs]
7442 if {$refs eq $reflist} return
7444 # Update the contents of $showrefstop.list according to the
7445 # differences between $reflist (old) and $refs (new)
7446 $showrefstop.list conf -state normal
7447 $showrefstop.list insert end "\n"
7450 while {$i < [llength $reflist] || $j < [llength $refs]} {
7451 if {$i < [llength $reflist]} {
7452 if {$j < [llength $refs]} {
7453 set cmp [string compare [lindex $reflist $i 0] \
7454 [lindex $refs $j 0]]
7456 set cmp [string compare [lindex $reflist $i 1] \
7457 [lindex $refs $j 1]]
7467 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7475 set l [expr {$j + 1}]
7476 $showrefstop.list image create $l.0 -align baseline \
7477 -image reficon-[lindex $refs $j 1] -padx 2
7478 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7484 # delete last newline
7485 $showrefstop.list delete end-2c end-1c
7486 $showrefstop.list conf -state disabled
7489 # Stuff for finding nearby tags
7490 proc getallcommits {} {
7491 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7492 global idheads idtags idotherrefs allparents tagobjid
7494 if {![info exists allcommits]} {
7500 set allccache [file join [gitdir] "gitk.cache"]
7502 set f [open $allccache r]
7511 set cmd [list | git rev-list --parents]
7512 set allcupdate [expr {$seeds ne {}}]
7516 set refs [concat [array names idheads] [array names idtags] \
7517 [array names idotherrefs]]
7520 foreach name [array names tagobjid] {
7521 lappend tagobjs $tagobjid($name)
7523 foreach id [lsort -unique $refs] {
7524 if {![info exists allparents($id)] &&
7525 [lsearch -exact $tagobjs $id] < 0} {
7536 set fd [open [concat $cmd $ids] r]
7537 fconfigure $fd -blocking 0
7540 filerun $fd [list getallclines $fd]
7546 # Since most commits have 1 parent and 1 child, we group strings of
7547 # such commits into "arcs" joining branch/merge points (BMPs), which
7548 # are commits that either don't have 1 parent or don't have 1 child.
7550 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7551 # arcout(id) - outgoing arcs for BMP
7552 # arcids(a) - list of IDs on arc including end but not start
7553 # arcstart(a) - BMP ID at start of arc
7554 # arcend(a) - BMP ID at end of arc
7555 # growing(a) - arc a is still growing
7556 # arctags(a) - IDs out of arcids (excluding end) that have tags
7557 # archeads(a) - IDs out of arcids (excluding end) that have heads
7558 # The start of an arc is at the descendent end, so "incoming" means
7559 # coming from descendents, and "outgoing" means going towards ancestors.
7561 proc getallclines {fd} {
7562 global allparents allchildren idtags idheads nextarc
7563 global arcnos arcids arctags arcout arcend arcstart archeads growing
7564 global seeds allcommits cachedarcs allcupdate
7567 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7568 set id [lindex $line 0]
7569 if {[info exists allparents($id)]} {
7574 set olds [lrange $line 1 end]
7575 set allparents($id) $olds
7576 if {![info exists allchildren($id)]} {
7577 set allchildren($id) {}
7582 if {[llength $olds] == 1 && [llength $a] == 1} {
7583 lappend arcids($a) $id
7584 if {[info exists idtags($id)]} {
7585 lappend arctags($a) $id
7587 if {[info exists idheads($id)]} {
7588 lappend archeads($a) $id
7590 if {[info exists allparents($olds)]} {
7591 # seen parent already
7592 if {![info exists arcout($olds)]} {
7595 lappend arcids($a) $olds
7596 set arcend($a) $olds
7599 lappend allchildren($olds) $id
7600 lappend arcnos($olds) $a
7604 foreach a $arcnos($id) {
7605 lappend arcids($a) $id
7612 lappend allchildren($p) $id
7613 set a [incr nextarc]
7614 set arcstart($a) $id
7621 if {[info exists allparents($p)]} {
7622 # seen it already, may need to make a new branch
7623 if {![info exists arcout($p)]} {
7626 lappend arcids($a) $p
7630 lappend arcnos($p) $a
7635 global cached_dheads cached_dtags cached_atags
7636 catch {unset cached_dheads}
7637 catch {unset cached_dtags}
7638 catch {unset cached_atags}
7641 return [expr {$nid >= 1000? 2: 1}]
7645 fconfigure $fd -blocking 1
7648 # got an error reading the list of commits
7649 # if we were updating, try rereading the whole thing again
7655 error_popup "[mc "Error reading commit topology information;\
7656 branch and preceding/following tag information\
7657 will be incomplete."]\n($err)"
7660 if {[incr allcommits -1] == 0} {
7670 proc recalcarc {a} {
7671 global arctags archeads arcids idtags idheads
7675 foreach id [lrange $arcids($a) 0 end-1] {
7676 if {[info exists idtags($id)]} {
7679 if {[info exists idheads($id)]} {
7684 set archeads($a) $ah
7688 global arcnos arcids nextarc arctags archeads idtags idheads
7689 global arcstart arcend arcout allparents growing
7692 if {[llength $a] != 1} {
7693 puts "oops splitarc called but [llength $a] arcs already"
7697 set i [lsearch -exact $arcids($a) $p]
7699 puts "oops splitarc $p not in arc $a"
7702 set na [incr nextarc]
7703 if {[info exists arcend($a)]} {
7704 set arcend($na) $arcend($a)
7706 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7707 set j [lsearch -exact $arcnos($l) $a]
7708 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7710 set tail [lrange $arcids($a) [expr {$i+1}] end]
7711 set arcids($a) [lrange $arcids($a) 0 $i]
7713 set arcstart($na) $p
7715 set arcids($na) $tail
7716 if {[info exists growing($a)]} {
7722 if {[llength $arcnos($id)] == 1} {
7725 set j [lsearch -exact $arcnos($id) $a]
7726 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7730 # reconstruct tags and heads lists
7731 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7736 set archeads($na) {}
7740 # Update things for a new commit added that is a child of one
7741 # existing commit. Used when cherry-picking.
7742 proc addnewchild {id p} {
7743 global allparents allchildren idtags nextarc
7744 global arcnos arcids arctags arcout arcend arcstart archeads growing
7745 global seeds allcommits
7747 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7748 set allparents($id) [list $p]
7749 set allchildren($id) {}
7752 lappend allchildren($p) $id
7753 set a [incr nextarc]
7754 set arcstart($a) $id
7757 set arcids($a) [list $p]
7759 if {![info exists arcout($p)]} {
7762 lappend arcnos($p) $a
7763 set arcout($id) [list $a]
7766 # This implements a cache for the topology information.
7767 # The cache saves, for each arc, the start and end of the arc,
7768 # the ids on the arc, and the outgoing arcs from the end.
7769 proc readcache {f} {
7770 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7771 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7776 if {$lim - $a > 500} {
7777 set lim [expr {$a + 500}]
7781 # finish reading the cache and setting up arctags, etc.
7783 if {$line ne "1"} {error "bad final version"}
7785 foreach id [array names idtags] {
7786 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7787 [llength $allparents($id)] == 1} {
7788 set a [lindex $arcnos($id) 0]
7789 if {$arctags($a) eq {}} {
7794 foreach id [array names idheads] {
7795 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7796 [llength $allparents($id)] == 1} {
7797 set a [lindex $arcnos($id) 0]
7798 if {$archeads($a) eq {}} {
7803 foreach id [lsort -unique $possible_seeds] {
7804 if {$arcnos($id) eq {}} {
7810 while {[incr a] <= $lim} {
7812 if {[llength $line] != 3} {error "bad line"}
7813 set s [lindex $line 0]
7815 lappend arcout($s) $a
7816 if {![info exists arcnos($s)]} {
7817 lappend possible_seeds $s
7820 set e [lindex $line 1]
7825 if {![info exists arcout($e)]} {
7829 set arcids($a) [lindex $line 2]
7830 foreach id $arcids($a) {
7831 lappend allparents($s) $id
7833 lappend arcnos($id) $a
7835 if {![info exists allparents($s)]} {
7836 set allparents($s) {}
7841 set nextarc [expr {$a - 1}]
7854 global nextarc cachedarcs possible_seeds
7858 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7859 # make sure it's an integer
7860 set cachedarcs [expr {int([lindex $line 1])}]
7861 if {$cachedarcs < 0} {error "bad number of arcs"}
7863 set possible_seeds {}
7871 proc dropcache {err} {
7872 global allcwait nextarc cachedarcs seeds
7874 #puts "dropping cache ($err)"
7875 foreach v {arcnos arcout arcids arcstart arcend growing \
7876 arctags archeads allparents allchildren} {
7887 proc writecache {f} {
7888 global cachearc cachedarcs allccache
7889 global arcstart arcend arcnos arcids arcout
7893 if {$lim - $a > 1000} {
7894 set lim [expr {$a + 1000}]
7897 while {[incr a] <= $lim} {
7898 if {[info exists arcend($a)]} {
7899 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7901 puts $f [list $arcstart($a) {} $arcids($a)]
7906 catch {file delete $allccache}
7907 #puts "writing cache failed ($err)"
7910 set cachearc [expr {$a - 1}]
7911 if {$a > $cachedarcs} {
7920 global nextarc cachedarcs cachearc allccache
7922 if {$nextarc == $cachedarcs} return
7924 set cachedarcs $nextarc
7926 set f [open $allccache w]
7927 puts $f [list 1 $cachedarcs]
7932 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7933 # or 0 if neither is true.
7934 proc anc_or_desc {a b} {
7935 global arcout arcstart arcend arcnos cached_isanc
7937 if {$arcnos($a) eq $arcnos($b)} {
7938 # Both are on the same arc(s); either both are the same BMP,
7939 # or if one is not a BMP, the other is also not a BMP or is
7940 # the BMP at end of the arc (and it only has 1 incoming arc).
7941 # Or both can be BMPs with no incoming arcs.
7942 if {$a eq $b || $arcnos($a) eq {}} {
7945 # assert {[llength $arcnos($a)] == 1}
7946 set arc [lindex $arcnos($a) 0]
7947 set i [lsearch -exact $arcids($arc) $a]
7948 set j [lsearch -exact $arcids($arc) $b]
7949 if {$i < 0 || $i > $j} {
7956 if {![info exists arcout($a)]} {
7957 set arc [lindex $arcnos($a) 0]
7958 if {[info exists arcend($arc)]} {
7959 set aend $arcend($arc)
7963 set a $arcstart($arc)
7967 if {![info exists arcout($b)]} {
7968 set arc [lindex $arcnos($b) 0]
7969 if {[info exists arcend($arc)]} {
7970 set bend $arcend($arc)
7974 set b $arcstart($arc)
7984 if {[info exists cached_isanc($a,$bend)]} {
7985 if {$cached_isanc($a,$bend)} {
7989 if {[info exists cached_isanc($b,$aend)]} {
7990 if {$cached_isanc($b,$aend)} {
7993 if {[info exists cached_isanc($a,$bend)]} {
7998 set todo [list $a $b]
8001 for {set i 0} {$i < [llength $todo]} {incr i} {
8002 set x [lindex $todo $i]
8003 if {$anc($x) eq {}} {
8006 foreach arc $arcnos($x) {
8007 set xd $arcstart($arc)
8009 set cached_isanc($a,$bend) 1
8010 set cached_isanc($b,$aend) 0
8012 } elseif {$xd eq $aend} {
8013 set cached_isanc($b,$aend) 1
8014 set cached_isanc($a,$bend) 0
8017 if {![info exists anc($xd)]} {
8018 set anc($xd) $anc($x)
8020 } elseif {$anc($xd) ne $anc($x)} {
8025 set cached_isanc($a,$bend) 0
8026 set cached_isanc($b,$aend) 0
8030 # This identifies whether $desc has an ancestor that is
8031 # a growing tip of the graph and which is not an ancestor of $anc
8032 # and returns 0 if so and 1 if not.
8033 # If we subsequently discover a tag on such a growing tip, and that
8034 # turns out to be a descendent of $anc (which it could, since we
8035 # don't necessarily see children before parents), then $desc
8036 # isn't a good choice to display as a descendent tag of
8037 # $anc (since it is the descendent of another tag which is
8038 # a descendent of $anc). Similarly, $anc isn't a good choice to
8039 # display as a ancestor tag of $desc.
8041 proc is_certain {desc anc} {
8042 global arcnos arcout arcstart arcend growing problems
8045 if {[llength $arcnos($anc)] == 1} {
8046 # tags on the same arc are certain
8047 if {$arcnos($desc) eq $arcnos($anc)} {
8050 if {![info exists arcout($anc)]} {
8051 # if $anc is partway along an arc, use the start of the arc instead
8052 set a [lindex $arcnos($anc) 0]
8053 set anc $arcstart($a)
8056 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8059 set a [lindex $arcnos($desc) 0]
8065 set anclist [list $x]
8069 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8070 set x [lindex $anclist $i]
8075 foreach a $arcout($x) {
8076 if {[info exists growing($a)]} {
8077 if {![info exists growanc($x)] && $dl($x)} {
8083 if {[info exists dl($y)]} {
8087 if {![info exists done($y)]} {
8090 if {[info exists growanc($x)]} {
8094 for {set k 0} {$k < [llength $xl]} {incr k} {
8095 set z [lindex $xl $k]
8096 foreach c $arcout($z) {
8097 if {[info exists arcend($c)]} {
8099 if {[info exists dl($v)] && $dl($v)} {
8101 if {![info exists done($v)]} {
8104 if {[info exists growanc($v)]} {
8114 } elseif {$y eq $anc || !$dl($x)} {
8125 foreach x [array names growanc] {
8134 proc validate_arctags {a} {
8135 global arctags idtags
8139 foreach id $arctags($a) {
8141 if {![info exists idtags($id)]} {
8142 set na [lreplace $na $i $i]
8149 proc validate_archeads {a} {
8150 global archeads idheads
8153 set na $archeads($a)
8154 foreach id $archeads($a) {
8156 if {![info exists idheads($id)]} {
8157 set na [lreplace $na $i $i]
8161 set archeads($a) $na
8164 # Return the list of IDs that have tags that are descendents of id,
8165 # ignoring IDs that are descendents of IDs already reported.
8166 proc desctags {id} {
8167 global arcnos arcstart arcids arctags idtags allparents
8168 global growing cached_dtags
8170 if {![info exists allparents($id)]} {
8173 set t1 [clock clicks -milliseconds]
8175 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8176 # part-way along an arc; check that arc first
8177 set a [lindex $arcnos($id) 0]
8178 if {$arctags($a) ne {}} {
8180 set i [lsearch -exact $arcids($a) $id]
8182 foreach t $arctags($a) {
8183 set j [lsearch -exact $arcids($a) $t]
8191 set id $arcstart($a)
8192 if {[info exists idtags($id)]} {
8196 if {[info exists cached_dtags($id)]} {
8197 return $cached_dtags($id)
8204 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8205 set id [lindex $todo $i]
8207 set ta [info exists hastaggedancestor($id)]
8211 # ignore tags on starting node
8212 if {!$ta && $i > 0} {
8213 if {[info exists idtags($id)]} {
8216 } elseif {[info exists cached_dtags($id)]} {
8217 set tagloc($id) $cached_dtags($id)
8221 foreach a $arcnos($id) {
8223 if {!$ta && $arctags($a) ne {}} {
8225 if {$arctags($a) ne {}} {
8226 lappend tagloc($id) [lindex $arctags($a) end]
8229 if {$ta || $arctags($a) ne {}} {
8230 set tomark [list $d]
8231 for {set j 0} {$j < [llength $tomark]} {incr j} {
8232 set dd [lindex $tomark $j]
8233 if {![info exists hastaggedancestor($dd)]} {
8234 if {[info exists done($dd)]} {
8235 foreach b $arcnos($dd) {
8236 lappend tomark $arcstart($b)
8238 if {[info exists tagloc($dd)]} {
8241 } elseif {[info exists queued($dd)]} {
8244 set hastaggedancestor($dd) 1
8248 if {![info exists queued($d)]} {
8251 if {![info exists hastaggedancestor($d)]} {
8258 foreach id [array names tagloc] {
8259 if {![info exists hastaggedancestor($id)]} {
8260 foreach t $tagloc($id) {
8261 if {[lsearch -exact $tags $t] < 0} {
8267 set t2 [clock clicks -milliseconds]
8270 # remove tags that are descendents of other tags
8271 for {set i 0} {$i < [llength $tags]} {incr i} {
8272 set a [lindex $tags $i]
8273 for {set j 0} {$j < $i} {incr j} {
8274 set b [lindex $tags $j]
8275 set r [anc_or_desc $a $b]
8277 set tags [lreplace $tags $j $j]
8280 } elseif {$r == -1} {
8281 set tags [lreplace $tags $i $i]
8288 if {[array names growing] ne {}} {
8289 # graph isn't finished, need to check if any tag could get
8290 # eclipsed by another tag coming later. Simply ignore any
8291 # tags that could later get eclipsed.
8294 if {[is_certain $t $origid]} {
8298 if {$tags eq $ctags} {
8299 set cached_dtags($origid) $tags
8304 set cached_dtags($origid) $tags
8306 set t3 [clock clicks -milliseconds]
8307 if {0 && $t3 - $t1 >= 100} {
8308 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8309 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8315 global arcnos arcids arcout arcend arctags idtags allparents
8316 global growing cached_atags
8318 if {![info exists allparents($id)]} {
8321 set t1 [clock clicks -milliseconds]
8323 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8324 # part-way along an arc; check that arc first
8325 set a [lindex $arcnos($id) 0]
8326 if {$arctags($a) ne {}} {
8328 set i [lsearch -exact $arcids($a) $id]
8329 foreach t $arctags($a) {
8330 set j [lsearch -exact $arcids($a) $t]
8336 if {![info exists arcend($a)]} {
8340 if {[info exists idtags($id)]} {
8344 if {[info exists cached_atags($id)]} {
8345 return $cached_atags($id)
8353 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8354 set id [lindex $todo $i]
8356 set td [info exists hastaggeddescendent($id)]
8360 # ignore tags on starting node
8361 if {!$td && $i > 0} {
8362 if {[info exists idtags($id)]} {
8365 } elseif {[info exists cached_atags($id)]} {
8366 set tagloc($id) $cached_atags($id)
8370 foreach a $arcout($id) {
8371 if {!$td && $arctags($a) ne {}} {
8373 if {$arctags($a) ne {}} {
8374 lappend tagloc($id) [lindex $arctags($a) 0]
8377 if {![info exists arcend($a)]} continue
8379 if {$td || $arctags($a) ne {}} {
8380 set tomark [list $d]
8381 for {set j 0} {$j < [llength $tomark]} {incr j} {
8382 set dd [lindex $tomark $j]
8383 if {![info exists hastaggeddescendent($dd)]} {
8384 if {[info exists done($dd)]} {
8385 foreach b $arcout($dd) {
8386 if {[info exists arcend($b)]} {
8387 lappend tomark $arcend($b)
8390 if {[info exists tagloc($dd)]} {
8393 } elseif {[info exists queued($dd)]} {
8396 set hastaggeddescendent($dd) 1
8400 if {![info exists queued($d)]} {
8403 if {![info exists hastaggeddescendent($d)]} {
8409 set t2 [clock clicks -milliseconds]
8412 foreach id [array names tagloc] {
8413 if {![info exists hastaggeddescendent($id)]} {
8414 foreach t $tagloc($id) {
8415 if {[lsearch -exact $tags $t] < 0} {
8422 # remove tags that are ancestors of other tags
8423 for {set i 0} {$i < [llength $tags]} {incr i} {
8424 set a [lindex $tags $i]
8425 for {set j 0} {$j < $i} {incr j} {
8426 set b [lindex $tags $j]
8427 set r [anc_or_desc $a $b]
8429 set tags [lreplace $tags $j $j]
8432 } elseif {$r == 1} {
8433 set tags [lreplace $tags $i $i]
8440 if {[array names growing] ne {}} {
8441 # graph isn't finished, need to check if any tag could get
8442 # eclipsed by another tag coming later. Simply ignore any
8443 # tags that could later get eclipsed.
8446 if {[is_certain $origid $t]} {
8450 if {$tags eq $ctags} {
8451 set cached_atags($origid) $tags
8456 set cached_atags($origid) $tags
8458 set t3 [clock clicks -milliseconds]
8459 if {0 && $t3 - $t1 >= 100} {
8460 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8461 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8466 # Return the list of IDs that have heads that are descendents of id,
8467 # including id itself if it has a head.
8468 proc descheads {id} {
8469 global arcnos arcstart arcids archeads idheads cached_dheads
8472 if {![info exists allparents($id)]} {
8476 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8477 # part-way along an arc; check it first
8478 set a [lindex $arcnos($id) 0]
8479 if {$archeads($a) ne {}} {
8480 validate_archeads $a
8481 set i [lsearch -exact $arcids($a) $id]
8482 foreach t $archeads($a) {
8483 set j [lsearch -exact $arcids($a) $t]
8488 set id $arcstart($a)
8494 for {set i 0} {$i < [llength $todo]} {incr i} {
8495 set id [lindex $todo $i]
8496 if {[info exists cached_dheads($id)]} {
8497 set ret [concat $ret $cached_dheads($id)]
8499 if {[info exists idheads($id)]} {
8502 foreach a $arcnos($id) {
8503 if {$archeads($a) ne {}} {
8504 validate_archeads $a
8505 if {$archeads($a) ne {}} {
8506 set ret [concat $ret $archeads($a)]
8510 if {![info exists seen($d)]} {
8517 set ret [lsort -unique $ret]
8518 set cached_dheads($origid) $ret
8519 return [concat $ret $aret]
8522 proc addedtag {id} {
8523 global arcnos arcout cached_dtags cached_atags
8525 if {![info exists arcnos($id)]} return
8526 if {![info exists arcout($id)]} {
8527 recalcarc [lindex $arcnos($id) 0]
8529 catch {unset cached_dtags}
8530 catch {unset cached_atags}
8533 proc addedhead {hid head} {
8534 global arcnos arcout cached_dheads
8536 if {![info exists arcnos($hid)]} return
8537 if {![info exists arcout($hid)]} {
8538 recalcarc [lindex $arcnos($hid) 0]
8540 catch {unset cached_dheads}
8543 proc removedhead {hid head} {
8544 global cached_dheads
8546 catch {unset cached_dheads}
8549 proc movedhead {hid head} {
8550 global arcnos arcout cached_dheads
8552 if {![info exists arcnos($hid)]} return
8553 if {![info exists arcout($hid)]} {
8554 recalcarc [lindex $arcnos($hid) 0]
8556 catch {unset cached_dheads}
8559 proc changedrefs {} {
8560 global cached_dheads cached_dtags cached_atags
8561 global arctags archeads arcnos arcout idheads idtags
8563 foreach id [concat [array names idheads] [array names idtags]] {
8564 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8565 set a [lindex $arcnos($id) 0]
8566 if {![info exists donearc($a)]} {
8572 catch {unset cached_dtags}
8573 catch {unset cached_atags}
8574 catch {unset cached_dheads}
8577 proc rereadrefs {} {
8578 global idtags idheads idotherrefs mainheadid
8580 set refids [concat [array names idtags] \
8581 [array names idheads] [array names idotherrefs]]
8582 foreach id $refids {
8583 if {![info exists ref($id)]} {
8584 set ref($id) [listrefs $id]
8587 set oldmainhead $mainheadid
8590 set refids [lsort -unique [concat $refids [array names idtags] \
8591 [array names idheads] [array names idotherrefs]]]
8592 foreach id $refids {
8593 set v [listrefs $id]
8594 if {![info exists ref($id)] || $ref($id) != $v ||
8595 ($id eq $oldmainhead && $id ne $mainheadid) ||
8596 ($id eq $mainheadid && $id ne $oldmainhead)} {
8603 proc listrefs {id} {
8604 global idtags idheads idotherrefs
8607 if {[info exists idtags($id)]} {
8611 if {[info exists idheads($id)]} {
8615 if {[info exists idotherrefs($id)]} {
8616 set z $idotherrefs($id)
8618 return [list $x $y $z]
8621 proc showtag {tag isnew} {
8622 global ctext tagcontents tagids linknum tagobjid
8625 addtohistory [list showtag $tag 0]
8627 $ctext conf -state normal
8631 if {![info exists tagcontents($tag)]} {
8633 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8636 if {[info exists tagcontents($tag)]} {
8637 set text $tagcontents($tag)
8639 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
8641 appendwithlinks $text {}
8642 $ctext conf -state disabled
8653 proc mkfontdisp {font top which} {
8654 global fontattr fontpref $font
8656 set fontpref($font) [set $font]
8657 button $top.${font}but -text $which -font optionfont \
8658 -command [list choosefont $font $which]
8659 label $top.$font -relief flat -font $font \
8660 -text $fontattr($font,family) -justify left
8661 grid x $top.${font}but $top.$font -sticky w
8664 proc choosefont {font which} {
8665 global fontparam fontlist fonttop fontattr
8667 set fontparam(which) $which
8668 set fontparam(font) $font
8669 set fontparam(family) [font actual $font -family]
8670 set fontparam(size) $fontattr($font,size)
8671 set fontparam(weight) $fontattr($font,weight)
8672 set fontparam(slant) $fontattr($font,slant)
8675 if {![winfo exists $top]} {
8677 eval font config sample [font actual $font]
8679 wm title $top [mc "Gitk font chooser"]
8680 label $top.l -textvariable fontparam(which)
8681 pack $top.l -side top
8682 set fontlist [lsort [font families]]
8684 listbox $top.f.fam -listvariable fontlist \
8685 -yscrollcommand [list $top.f.sb set]
8686 bind $top.f.fam <<ListboxSelect>> selfontfam
8687 scrollbar $top.f.sb -command [list $top.f.fam yview]
8688 pack $top.f.sb -side right -fill y
8689 pack $top.f.fam -side left -fill both -expand 1
8690 pack $top.f -side top -fill both -expand 1
8692 spinbox $top.g.size -from 4 -to 40 -width 4 \
8693 -textvariable fontparam(size) \
8694 -validatecommand {string is integer -strict %s}
8695 checkbutton $top.g.bold -padx 5 \
8696 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8697 -variable fontparam(weight) -onvalue bold -offvalue normal
8698 checkbutton $top.g.ital -padx 5 \
8699 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8700 -variable fontparam(slant) -onvalue italic -offvalue roman
8701 pack $top.g.size $top.g.bold $top.g.ital -side left
8702 pack $top.g -side top
8703 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8705 $top.c create text 100 25 -anchor center -text $which -font sample \
8706 -fill black -tags text
8707 bind $top.c <Configure> [list centertext $top.c]
8708 pack $top.c -side top -fill x
8710 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8711 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8712 grid $top.buts.ok $top.buts.can
8713 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8714 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8715 pack $top.buts -side bottom -fill x
8716 trace add variable fontparam write chg_fontparam
8719 $top.c itemconf text -text $which
8721 set i [lsearch -exact $fontlist $fontparam(family)]
8723 $top.f.fam selection set $i
8728 proc centertext {w} {
8729 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8733 global fontparam fontpref prefstop
8735 set f $fontparam(font)
8736 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8737 if {$fontparam(weight) eq "bold"} {
8738 lappend fontpref($f) "bold"
8740 if {$fontparam(slant) eq "italic"} {
8741 lappend fontpref($f) "italic"
8744 $w conf -text $fontparam(family) -font $fontpref($f)
8750 global fonttop fontparam
8752 if {[info exists fonttop]} {
8753 catch {destroy $fonttop}
8754 catch {font delete sample}
8760 proc selfontfam {} {
8761 global fonttop fontparam
8763 set i [$fonttop.f.fam curselection]
8765 set fontparam(family) [$fonttop.f.fam get $i]
8769 proc chg_fontparam {v sub op} {
8772 font config sample -$sub $fontparam($sub)
8776 global maxwidth maxgraphpct
8777 global oldprefs prefstop showneartags showlocalchanges
8778 global bgcolor fgcolor ctext diffcolors selectbgcolor
8779 global tabstop limitdiffs autoselect
8783 if {[winfo exists $top]} {
8787 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8788 limitdiffs tabstop} {
8789 set oldprefs($v) [set $v]
8792 wm title $top [mc "Gitk preferences"]
8793 label $top.ldisp -text [mc "Commit list display options"]
8794 grid $top.ldisp - -sticky w -pady 10
8795 label $top.spacer -text " "
8796 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8798 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8799 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8800 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8802 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8803 grid x $top.maxpctl $top.maxpct -sticky w
8804 frame $top.showlocal
8805 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8806 checkbutton $top.showlocal.b -variable showlocalchanges
8807 pack $top.showlocal.b $top.showlocal.l -side left
8808 grid x $top.showlocal -sticky w
8809 frame $top.autoselect
8810 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
8811 checkbutton $top.autoselect.b -variable autoselect
8812 pack $top.autoselect.b $top.autoselect.l -side left
8813 grid x $top.autoselect -sticky w
8815 label $top.ddisp -text [mc "Diff display options"]
8816 grid $top.ddisp - -sticky w -pady 10
8817 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8818 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8819 grid x $top.tabstopl $top.tabstop -sticky w
8821 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8822 checkbutton $top.ntag.b -variable showneartags
8823 pack $top.ntag.b $top.ntag.l -side left
8824 grid x $top.ntag -sticky w
8826 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8827 checkbutton $top.ldiff.b -variable limitdiffs
8828 pack $top.ldiff.b $top.ldiff.l -side left
8829 grid x $top.ldiff -sticky w
8831 label $top.cdisp -text [mc "Colors: press to choose"]
8832 grid $top.cdisp - -sticky w -pady 10
8833 label $top.bg -padx 40 -relief sunk -background $bgcolor
8834 button $top.bgbut -text [mc "Background"] -font optionfont \
8835 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8836 grid x $top.bgbut $top.bg -sticky w
8837 label $top.fg -padx 40 -relief sunk -background $fgcolor
8838 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8839 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8840 grid x $top.fgbut $top.fg -sticky w
8841 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8842 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8843 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8844 [list $ctext tag conf d0 -foreground]]
8845 grid x $top.diffoldbut $top.diffold -sticky w
8846 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8847 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8848 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8849 [list $ctext tag conf d1 -foreground]]
8850 grid x $top.diffnewbut $top.diffnew -sticky w
8851 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8852 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8853 -command [list choosecolor diffcolors 2 $top.hunksep \
8854 "diff hunk header" \
8855 [list $ctext tag conf hunksep -foreground]]
8856 grid x $top.hunksepbut $top.hunksep -sticky w
8857 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8858 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8859 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8860 grid x $top.selbgbut $top.selbgsep -sticky w
8862 label $top.cfont -text [mc "Fonts: press to choose"]
8863 grid $top.cfont - -sticky w -pady 10
8864 mkfontdisp mainfont $top [mc "Main font"]
8865 mkfontdisp textfont $top [mc "Diff display font"]
8866 mkfontdisp uifont $top [mc "User interface font"]
8869 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8870 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8871 grid $top.buts.ok $top.buts.can
8872 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8873 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8874 grid $top.buts - - -pady 10 -sticky ew
8875 bind $top <Visibility> "focus $top.buts.ok"
8878 proc choosecolor {v vi w x cmd} {
8881 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8882 -title [mc "Gitk: choose color for %s" $x]]
8883 if {$c eq {}} return
8884 $w conf -background $c
8890 global bglist cflist
8892 $w configure -selectbackground $c
8894 $cflist tag configure highlight \
8895 -background [$cflist cget -selectbackground]
8896 allcanvs itemconf secsel -fill $c
8903 $w conf -background $c
8911 $w conf -foreground $c
8913 allcanvs itemconf text -fill $c
8914 $canv itemconf circle -outline $c
8918 global oldprefs prefstop
8920 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8921 limitdiffs tabstop} {
8923 set $v $oldprefs($v)
8925 catch {destroy $prefstop}
8931 global maxwidth maxgraphpct
8932 global oldprefs prefstop showneartags showlocalchanges
8933 global fontpref mainfont textfont uifont
8934 global limitdiffs treediffs
8936 catch {destroy $prefstop}
8940 if {$mainfont ne $fontpref(mainfont)} {
8941 set mainfont $fontpref(mainfont)
8942 parsefont mainfont $mainfont
8943 eval font configure mainfont [fontflags mainfont]
8944 eval font configure mainfontbold [fontflags mainfont 1]
8948 if {$textfont ne $fontpref(textfont)} {
8949 set textfont $fontpref(textfont)
8950 parsefont textfont $textfont
8951 eval font configure textfont [fontflags textfont]
8952 eval font configure textfontbold [fontflags textfont 1]
8954 if {$uifont ne $fontpref(uifont)} {
8955 set uifont $fontpref(uifont)
8956 parsefont uifont $uifont
8957 eval font configure uifont [fontflags uifont]
8960 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8961 if {$showlocalchanges} {
8967 if {$limitdiffs != $oldprefs(limitdiffs)} {
8968 # treediffs elements are limited by path
8969 catch {unset treediffs}
8971 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8972 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8974 } elseif {$showneartags != $oldprefs(showneartags) ||
8975 $limitdiffs != $oldprefs(limitdiffs)} {
8980 proc formatdate {d} {
8981 global datetimeformat
8983 set d [clock format $d -format $datetimeformat]
8988 # This list of encoding names and aliases is distilled from
8989 # http://www.iana.org/assignments/character-sets.
8990 # Not all of them are supported by Tcl.
8991 set encoding_aliases {
8992 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8993 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8994 { ISO-10646-UTF-1 csISO10646UTF1 }
8995 { ISO_646.basic:1983 ref csISO646basic1983 }
8996 { INVARIANT csINVARIANT }
8997 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8998 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8999 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9000 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9001 { NATS-DANO iso-ir-9-1 csNATSDANO }
9002 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9003 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9004 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9005 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9006 { ISO-2022-KR csISO2022KR }
9008 { ISO-2022-JP csISO2022JP }
9009 { ISO-2022-JP-2 csISO2022JP2 }
9010 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9012 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9013 { IT iso-ir-15 ISO646-IT csISO15Italian }
9014 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9015 { ES iso-ir-17 ISO646-ES csISO17Spanish }
9016 { greek7-old iso-ir-18 csISO18Greek7Old }
9017 { latin-greek iso-ir-19 csISO19LatinGreek }
9018 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9019 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9020 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9021 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9022 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9023 { BS_viewdata iso-ir-47 csISO47BSViewdata }
9024 { INIS iso-ir-49 csISO49INIS }
9025 { INIS-8 iso-ir-50 csISO50INIS8 }
9026 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9027 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9028 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9029 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9030 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9031 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9033 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9034 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9035 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9036 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9037 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9038 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9039 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9040 { greek7 iso-ir-88 csISO88Greek7 }
9041 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9042 { iso-ir-90 csISO90 }
9043 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9044 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9045 csISO92JISC62991984b }
9046 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9047 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9048 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9049 csISO95JIS62291984handadd }
9050 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9051 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9052 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9053 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9055 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9056 { T.61-7bit iso-ir-102 csISO102T617bit }
9057 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9058 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9059 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9060 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9061 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9062 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9063 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9064 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9065 arabic csISOLatinArabic }
9066 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9067 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9068 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9069 greek greek8 csISOLatinGreek }
9070 { T.101-G2 iso-ir-128 csISO128T101G2 }
9071 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9073 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9074 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9075 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9076 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9077 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9078 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9079 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9080 csISOLatinCyrillic }
9081 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9082 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9083 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9084 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9085 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9086 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9087 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9088 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9089 { ISO_10367-box iso-ir-155 csISO10367Box }
9090 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9091 { latin-lap lap iso-ir-158 csISO158Lap }
9092 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9093 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9096 { JIS_X0201 X0201 csHalfWidthKatakana }
9097 { KSC5636 ISO646-KR csKSC5636 }
9098 { ISO-10646-UCS-2 csUnicode }
9099 { ISO-10646-UCS-4 csUCS4 }
9100 { DEC-MCS dec csDECMCS }
9101 { hp-roman8 roman8 r8 csHPRoman8 }
9102 { macintosh mac csMacintosh }
9103 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9105 { IBM038 EBCDIC-INT cp038 csIBM038 }
9106 { IBM273 CP273 csIBM273 }
9107 { IBM274 EBCDIC-BE CP274 csIBM274 }
9108 { IBM275 EBCDIC-BR cp275 csIBM275 }
9109 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9110 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9111 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9112 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9113 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9114 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9115 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9116 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9117 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9118 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9119 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9120 { IBM437 cp437 437 csPC8CodePage437 }
9121 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9122 { IBM775 cp775 csPC775Baltic }
9123 { IBM850 cp850 850 csPC850Multilingual }
9124 { IBM851 cp851 851 csIBM851 }
9125 { IBM852 cp852 852 csPCp852 }
9126 { IBM855 cp855 855 csIBM855 }
9127 { IBM857 cp857 857 csIBM857 }
9128 { IBM860 cp860 860 csIBM860 }
9129 { IBM861 cp861 861 cp-is csIBM861 }
9130 { IBM862 cp862 862 csPC862LatinHebrew }
9131 { IBM863 cp863 863 csIBM863 }
9132 { IBM864 cp864 csIBM864 }
9133 { IBM865 cp865 865 csIBM865 }
9134 { IBM866 cp866 866 csIBM866 }
9135 { IBM868 CP868 cp-ar csIBM868 }
9136 { IBM869 cp869 869 cp-gr csIBM869 }
9137 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9138 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9139 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9140 { IBM891 cp891 csIBM891 }
9141 { IBM903 cp903 csIBM903 }
9142 { IBM904 cp904 904 csIBBM904 }
9143 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9144 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9145 { IBM1026 CP1026 csIBM1026 }
9146 { EBCDIC-AT-DE csIBMEBCDICATDE }
9147 { EBCDIC-AT-DE-A csEBCDICATDEA }
9148 { EBCDIC-CA-FR csEBCDICCAFR }
9149 { EBCDIC-DK-NO csEBCDICDKNO }
9150 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9151 { EBCDIC-FI-SE csEBCDICFISE }
9152 { EBCDIC-FI-SE-A csEBCDICFISEA }
9153 { EBCDIC-FR csEBCDICFR }
9154 { EBCDIC-IT csEBCDICIT }
9155 { EBCDIC-PT csEBCDICPT }
9156 { EBCDIC-ES csEBCDICES }
9157 { EBCDIC-ES-A csEBCDICESA }
9158 { EBCDIC-ES-S csEBCDICESS }
9159 { EBCDIC-UK csEBCDICUK }
9160 { EBCDIC-US csEBCDICUS }
9161 { UNKNOWN-8BIT csUnknown8BiT }
9162 { MNEMONIC csMnemonic }
9167 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9168 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9169 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9170 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9171 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9172 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9173 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9174 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9175 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9176 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9177 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9178 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9179 { IBM1047 IBM-1047 }
9180 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9181 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9182 { UNICODE-1-1 csUnicode11 }
9185 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9186 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9188 { ISO-8859-15 ISO_8859-15 Latin-9 }
9189 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9190 { GBK CP936 MS936 windows-936 }
9191 { JIS_Encoding csJISEncoding }
9192 { Shift_JIS MS_Kanji csShiftJIS }
9193 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9195 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9196 { ISO-10646-UCS-Basic csUnicodeASCII }
9197 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9198 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9199 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9200 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9201 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9202 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9203 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9204 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9205 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9206 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9207 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9208 { Ventura-US csVenturaUS }
9209 { Ventura-International csVenturaInternational }
9210 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9211 { PC8-Turkish csPC8Turkish }
9212 { IBM-Symbols csIBMSymbols }
9213 { IBM-Thai csIBMThai }
9214 { HP-Legal csHPLegal }
9215 { HP-Pi-font csHPPiFont }
9216 { HP-Math8 csHPMath8 }
9217 { Adobe-Symbol-Encoding csHPPSMath }
9218 { HP-DeskTop csHPDesktop }
9219 { Ventura-Math csVenturaMath }
9220 { Microsoft-Publishing csMicrosoftPublishing }
9221 { Windows-31J csWindows31J }
9226 proc tcl_encoding {enc} {
9227 global encoding_aliases
9228 set names [encoding names]
9229 set lcnames [string tolower $names]
9230 set enc [string tolower $enc]
9231 set i [lsearch -exact $lcnames $enc]
9233 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9234 if {[regsub {^iso[-_]} $enc iso encx]} {
9235 set i [lsearch -exact $lcnames $encx]
9239 foreach l $encoding_aliases {
9240 set ll [string tolower $l]
9241 if {[lsearch -exact $ll $enc] < 0} continue
9242 # look through the aliases for one that tcl knows about
9244 set i [lsearch -exact $lcnames $e]
9246 if {[regsub {^iso[-_]} $e iso ex]} {
9247 set i [lsearch -exact $lcnames $ex]
9256 return [lindex $names $i]
9261 # First check that Tcl/Tk is recent enough
9262 if {[catch {package require Tk 8.4} err]} {
9263 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9264 Gitk requires at least Tcl/Tk 8.4."]
9270 set wrcomcmd "git diff-tree --stdin -p --pretty"
9274 set gitencoding [exec git config --get i18n.commitencoding]
9276 if {$gitencoding == ""} {
9277 set gitencoding "utf-8"
9279 set tclencoding [tcl_encoding $gitencoding]
9280 if {$tclencoding == {}} {
9281 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9284 set mainfont {Helvetica 9}
9285 set textfont {Courier 9}
9286 set uifont {Helvetica 9 bold}
9288 set findmergefiles 0
9296 set cmitmode "patch"
9297 set wrapcomment "none"
9301 set showlocalchanges 1
9303 set datetimeformat "%Y-%m-%d %H:%M:%S"
9306 set colors {green red blue magenta darkgrey brown orange}
9309 set diffcolors {red "#00a000" blue}
9312 set selectbgcolor gray85
9314 ## For msgcat loading, first locate the installation location.
9315 if { [info exists ::env(GITK_MSGSDIR)] } {
9316 ## Msgsdir was manually set in the environment.
9317 set gitk_msgsdir $::env(GITK_MSGSDIR)
9319 ## Let's guess the prefix from argv0.
9320 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9321 set gitk_libdir [file join $gitk_prefix share gitk lib]
9322 set gitk_msgsdir [file join $gitk_libdir msgs]
9326 ## Internationalization (i18n) through msgcat and gettext. See
9327 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9328 package require msgcat
9329 namespace import ::msgcat::mc
9330 ## And eventually load the actual message catalog
9331 ::msgcat::mcload $gitk_msgsdir
9333 catch {source ~/.gitk}
9335 font create optionfont -family sans-serif -size -12
9337 parsefont mainfont $mainfont
9338 eval font create mainfont [fontflags mainfont]
9339 eval font create mainfontbold [fontflags mainfont 1]
9341 parsefont textfont $textfont
9342 eval font create textfont [fontflags textfont]
9343 eval font create textfontbold [fontflags textfont 1]
9345 parsefont uifont $uifont
9346 eval font create uifont [fontflags uifont]
9350 # check that we can find a .git directory somewhere...
9351 if {[catch {set gitdir [gitdir]}]} {
9352 show_error {} . [mc "Cannot find a git repository here."]
9355 if {![file isdirectory $gitdir]} {
9356 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9362 set cmdline_files {}
9364 set revtreeargscmd {}
9366 switch -glob -- $arg {
9368 "-d" { set datemode 1 }
9371 lappend revtreeargs $arg
9374 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9378 set revtreeargscmd [string range $arg 10 end]
9381 lappend revtreeargs $arg
9387 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9388 # no -- on command line, but some arguments (other than -d)
9390 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9391 set cmdline_files [split $f "\n"]
9392 set n [llength $cmdline_files]
9393 set revtreeargs [lrange $revtreeargs 0 end-$n]
9394 # Unfortunately git rev-parse doesn't produce an error when
9395 # something is both a revision and a filename. To be consistent
9396 # with git log and git rev-list, check revtreeargs for filenames.
9397 foreach arg $revtreeargs {
9398 if {[file exists $arg]} {
9399 show_error {} . [mc "Ambiguous argument '%s': both revision\
9405 # unfortunately we get both stdout and stderr in $err,
9406 # so look for "fatal:".
9407 set i [string first "fatal:" $err]
9409 set err [string range $err [expr {$i + 6}] end]
9411 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9417 # find the list of unmerged files
9421 set fd [open "| git ls-files -u" r]
9423 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9426 while {[gets $fd line] >= 0} {
9427 set i [string first "\t" $line]
9428 if {$i < 0} continue
9429 set fname [string range $line [expr {$i+1}] end]
9430 if {[lsearch -exact $mlist $fname] >= 0} continue
9432 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9433 lappend mlist $fname
9438 if {$nr_unmerged == 0} {
9439 show_error {} . [mc "No files selected: --merge specified but\
9440 no files are unmerged."]
9442 show_error {} . [mc "No files selected: --merge specified but\
9443 no unmerged files are within file limit."]
9447 set cmdline_files $mlist
9450 set nullid "0000000000000000000000000000000000000000"
9451 set nullid2 "0000000000000000000000000000000000000001"
9453 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9460 set highlight_paths {}
9462 set searchdirn -forwards
9466 set markingmatches 0
9467 set linkentercount 0
9468 set need_redisplay 0
9475 set selectedhlview [mc "None"]
9476 set highlight_related [mc "None"]
9477 set highlight_files {}
9481 set viewargscmd(0) {}
9489 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
9492 # wait for the window to become visible
9494 wm title . "[file tail $argv0]: [file tail [pwd]]"
9497 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
9498 # create a view for the files/dirs specified on the command line
9502 set viewname(1) [mc "Command line"]
9503 set viewfiles(1) $cmdline_files
9504 set viewargs(1) $revtreeargs
9505 set viewargscmd(1) $revtreeargscmd
9508 .bar.view entryconf [mc "Edit view..."] -state normal
9509 .bar.view entryconf [mc "Delete view"] -state normal
9512 if {[info exists permviews]} {
9513 foreach v $permviews {
9516 set viewname($n) [lindex $v 0]
9517 set viewfiles($n) [lindex $v 1]
9518 set viewargs($n) [lindex $v 2]
9519 set viewargscmd($n) [lindex $v 3]