2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
12 if {[info exists env
(GIT_DIR
)]} {
15 return [exec git rev-parse
--git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
28 if {[info exists isonrunq
($script)]} return
32 lappend runq
[list
{} $script]
33 set isonrunq
($script) 1
36 proc filerun
{fd
script} {
37 fileevent
$fd readable
[list filereadable
$fd $script]
40 proc filereadable
{fd
script} {
43 fileevent
$fd readable
{}
47 lappend runq
[list
$fd $script]
53 for {set i
0} {$i < [llength
$runq]} {} {
54 if {[lindex
$runq $i 0] eq
$fd} {
55 set runq
[lreplace
$runq $i $i]
65 set tstart
[clock clicks
-milliseconds]
67 while {[llength
$runq] > 0} {
68 set fd
[lindex
$runq 0 0]
69 set script [lindex
$runq 0 1]
70 set repeat
[eval $script]
71 set t1
[clock clicks
-milliseconds]
72 set t
[expr {$t1 - $t0}]
73 set runq
[lrange
$runq 1 end
]
74 if {$repeat ne
{} && $repeat} {
75 if {$fd eq
{} ||
$repeat == 2} {
76 # script returns 1 if it wants to be readded
77 # file readers return 2 if they could do more straight away
78 lappend runq
[list
$fd $script]
80 fileevent
$fd readable
[list filereadable
$fd $script]
82 } elseif
{$fd eq
{}} {
83 unset isonrunq
($script)
86 if {$t1 - $tstart >= 80} break
93 # Start off a git rev-list process and arrange to read its output
94 proc start_rev_list
{view
} {
96 global commfd leftover tclencoding datemode
97 global viewargs viewfiles commitidx viewcomplete vnextroot
98 global showlocalchanges commitinterest mainheadid
99 global progressdirn progresscoords proglastnc curview
100 global viewincl viewactive loginstance viewinstances
101 global pending_select mainheadid
103 set startmsecs
[clock clicks
-milliseconds]
104 set commitidx
($view) 0
105 set viewcomplete
($view) 0
106 set viewactive
($view) 1
107 set vnextroot
($view) 0
110 set commits
[eval exec git rev-parse
--default HEAD
--revs-only \
112 set viewincl
($view) {}
114 if {[regexp
{^
[0-9a-fA-F]{40}$
} $c]} {
115 lappend viewincl
($view) $c
119 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
120 --boundary $commits "--" $viewfiles($view)] r
]
122 error_popup
"[mc "Error executing git log
:"] $err"
125 set i
[incr loginstance
]
126 set viewinstances
($view) [list
$i]
129 if {$showlocalchanges} {
130 lappend commitinterest
($mainheadid) {dodiffindex
}
132 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
133 if {$tclencoding != {}} {
134 fconfigure
$fd -encoding $tclencoding
136 filerun
$fd [list getcommitlines
$fd $i $view]
137 nowbusy
$view [mc
"Reading"]
138 if {$view == $curview} {
140 set progresscoords
{0 0}
142 set pending_select
$mainheadid
146 proc stop_rev_list
{view
} {
147 global commfd viewinstances leftover
149 foreach inst
$viewinstances($view) {
150 set fd
$commfd($inst)
158 unset leftover
($inst)
160 set viewinstances
($view) {}
167 start_rev_list
$curview
168 show_status
[mc
"Reading commits..."]
171 proc updatecommits
{} {
172 global curview viewargs viewfiles viewincl viewinstances
173 global viewactive viewcomplete loginstance tclencoding mainheadid
174 global varcid startmsecs commfd showneartags showlocalchanges leftover
175 global mainheadid pending_select
177 set oldmainid
$mainheadid
179 if {$showlocalchanges} {
180 if {$mainheadid ne
$oldmainid} {
183 if {[commitinview
$mainheadid $curview]} {
188 set commits
[exec git rev-parse
--default HEAD
--revs-only \
194 if {[string match
"^*" $c]} {
196 } elseif
{[regexp
{^
[0-9a-fA-F]{40}$
} $c]} {
197 if {!([info exists varcid
($view,$c)] ||
198 [lsearch
-exact $viewincl($view) $c] >= 0)} {
208 foreach id
$viewincl($view) {
211 set viewincl
($view) [concat
$viewincl($view) $pos]
213 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
214 --boundary $pos $neg $flags "--" $viewfiles($view)] r
]
216 error_popup
"Error executing git log: $err"
219 if {$viewactive($view) == 0} {
220 set startmsecs
[clock clicks
-milliseconds]
222 set i
[incr loginstance
]
223 lappend viewinstances
($view) $i
226 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
227 if {$tclencoding != {}} {
228 fconfigure
$fd -encoding $tclencoding
230 filerun
$fd [list getcommitlines
$fd $i $view]
231 incr viewactive
($view)
232 set viewcomplete
($view) 0
233 set pending_select
$mainheadid
234 nowbusy
$view "Reading"
240 proc reloadcommits
{} {
241 global curview viewcomplete selectedline currentid thickerline
242 global showneartags treediffs commitinterest cached_commitrow
243 global progresscoords targetid
245 if {!$viewcomplete($curview)} {
246 stop_rev_list
$curview
247 set progresscoords
{0 0}
251 catch
{unset selectedline
}
252 catch
{unset currentid
}
253 catch
{unset thickerline
}
254 catch
{unset treediffs
}
261 catch
{unset commitinterest
}
262 catch
{unset cached_commitrow
}
263 catch
{unset targetid
}
268 # This makes a string representation of a positive integer which
269 # sorts as a string in numerical order
272 return [format
"%x" $n]
273 } elseif
{$n < 256} {
274 return [format
"x%.2x" $n]
275 } elseif
{$n < 65536} {
276 return [format
"y%.4x" $n]
278 return [format
"z%.8x" $n]
281 # Procedures used in reordering commits from git log (without
282 # --topo-order) into the order for display.
284 proc varcinit
{view
} {
285 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
286 global vtokmod varcmod vrowmod varcix vlastins
288 set varcstart
($view) {{}}
289 set vupptr
($view) {0}
290 set vdownptr
($view) {0}
291 set vleftptr
($view) {0}
292 set vbackptr
($view) {0}
293 set varctok
($view) {{}}
294 set varcrow
($view) {{}}
295 set vtokmod
($view) {}
298 set varcix
($view) {{}}
299 set vlastins
($view) {0}
302 proc resetvarcs
{view
} {
303 global varcid varccommits parents children vseedcount ordertok
305 foreach vid
[array names varcid
$view,*] {
310 # some commits might have children but haven't been seen yet
311 foreach vid
[array names children
$view,*] {
314 foreach va
[array names varccommits
$view,*] {
315 unset varccommits
($va)
317 foreach vd
[array names vseedcount
$view,*] {
318 unset vseedcount
($vd)
320 catch
{unset ordertok
}
323 proc newvarc
{view id
} {
324 global varcid varctok parents children datemode
325 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
326 global commitdata commitinfo vseedcount varccommits vlastins
328 set a
[llength
$varctok($view)]
330 if {[llength
$children($vid)] == 0 ||
$datemode} {
331 if {![info exists commitinfo
($id)]} {
332 parsecommit
$id $commitdata($id) 1
334 set cdate
[lindex
$commitinfo($id) 4]
335 if {![string is integer
-strict $cdate]} {
338 if {![info exists vseedcount
($view,$cdate)]} {
339 set vseedcount
($view,$cdate) -1
341 set c
[incr vseedcount
($view,$cdate)]
342 set cdate
[expr {$cdate ^
0xffffffff}]
343 set tok
"s[strrep $cdate][strrep $c]"
348 if {[llength
$children($vid)] > 0} {
349 set kid
[lindex
$children($vid) end
]
350 set k
$varcid($view,$kid)
351 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
354 set tok
[lindex
$varctok($view) $k]
358 set i
[lsearch
-exact $parents($view,$ki) $id]
359 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
360 append tok
[strrep
$j]
362 set c
[lindex
$vlastins($view) $ka]
363 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
365 set b
[lindex
$vdownptr($view) $ka]
367 set b
[lindex
$vleftptr($view) $c]
369 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
371 set b
[lindex
$vleftptr($view) $c]
374 lset vdownptr
($view) $ka $a
375 lappend vbackptr
($view) 0
377 lset vleftptr
($view) $c $a
378 lappend vbackptr
($view) $c
380 lset vlastins
($view) $ka $a
381 lappend vupptr
($view) $ka
382 lappend vleftptr
($view) $b
384 lset vbackptr
($view) $b $a
386 lappend varctok
($view) $tok
387 lappend varcstart
($view) $id
388 lappend vdownptr
($view) 0
389 lappend varcrow
($view) {}
390 lappend varcix
($view) {}
391 set varccommits
($view,$a) {}
392 lappend vlastins
($view) 0
396 proc splitvarc
{p v
} {
397 global varcid varcstart varccommits varctok
398 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
400 set oa
$varcid($v,$p)
401 set ac
$varccommits($v,$oa)
402 set i
[lsearch
-exact $varccommits($v,$oa) $p]
404 set na
[llength
$varctok($v)]
405 # "%" sorts before "0"...
406 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
407 lappend varctok
($v) $tok
408 lappend varcrow
($v) {}
409 lappend varcix
($v) {}
410 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
411 set varccommits
($v,$na) [lrange
$ac $i end
]
412 lappend varcstart
($v) $p
413 foreach id
$varccommits($v,$na) {
414 set varcid
($v,$id) $na
416 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
417 lset vdownptr
($v) $oa $na
418 lappend vupptr
($v) $oa
419 lappend vleftptr
($v) 0
420 lappend vbackptr
($v) 0
421 lappend vlastins
($v) 0
422 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
423 lset vupptr
($v) $b $na
427 proc renumbervarc
{a v
} {
428 global parents children varctok varcstart varccommits
429 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
431 set t1
[clock clicks
-milliseconds]
437 if {[info exists isrelated
($a)]} {
439 set id
[lindex
$varccommits($v,$a) end
]
440 foreach p
$parents($v,$id) {
441 if {[info exists varcid
($v,$p)]} {
442 set isrelated
($varcid($v,$p)) 1
447 set b
[lindex
$vdownptr($v) $a]
450 set b
[lindex
$vleftptr($v) $a]
452 set a
[lindex
$vupptr($v) $a]
458 if {![info exists kidchanged
($a)]} continue
459 set id
[lindex
$varcstart($v) $a]
460 if {[llength
$children($v,$id)] > 1} {
461 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
464 set oldtok
[lindex
$varctok($v) $a]
471 set kid
[last_real_child
$v,$id]
473 set k
$varcid($v,$kid)
474 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
477 set tok
[lindex
$varctok($v) $k]
481 set i
[lsearch
-exact $parents($v,$ki) $id]
482 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
483 append tok
[strrep
$j]
485 if {$tok eq
$oldtok} {
488 set id
[lindex
$varccommits($v,$a) end
]
489 foreach p
$parents($v,$id) {
490 if {[info exists varcid
($v,$p)]} {
491 set kidchanged
($varcid($v,$p)) 1
496 lset varctok
($v) $a $tok
497 set b
[lindex
$vupptr($v) $a]
499 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
502 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
505 set c
[lindex
$vbackptr($v) $a]
506 set d
[lindex
$vleftptr($v) $a]
508 lset vdownptr
($v) $b $d
510 lset vleftptr
($v) $c $d
513 lset vbackptr
($v) $d $c
515 lset vupptr
($v) $a $ka
516 set c
[lindex
$vlastins($v) $ka]
518 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
520 set b
[lindex
$vdownptr($v) $ka]
522 set b
[lindex
$vleftptr($v) $c]
525 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
527 set b
[lindex
$vleftptr($v) $c]
530 lset vdownptr
($v) $ka $a
531 lset vbackptr
($v) $a 0
533 lset vleftptr
($v) $c $a
534 lset vbackptr
($v) $a $c
536 lset vleftptr
($v) $a $b
538 lset vbackptr
($v) $b $a
540 lset vlastins
($v) $ka $a
543 foreach id
[array names sortkids
] {
544 if {[llength
$children($v,$id)] > 1} {
545 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
549 set t2
[clock clicks
-milliseconds]
550 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
553 proc fix_reversal
{p a v
} {
554 global varcid varcstart varctok vupptr
556 set pa
$varcid($v,$p)
557 if {$p ne
[lindex
$varcstart($v) $pa]} {
559 set pa
$varcid($v,$p)
561 # seeds always need to be renumbered
562 if {[lindex
$vupptr($v) $pa] == 0 ||
563 [string compare
[lindex
$varctok($v) $a] \
564 [lindex
$varctok($v) $pa]] > 0} {
569 proc insertrow
{id p v
} {
570 global varcid varccommits parents children cmitlisted
571 global commitidx varctok vtokmod targetid targetrow
574 set i
[lsearch
-exact $varccommits($v,$a) $p]
576 puts
"oops: insertrow can't find [shortids $p] on arc $a"
579 set children
($v,$id) {}
580 set parents
($v,$id) [list
$p]
581 set varcid
($v,$id) $a
582 lappend children
($v,$p) $id
583 set cmitlisted
($v,$id) 1
585 # note we deliberately don't update varcstart($v) even if $i == 0
586 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
587 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
590 if {[info exists targetid
]} {
591 if {![comes_before
$targetid $p]} {
598 proc removerow
{id v
} {
599 global varcid varccommits parents children commitidx
600 global varctok vtokmod cmitlisted currentid selectedline
603 if {[llength
$parents($v,$id)] != 1} {
604 puts
"oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
607 set p
[lindex
$parents($v,$id) 0]
608 set a
$varcid($v,$id)
609 set i
[lsearch
-exact $varccommits($v,$a) $id]
611 puts
"oops: removerow can't find [shortids $id] on arc $a"
615 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
616 unset parents
($v,$id)
617 unset children
($v,$id)
618 unset cmitlisted
($v,$id)
619 incr commitidx
($v) -1
620 set j
[lsearch
-exact $children($v,$p) $id]
622 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
624 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
627 if {[info exist currentid
] && $id eq
$currentid} {
631 if {[info exists targetid
] && $targetid eq
$id} {
637 proc first_real_child
{vp
} {
638 global children nullid nullid2
640 foreach id
$children($vp) {
641 if {$id ne
$nullid && $id ne
$nullid2} {
648 proc last_real_child
{vp
} {
649 global children nullid nullid2
651 set kids
$children($vp)
652 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
653 set id
[lindex
$kids $i]
654 if {$id ne
$nullid && $id ne
$nullid2} {
661 proc vtokcmp
{v a b
} {
662 global varctok varcid
664 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
665 [lindex
$varctok($v) $varcid($v,$b)]]
668 proc modify_arc
{v a
{lim
{}}} {
669 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
671 set vtokmod
($v) [lindex
$varctok($v) $a]
673 if {$v == $curview} {
674 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
675 set a
[lindex
$vupptr($v) $a]
681 set lim
[llength
$varccommits($v,$a)]
683 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
690 proc update_arcrows
{v
} {
691 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
692 global varcid vrownum varcorder varcix varccommits
693 global vupptr vdownptr vleftptr varctok
694 global displayorder parentlist curview cached_commitrow
696 set narctot
[expr {[llength
$varctok($v)] - 1}]
698 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
699 # go up the tree until we find something that has a row number,
700 # or we get to a seed
701 set a
[lindex
$vupptr($v) $a]
704 set a
[lindex
$vdownptr($v) 0]
707 set varcorder
($v) [list
$a]
709 lset varcrow
($v) $a 0
713 set arcn
[lindex
$varcix($v) $a]
714 # see if a is the last arc; if so, nothing to do
715 if {$arcn == $narctot - 1} {
718 if {[llength
$vrownum($v)] > $arcn + 1} {
719 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
720 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
722 set row
[lindex
$varcrow($v) $a]
724 if {$v == $curview} {
725 if {[llength
$displayorder] > $vrowmod($v)} {
726 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
727 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
729 catch
{unset cached_commitrow
}
733 incr row
[llength
$varccommits($v,$a)]
734 # go down if possible
735 set b
[lindex
$vdownptr($v) $a]
737 # if not, go left, or go up until we can go left
739 set b
[lindex
$vleftptr($v) $a]
741 set a
[lindex
$vupptr($v) $a]
747 lappend vrownum
($v) $row
748 lappend varcorder
($v) $a
749 lset varcix
($v) $a $arcn
750 lset varcrow
($v) $a $row
752 set vtokmod
($v) [lindex
$varctok($v) $p]
755 if {[info exists currentid
]} {
756 set selectedline
[rowofcommit
$currentid]
760 # Test whether view $v contains commit $id
761 proc commitinview
{id v
} {
764 return [info exists varcid
($v,$id)]
767 # Return the row number for commit $id in the current view
768 proc rowofcommit
{id
} {
769 global varcid varccommits varcrow curview cached_commitrow
770 global varctok vtokmod
773 if {![info exists varcid
($v,$id)]} {
774 puts
"oops rowofcommit no arc for [shortids $id]"
777 set a
$varcid($v,$id)
778 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
781 if {[info exists cached_commitrow
($id)]} {
782 return $cached_commitrow($id)
784 set i
[lsearch
-exact $varccommits($v,$a) $id]
786 puts
"oops didn't find commit [shortids $id] in arc $a"
789 incr i
[lindex
$varcrow($v) $a]
790 set cached_commitrow
($id) $i
794 # Returns 1 if a is on an earlier row than b, otherwise 0
795 proc comes_before
{a b
} {
796 global varcid varctok curview
799 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
800 ![info exists varcid
($v,$b)]} {
803 if {$varcid($v,$a) != $varcid($v,$b)} {
804 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
805 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
807 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
810 proc bsearch
{l elt
} {
811 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
816 while {$hi - $lo > 1} {
817 set mid
[expr {int
(($lo + $hi) / 2)}]
818 set t
[lindex
$l $mid]
821 } elseif
{$elt > $t} {
830 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
831 proc make_disporder
{start end
} {
832 global vrownum curview commitidx displayorder parentlist
833 global varccommits varcorder parents vrowmod varcrow
834 global d_valid_start d_valid_end
836 if {$end > $vrowmod($curview)} {
837 update_arcrows
$curview
839 set ai
[bsearch
$vrownum($curview) $start]
840 set start
[lindex
$vrownum($curview) $ai]
841 set narc
[llength
$vrownum($curview)]
842 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
843 set a
[lindex
$varcorder($curview) $ai]
844 set l
[llength
$displayorder]
845 set al
[llength
$varccommits($curview,$a)]
848 set pad
[ntimes
[expr {$r - $l}] {}]
849 set displayorder
[concat
$displayorder $pad]
850 set parentlist
[concat
$parentlist $pad]
852 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
853 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
855 foreach id
$varccommits($curview,$a) {
856 lappend displayorder
$id
857 lappend parentlist
$parents($curview,$id)
859 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
861 foreach id
$varccommits($curview,$a) {
862 lset displayorder
$i $id
863 lset parentlist
$i $parents($curview,$id)
871 proc commitonrow
{row
} {
874 set id
[lindex
$displayorder $row]
876 make_disporder
$row [expr {$row + 1}]
877 set id
[lindex
$displayorder $row]
882 proc closevarcs
{v
} {
883 global varctok varccommits varcid parents children
884 global cmitlisted commitidx commitinterest vtokmod
886 set missing_parents
0
888 set narcs
[llength
$varctok($v)]
889 for {set a
1} {$a < $narcs} {incr a
} {
890 set id
[lindex
$varccommits($v,$a) end
]
891 foreach p
$parents($v,$id) {
892 if {[info exists varcid
($v,$p)]} continue
893 # add p as a new commit
895 set cmitlisted
($v,$p) 0
896 set parents
($v,$p) {}
897 if {[llength
$children($v,$p)] == 1 &&
898 [llength
$parents($v,$id)] == 1} {
901 set b
[newvarc
$v $p]
904 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
907 lappend varccommits
($v,$b) $p
909 if {[info exists commitinterest
($p)]} {
910 foreach
script $commitinterest($p) {
911 lappend scripts
[string map
[list
"%I" $p] $script]
913 unset commitinterest
($id)
917 if {$missing_parents > 0} {
924 proc getcommitlines
{fd inst view
} {
925 global cmitlisted commitinterest leftover
926 global commitidx commitdata datemode
927 global parents children curview hlview
928 global vnextroot idpending ordertok
929 global varccommits varcid varctok vtokmod
931 set stuff
[read $fd 500000]
932 # git log doesn't terminate the last commit with a null...
933 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
940 global commfd viewcomplete viewactive viewname progresscoords
943 set i
[lsearch
-exact $viewinstances($view) $inst]
945 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
947 # set it blocking so we wait for the process to terminate
948 fconfigure
$fd -blocking 1
949 if {[catch
{close
$fd} err
]} {
951 if {$view != $curview} {
952 set fv
" for the \"$viewname($view)\" view"
954 if {[string range
$err 0 4] == "usage"} {
955 set err
"Gitk: error reading commits$fv:\
956 bad arguments to git rev-list."
957 if {$viewname($view) eq
"Command line"} {
959 " (Note: arguments to gitk are passed to git rev-list\
960 to allow selection of commits to be displayed.)"
963 set err
"Error reading commits$fv: $err"
967 if {[incr viewactive
($view) -1] <= 0} {
968 set viewcomplete
($view) 1
969 # Check if we have seen any ids listed as parents that haven't
970 # appeared in the list
973 set progresscoords
{0 0}
976 if {$view == $curview} {
977 run chewcommits
$view
985 set i
[string first
"\0" $stuff $start]
987 append leftover
($inst) [string range
$stuff $start end
]
991 set cmit
$leftover($inst)
992 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
993 set leftover
($inst) {}
995 set cmit
[string range
$stuff $start [expr {$i - 1}]]
997 set start
[expr {$i + 1}]
998 set j
[string first
"\n" $cmit]
1001 if {$j >= 0 && [string match
"commit *" $cmit]} {
1002 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1003 if {[string match
{[-<>]*} $ids]} {
1004 switch
-- [string index
$ids 0] {
1009 set ids
[string range
$ids 1 end
]
1013 if {[string length
$id] != 40} {
1021 if {[string length
$shortcmit] > 80} {
1022 set shortcmit
"[string range $shortcmit 0 80]..."
1024 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1027 set id [lindex $ids 0]
1029 if {!$listed && [info exists parents($vid)]} continue
1031 set olds [lrange $ids 1 end]
1035 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1036 set cmitlisted($vid) $listed
1037 set parents($vid) $olds
1039 if {![info exists children($vid)]} {
1040 set children($vid) {}
1041 } elseif {[llength $children($vid)] == 1} {
1042 set k [lindex $children($vid) 0]
1043 if {[llength $parents($view,$k)] == 1 &&
1045 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1046 set a $varcid($view,$k)
1051 set a [newvarc $view $id]
1054 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1057 lappend varccommits($view,$a) $id
1061 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1063 if {[llength [lappend children($vp) $id]] > 1 &&
1064 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1065 set children($vp) [lsort -command [list vtokcmp $view] \
1067 catch {unset ordertok}
1069 if {[info exists varcid($view,$p)]} {
1070 fix_reversal $p $a $view
1076 incr commitidx($view)
1077 if {[info exists commitinterest($id)]} {
1078 foreach script $commitinterest($id) {
1079 lappend scripts [string map [list "%I" $id] $script]
1081 unset commitinterest($id)
1086 run chewcommits $view
1087 foreach s $scripts {
1090 if {$view == $curview} {
1091 # update progress bar
1092 global progressdirn progresscoords proglastnc
1093 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1094 set proglastnc $commitidx($view)
1095 set l [lindex $progresscoords 0]
1096 set r [lindex $progresscoords 1]
1097 if {$progressdirn} {
1098 set r [expr {$r + $inc}]
1104 set l [expr {$r - 0.2}]
1107 set l [expr {$l - $inc}]
1112 set r [expr {$l + 0.2}]
1114 set progresscoords [list $l $r]
1121 proc chewcommits {view} {
1122 global curview hlview viewcomplete
1123 global pending_select
1125 if {$view == $curview} {
1127 if {$viewcomplete($view)} {
1128 global commitidx varctok
1129 global numcommits startmsecs
1130 global mainheadid commitinfo nullid
1132 if {[info exists pending_select]} {
1133 set row [first_real_row]
1136 if {$commitidx($curview) > 0} {
1137 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1138 #puts "overall $ms ms for $numcommits commits"
1139 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1141 show_status [mc "No commits selected"]
1146 if {[info exists hlview] && $view == $hlview} {
1152 proc readcommit {id} {
1153 if {[catch {set contents [exec git cat-file commit $id]}]} return
1154 parsecommit $id $contents 0
1157 proc parsecommit {id contents listed} {
1158 global commitinfo cdate
1167 set hdrend [string first "\n\n" $contents]
1169 # should never happen...
1170 set hdrend [string length $contents]
1172 set header [string range $contents 0 [expr {$hdrend - 1}]]
1173 set comment [string range $contents [expr {$hdrend + 2}] end]
1174 foreach line [split $header "\n"] {
1175 set tag [lindex $line 0]
1176 if {$tag == "author"} {
1177 set audate [lindex $line end-1]
1178 set auname [lrange $line 1 end-2]
1179 } elseif {$tag == "committer"} {
1180 set comdate [lindex $line end-1]
1181 set comname [lrange $line 1 end-2]
1185 # take the first non-blank line of the comment as the headline
1186 set headline [string trimleft $comment]
1187 set i [string first "\n" $headline]
1189 set headline [string range $headline 0 $i]
1191 set headline [string trimright $headline]
1192 set i [string first "\r" $headline]
1194 set headline [string trimright [string range $headline 0 $i]]
1197 # git rev-list indents the comment by 4 spaces;
1198 # if we got this via git cat-file, add the indentation
1200 foreach line [split $comment "\n"] {
1201 append newcomment " "
1202 append newcomment $line
1203 append newcomment "\n"
1205 set comment $newcomment
1207 if {$comdate != {}} {
1208 set cdate($id) $comdate
1210 set commitinfo($id) [list $headline $auname $audate \
1211 $comname $comdate $comment]
1214 proc getcommit {id} {
1215 global commitdata commitinfo
1217 if {[info exists commitdata($id)]} {
1218 parsecommit $id $commitdata($id) 1
1221 if {![info exists commitinfo($id)]} {
1222 set commitinfo($id) [list [mc "No commit information available"]]
1229 global tagids idtags headids idheads tagobjid
1230 global otherrefids idotherrefs mainhead mainheadid
1232 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1235 set refd [open [list | git show-ref -d] r]
1236 while {[gets $refd line] >= 0} {
1237 if {[string index $line 40] ne " "} continue
1238 set id [string range $line 0 39]
1239 set ref [string range $line 41 end]
1240 if {![string match "refs/*" $ref]} continue
1241 set name [string range $ref 5 end]
1242 if {[string match "remotes/*" $name]} {
1243 if {![string match "*/HEAD" $name]} {
1244 set headids($name) $id
1245 lappend idheads($id) $name
1247 } elseif {[string match "heads/*" $name]} {
1248 set name [string range $name 6 end]
1249 set headids($name) $id
1250 lappend idheads($id) $name
1251 } elseif {[string match "tags/*" $name]} {
1252 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1253 # which is what we want since the former is the commit ID
1254 set name [string range $name 5 end]
1255 if {[string match "*^{}" $name]} {
1256 set name [string range $name 0 end-3]
1258 set tagobjid($name) $id
1260 set tagids($name) $id
1261 lappend idtags($id) $name
1263 set otherrefids($name) $id
1264 lappend idotherrefs($id) $name
1271 set thehead [exec git symbolic-ref HEAD]
1272 if {[string match "refs/heads/*" $thehead]} {
1273 set mainhead [string range $thehead 11 end]
1274 if {[info exists headids($mainhead)]} {
1275 set mainheadid $headids($mainhead)
1281 # skip over fake commits
1282 proc first_real_row {} {
1283 global nullid nullid2 numcommits
1285 for {set row 0} {$row < $numcommits} {incr row} {
1286 set id [commitonrow $row]
1287 if {$id ne $nullid && $id ne $nullid2} {
1294 # update things for a head moved to a child of its previous location
1295 proc movehead {id name} {
1296 global headids idheads
1298 removehead $headids($name) $name
1299 set headids($name) $id
1300 lappend idheads($id) $name
1303 # update things when a head has been removed
1304 proc removehead {id name} {
1305 global headids idheads
1307 if {$idheads($id) eq $name} {
1310 set i [lsearch -exact $idheads($id) $name]
1312 set idheads($id) [lreplace $idheads($id) $i $i]
1315 unset headids($name)
1318 proc show_error {w top msg} {
1319 message $w.m -text $msg -justify center -aspect 400
1320 pack $w.m -side top -fill x -padx 20 -pady 20
1321 button $w.ok -text [mc OK] -command "destroy $top"
1322 pack $w.ok -side bottom -fill x
1323 bind $top <Visibility> "grab $top; focus $top"
1324 bind $top <Key-Return> "destroy $top"
1328 proc error_popup msg {
1332 show_error $w $w $msg
1335 proc confirm_popup msg {
1341 message $w.m -text $msg -justify center -aspect 400
1342 pack $w.m -side top -fill x -padx 20 -pady 20
1343 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1344 pack $w.ok -side left -fill x
1345 button $w.cancel -text [mc Cancel] -command "destroy $w"
1346 pack $w.cancel -side right -fill x
1347 bind $w <Visibility> "grab $w; focus $w"
1352 proc setoptions {} {
1353 option add *Panedwindow.showHandle 1 startupFile
1354 option add *Panedwindow.sashRelief raised startupFile
1355 option add *Button.font uifont startupFile
1356 option add *Checkbutton.font uifont startupFile
1357 option add *Radiobutton.font uifont startupFile
1358 option add *Menu.font uifont startupFile
1359 option add *Menubutton.font uifont startupFile
1360 option add *Label.font uifont startupFile
1361 option add *Message.font uifont startupFile
1362 option add *Entry.font uifont startupFile
1365 proc makewindow {} {
1366 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1368 global findtype findtypemenu findloc findstring fstring geometry
1369 global entries sha1entry sha1string sha1but
1370 global diffcontextstring diffcontext
1371 global maincursor textcursor curtextcursor
1372 global rowctxmenu fakerowmenu mergemax wrapcomment
1373 global highlight_files gdttype
1374 global searchstring sstring
1375 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1376 global headctxmenu progresscanv progressitem progresscoords statusw
1377 global fprogitem fprogcoord lastprogupdate progupdatepending
1378 global rprogitem rprogcoord
1382 .bar add cascade -label [mc "File"] -menu .bar.file
1384 .bar.file add command -label [mc "Update"] -command updatecommits
1385 .bar.file add command -label [mc "Reload"] -command reloadcommits
1386 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1387 .bar.file add command -label [mc "List references"] -command showrefs
1388 .bar.file add command -label [mc "Quit"] -command doquit
1390 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1391 .bar.edit add command -label [mc "Preferences"] -command doprefs
1394 .bar add cascade -label [mc "View"] -menu .bar.view
1395 .bar.view add command -label [mc "New view..."] -command {newview 0}
1396 .bar.view add command -label [mc "Edit view..."] -command editview \
1398 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1399 .bar.view add separator
1400 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1401 -variable selectedview -value 0
1404 .bar add cascade -label [mc "Help"] -menu .bar.help
1405 .bar.help add command -label [mc "About gitk"] -command about
1406 .bar.help add command -label [mc "Key bindings"] -command keys
1408 . configure -menu .bar
1410 # the gui has upper and lower half, parts of a paned window.
1411 panedwindow .ctop -orient vertical
1413 # possibly use assumed geometry
1414 if {![info exists geometry(pwsash0)]} {
1415 set geometry(topheight) [expr {15 * $linespc}]
1416 set geometry(topwidth) [expr {80 * $charspc}]
1417 set geometry(botheight) [expr {15 * $linespc}]
1418 set geometry(botwidth) [expr {50 * $charspc}]
1419 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1420 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1423 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1424 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1426 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1428 # create three canvases
1429 set cscroll .tf.histframe.csb
1430 set canv .tf.histframe.pwclist.canv
1432 -selectbackground $selectbgcolor \
1433 -background $bgcolor -bd 0 \
1434 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1435 .tf.histframe.pwclist add $canv
1436 set canv2 .tf.histframe.pwclist.canv2
1438 -selectbackground $selectbgcolor \
1439 -background $bgcolor -bd 0 -yscrollincr $linespc
1440 .tf.histframe.pwclist add $canv2
1441 set canv3 .tf.histframe.pwclist.canv3
1443 -selectbackground $selectbgcolor \
1444 -background $bgcolor -bd 0 -yscrollincr $linespc
1445 .tf.histframe.pwclist add $canv3
1446 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1447 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1449 # a scroll bar to rule them
1450 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1451 pack $cscroll -side right -fill y
1452 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1453 lappend bglist $canv $canv2 $canv3
1454 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1456 # we have two button bars at bottom of top frame. Bar 1
1458 frame .tf.lbar -height 15
1460 set sha1entry .tf.bar.sha1
1461 set entries $sha1entry
1462 set sha1but .tf.bar.sha1label
1463 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1464 -command gotocommit -width 8
1465 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1466 pack .tf.bar.sha1label -side left
1467 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1468 trace add variable sha1string write sha1change
1469 pack $sha1entry -side left -pady 2
1471 image create bitmap bm-left -data {
1472 #define left_width 16
1473 #define left_height 16
1474 static unsigned char left_bits[] = {
1475 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1476 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1477 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1479 image create bitmap bm-right -data {
1480 #define right_width 16
1481 #define right_height 16
1482 static unsigned char right_bits[] = {
1483 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1484 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1485 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1487 button .tf.bar.leftbut -image bm-left -command goback \
1488 -state disabled -width 26
1489 pack .tf.bar.leftbut -side left -fill y
1490 button .tf.bar.rightbut -image bm-right -command goforw \
1491 -state disabled -width 26
1492 pack .tf.bar.rightbut -side left -fill y
1494 # Status label and progress bar
1495 set statusw .tf.bar.status
1496 label $statusw -width 15 -relief sunken
1497 pack $statusw -side left -padx 5
1498 set h [expr {[font metrics uifont -linespace] + 2}]
1499 set progresscanv .tf.bar.progress
1500 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1501 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1502 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1503 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1504 pack $progresscanv -side right -expand 1 -fill x
1505 set progresscoords {0 0}
1508 bind $progresscanv <Configure> adjustprogress
1509 set lastprogupdate [clock clicks -milliseconds]
1510 set progupdatepending 0
1512 # build up the bottom bar of upper window
1513 label .tf.lbar.flabel -text "[mc "Find"] "
1514 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1515 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1516 label .tf.lbar.flab2 -text " [mc "commit"] "
1517 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1519 set gdttype [mc "containing:"]
1520 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1521 [mc "containing:"] \
1522 [mc "touching paths:"] \
1523 [mc "adding/removing string:"]]
1524 trace add variable gdttype write gdttype_change
1525 pack .tf.lbar.gdttype -side left -fill y
1528 set fstring .tf.lbar.findstring
1529 lappend entries $fstring
1530 entry $fstring -width 30 -font textfont -textvariable findstring
1531 trace add variable findstring write find_change
1532 set findtype [mc "Exact"]
1533 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1534 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1535 trace add variable findtype write findcom_change
1536 set findloc [mc "All fields"]
1537 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1538 [mc "Comments"] [mc "Author"] [mc "Committer"]
1539 trace add variable findloc write find_change
1540 pack .tf.lbar.findloc -side right
1541 pack .tf.lbar.findtype -side right
1542 pack $fstring -side left -expand 1 -fill x
1544 # Finish putting the upper half of the viewer together
1545 pack .tf.lbar -in .tf -side bottom -fill x
1546 pack .tf.bar -in .tf -side bottom -fill x
1547 pack .tf.histframe -fill both -side top -expand 1
1549 .ctop paneconfigure .tf -height $geometry(topheight)
1550 .ctop paneconfigure .tf -width $geometry(topwidth)
1552 # now build up the bottom
1553 panedwindow .pwbottom -orient horizontal
1555 # lower left, a text box over search bar, scroll bar to the right
1556 # if we know window height, then that will set the lower text height, otherwise
1557 # we set lower text height which will drive window height
1558 if {[info exists geometry(main)]} {
1559 frame .bleft -width $geometry(botwidth)
1561 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1566 button .bleft.top.search -text [mc "Search"] -command dosearch
1567 pack .bleft.top.search -side left -padx 5
1568 set sstring .bleft.top.sstring
1569 entry $sstring -width 20 -font textfont -textvariable searchstring
1570 lappend entries $sstring
1571 trace add variable searchstring write incrsearch
1572 pack $sstring -side left -expand 1 -fill x
1573 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1574 -command changediffdisp -variable diffelide -value {0 0}
1575 radiobutton .bleft.mid.old -text [mc "Old version"] \
1576 -command changediffdisp -variable diffelide -value {0 1}
1577 radiobutton .bleft.mid.new -text [mc "New version"] \
1578 -command changediffdisp -variable diffelide -value {1 0}
1579 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1580 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1581 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1582 -from 1 -increment 1 -to 10000000 \
1583 -validate all -validatecommand "diffcontextvalidate %P" \
1584 -textvariable diffcontextstring
1585 .bleft.mid.diffcontext set $diffcontext
1586 trace add variable diffcontextstring write diffcontextchange
1587 lappend entries .bleft.mid.diffcontext
1588 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1589 set ctext .bleft.ctext
1590 text $ctext -background $bgcolor -foreground $fgcolor \
1591 -state disabled -font textfont \
1592 -yscrollcommand scrolltext -wrap none
1594 $ctext conf -tabstyle wordprocessor
1596 scrollbar .bleft.sb -command "$ctext yview"
1597 pack .bleft.top -side top -fill x
1598 pack .bleft.mid -side top -fill x
1599 pack .bleft.sb -side right -fill y
1600 pack $ctext -side left -fill both -expand 1
1601 lappend bglist $ctext
1602 lappend fglist $ctext
1604 $ctext tag conf comment -wrap $wrapcomment
1605 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1606 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1607 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1608 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1609 $ctext tag conf m0 -fore red
1610 $ctext tag conf m1 -fore blue
1611 $ctext tag conf m2 -fore green
1612 $ctext tag conf m3 -fore purple
1613 $ctext tag conf m4 -fore brown
1614 $ctext tag conf m5 -fore "#009090"
1615 $ctext tag conf m6 -fore magenta
1616 $ctext tag conf m7 -fore "#808000"
1617 $ctext tag conf m8 -fore "#009000"
1618 $ctext tag conf m9 -fore "#ff0080"
1619 $ctext tag conf m10 -fore cyan
1620 $ctext tag conf m11 -fore "#b07070"
1621 $ctext tag conf m12 -fore "#70b0f0"
1622 $ctext tag conf m13 -fore "#70f0b0"
1623 $ctext tag conf m14 -fore "#f0b070"
1624 $ctext tag conf m15 -fore "#ff70b0"
1625 $ctext tag conf mmax -fore darkgrey
1627 $ctext tag conf mresult -font textfontbold
1628 $ctext tag conf msep -font textfontbold
1629 $ctext tag conf found -back yellow
1631 .pwbottom add .bleft
1632 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1637 radiobutton .bright.mode.patch -text [mc "Patch"] \
1638 -command reselectline -variable cmitmode -value "patch"
1639 radiobutton .bright.mode.tree -text [mc "Tree"] \
1640 -command reselectline -variable cmitmode -value "tree"
1641 grid .bright.mode.patch .bright.mode.tree -sticky ew
1642 pack .bright.mode -side top -fill x
1643 set cflist .bright.cfiles
1644 set indent [font measure mainfont "nn"]
1646 -selectbackground $selectbgcolor \
1647 -background $bgcolor -foreground $fgcolor \
1649 -tabs [list $indent [expr {2 * $indent}]] \
1650 -yscrollcommand ".bright.sb set" \
1651 -cursor [. cget -cursor] \
1652 -spacing1 1 -spacing3 1
1653 lappend bglist $cflist
1654 lappend fglist $cflist
1655 scrollbar .bright.sb -command "$cflist yview"
1656 pack .bright.sb -side right -fill y
1657 pack $cflist -side left -fill both -expand 1
1658 $cflist tag configure highlight \
1659 -background [$cflist cget -selectbackground]
1660 $cflist tag configure bold -font mainfontbold
1662 .pwbottom add .bright
1665 # restore window position if known
1666 if {[info exists geometry(main)]} {
1667 wm geometry . "$geometry(main)"
1670 if {[tk windowingsystem] eq {aqua}} {
1676 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1677 pack .ctop -fill both -expand 1
1678 bindall <1> {selcanvline %W %x %y}
1679 #bindall <B1-Motion> {selcanvline %W %x %y}
1680 if {[tk windowingsystem] == "win32"} {
1681 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1682 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1684 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1685 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1686 if {[tk windowingsystem] eq "aqua"} {
1687 bindall <MouseWheel> {
1688 set delta [expr {- (%D)}]
1689 allcanvs yview scroll $delta units
1693 bindall <2> "canvscan mark %W %x %y"
1694 bindall <B2-Motion> "canvscan dragto %W %x %y"
1695 bindkey <Home> selfirstline
1696 bindkey <End> sellastline
1697 bind . <Key-Up> "selnextline -1"
1698 bind . <Key-Down> "selnextline 1"
1699 bind . <Shift-Key-Up> "dofind -1 0"
1700 bind . <Shift-Key-Down> "dofind 1 0"
1701 bindkey <Key-Right> "goforw"
1702 bindkey <Key-Left> "goback"
1703 bind . <Key-Prior> "selnextpage -1"
1704 bind . <Key-Next> "selnextpage 1"
1705 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1706 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1707 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1708 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1709 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1710 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1711 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1712 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1713 bindkey <Key-space> "$ctext yview scroll 1 pages"
1714 bindkey p "selnextline -1"
1715 bindkey n "selnextline 1"
1718 bindkey i "selnextline -1"
1719 bindkey k "selnextline 1"
1722 bindkey b "$ctext yview scroll -1 pages"
1723 bindkey d "$ctext yview scroll 18 units"
1724 bindkey u "$ctext yview scroll -18 units"
1725 bindkey / {dofind 1 1}
1726 bindkey <Key-Return> {dofind 1 1}
1727 bindkey ? {dofind -1 1}
1729 bindkey <F5> updatecommits
1730 bind . <$M1B-q> doquit
1731 bind . <$M1B-f> {dofind 1 1}
1732 bind . <$M1B-g> {dofind 1 0}
1733 bind . <$M1B-r> dosearchback
1734 bind . <$M1B-s> dosearch
1735 bind . <$M1B-equal> {incrfont 1}
1736 bind . <$M1B-KP_Add> {incrfont 1}
1737 bind . <$M1B-minus> {incrfont -1}
1738 bind . <$M1B-KP_Subtract> {incrfont -1}
1739 wm protocol . WM_DELETE_WINDOW doquit
1740 bind . <Button-1> "click %W"
1741 bind $fstring <Key-Return> {dofind 1 1}
1742 bind $sha1entry <Key-Return> gotocommit
1743 bind $sha1entry <<PasteSelection>> clearsha1
1744 bind $cflist <1> {sel_flist %W %x %y; break}
1745 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1746 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1747 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1749 set maincursor [. cget -cursor]
1750 set textcursor [$ctext cget -cursor]
1751 set curtextcursor $textcursor
1753 set rowctxmenu .rowctxmenu
1754 menu $rowctxmenu -tearoff 0
1755 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1756 -command {diffvssel 0}
1757 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1758 -command {diffvssel 1}
1759 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1760 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1761 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1762 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1763 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1765 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1768 set fakerowmenu .fakerowmenu
1769 menu $fakerowmenu -tearoff 0
1770 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1771 -command {diffvssel 0}
1772 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1773 -command {diffvssel 1}
1774 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1775 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1776 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1777 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1779 set headctxmenu .headctxmenu
1780 menu $headctxmenu -tearoff 0
1781 $headctxmenu add command -label [mc "Check out this branch"] \
1783 $headctxmenu add command -label [mc "Remove this branch"] \
1787 set flist_menu .flistctxmenu
1788 menu $flist_menu -tearoff 0
1789 $flist_menu add command -label [mc "Highlight this too"] \
1790 -command {flist_hl 0}
1791 $flist_menu add command -label [mc "Highlight this only"] \
1792 -command {flist_hl 1}
1795 # Windows sends all mouse wheel events to the current focused window, not
1796 # the one where the mouse hovers, so bind those events here and redirect
1797 # to the correct window
1798 proc windows_mousewheel_redirector {W X Y D} {
1799 global canv canv2 canv3
1800 set w [winfo containing -displayof $W $X $Y]
1802 set u [expr {$D < 0 ? 5 : -5}]
1803 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1804 allcanvs yview scroll $u units
1807 $w yview scroll $u units
1813 # mouse-2 makes all windows scan vertically, but only the one
1814 # the cursor is in scans horizontally
1815 proc canvscan {op w x y} {
1816 global canv canv2 canv3
1817 foreach c [list $canv $canv2 $canv3] {
1826 proc scrollcanv {cscroll f0 f1} {
1827 $cscroll set $f0 $f1
1832 # when we make a key binding for the toplevel, make sure
1833 # it doesn't get triggered when that key is pressed
in the
1834 # find string entry widget.
1835 proc bindkey
{ev
script} {
1838 set escript
[bind Entry
$ev]
1839 if {$escript == {}} {
1840 set escript
[bind Entry
<Key
>]
1842 foreach e
$entries {
1843 bind $e $ev "$escript; break"
1847 # set the focus back to the toplevel for any click outside
1850 global ctext entries
1851 foreach e
[concat
$entries $ctext] {
1852 if {$w == $e} return
1857 # Adjust the progress bar for a change in requested extent or canvas size
1858 proc adjustprogress
{} {
1859 global progresscanv progressitem progresscoords
1860 global fprogitem fprogcoord lastprogupdate progupdatepending
1861 global rprogitem rprogcoord
1863 set w
[expr {[winfo width
$progresscanv] - 4}]
1864 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1865 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1866 set h
[winfo height
$progresscanv]
1867 $progresscanv coords
$progressitem $x0 0 $x1 $h
1868 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1869 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1870 set now
[clock clicks
-milliseconds]
1871 if {$now >= $lastprogupdate + 100} {
1872 set progupdatepending
0
1874 } elseif
{!$progupdatepending} {
1875 set progupdatepending
1
1876 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1880 proc doprogupdate
{} {
1881 global lastprogupdate progupdatepending
1883 if {$progupdatepending} {
1884 set progupdatepending
0
1885 set lastprogupdate
[clock clicks
-milliseconds]
1890 proc savestuff
{w
} {
1891 global canv canv2 canv3 mainfont textfont uifont tabstop
1892 global stuffsaved findmergefiles maxgraphpct
1893 global maxwidth showneartags showlocalchanges
1894 global viewname viewfiles viewargs viewperm nextviewnum
1895 global cmitmode wrapcomment datetimeformat limitdiffs
1896 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1898 if {$stuffsaved} return
1899 if {![winfo viewable .
]} return
1901 set f
[open
"~/.gitk-new" w
]
1902 puts
$f [list
set mainfont
$mainfont]
1903 puts
$f [list
set textfont
$textfont]
1904 puts
$f [list
set uifont
$uifont]
1905 puts
$f [list
set tabstop
$tabstop]
1906 puts
$f [list
set findmergefiles
$findmergefiles]
1907 puts
$f [list
set maxgraphpct
$maxgraphpct]
1908 puts
$f [list
set maxwidth
$maxwidth]
1909 puts
$f [list
set cmitmode
$cmitmode]
1910 puts
$f [list
set wrapcomment
$wrapcomment]
1911 puts
$f [list
set showneartags
$showneartags]
1912 puts
$f [list
set showlocalchanges
$showlocalchanges]
1913 puts
$f [list
set datetimeformat
$datetimeformat]
1914 puts
$f [list
set limitdiffs
$limitdiffs]
1915 puts
$f [list
set bgcolor
$bgcolor]
1916 puts
$f [list
set fgcolor
$fgcolor]
1917 puts
$f [list
set colors
$colors]
1918 puts
$f [list
set diffcolors
$diffcolors]
1919 puts
$f [list
set diffcontext
$diffcontext]
1920 puts
$f [list
set selectbgcolor
$selectbgcolor]
1922 puts
$f "set geometry(main) [wm geometry .]"
1923 puts
$f "set geometry(topwidth) [winfo width .tf]"
1924 puts
$f "set geometry(topheight) [winfo height .tf]"
1925 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1926 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1927 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1928 puts
$f "set geometry(botheight) [winfo height .bleft]"
1930 puts
-nonewline $f "set permviews {"
1931 for {set v
0} {$v < $nextviewnum} {incr v
} {
1932 if {$viewperm($v)} {
1933 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1938 file rename
-force "~/.gitk-new" "~/.gitk"
1943 proc resizeclistpanes
{win w
} {
1945 if {[info exists oldwidth
($win)]} {
1946 set s0
[$win sash coord
0]
1947 set s1
[$win sash coord
1]
1949 set sash0
[expr {int
($w/2 - 2)}]
1950 set sash1
[expr {int
($w*5/6 - 2)}]
1952 set factor [expr {1.0 * $w / $oldwidth($win)}]
1953 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1954 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1958 if {$sash1 < $sash0 + 20} {
1959 set sash1
[expr {$sash0 + 20}]
1961 if {$sash1 > $w - 10} {
1962 set sash1
[expr {$w - 10}]
1963 if {$sash0 > $sash1 - 20} {
1964 set sash0
[expr {$sash1 - 20}]
1968 $win sash place
0 $sash0 [lindex
$s0 1]
1969 $win sash place
1 $sash1 [lindex
$s1 1]
1971 set oldwidth
($win) $w
1974 proc resizecdetpanes
{win w
} {
1976 if {[info exists oldwidth
($win)]} {
1977 set s0
[$win sash coord
0]
1979 set sash0
[expr {int
($w*3/4 - 2)}]
1981 set factor [expr {1.0 * $w / $oldwidth($win)}]
1982 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1986 if {$sash0 > $w - 15} {
1987 set sash0
[expr {$w - 15}]
1990 $win sash place
0 $sash0 [lindex
$s0 1]
1992 set oldwidth
($win) $w
1995 proc allcanvs args
{
1996 global canv canv2 canv3
2002 proc bindall
{event action
} {
2003 global canv canv2 canv3
2004 bind $canv $event $action
2005 bind $canv2 $event $action
2006 bind $canv3 $event $action
2012 if {[winfo exists
$w]} {
2017 wm title
$w [mc
"About gitk"]
2018 message
$w.m
-text [mc
"
2019 Gitk - a commit viewer for git
2021 Copyright © 2005-2006 Paul Mackerras
2023 Use and redistribute under the terms of the GNU General Public License"] \
2024 -justify center
-aspect 400 -border 2 -bg white
-relief groove
2025 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
2026 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2027 pack
$w.ok
-side bottom
2028 bind $w <Visibility
> "focus $w.ok"
2029 bind $w <Key-Escape
> "destroy $w"
2030 bind $w <Key-Return
> "destroy $w"
2035 if {[winfo exists
$w]} {
2039 if {[tk windowingsystem
] eq
{aqua
}} {
2045 wm title
$w [mc
"Gitk key bindings"]
2046 message
$w.m
-text [mc
"
2050 <Home> Move to first commit
2051 <End> Move to last commit
2052 <Up>, p, i Move up one commit
2053 <Down>, n, k Move down one commit
2054 <Left>, z, j Go back in history list
2055 <Right>, x, l Go forward in history list
2056 <PageUp> Move up one page in commit list
2057 <PageDown> Move down one page in commit list
2058 <$M1T-Home> Scroll to top of commit list
2059 <$M1T-End> Scroll to bottom of commit list
2060 <$M1T-Up> Scroll commit list up one line
2061 <$M1T-Down> Scroll commit list down one line
2062 <$M1T-PageUp> Scroll commit list up one page
2063 <$M1T-PageDown> Scroll commit list down one page
2064 <Shift-Up> Find backwards (upwards, later commits)
2065 <Shift-Down> Find forwards (downwards, earlier commits)
2066 <Delete>, b Scroll diff view up one page
2067 <Backspace> Scroll diff view up one page
2068 <Space> Scroll diff view down one page
2069 u Scroll diff view up 18 lines
2070 d Scroll diff view down 18 lines
2072 <$M1T-G> Move to next find hit
2073 <Return> Move to next find hit
2074 / Move to next find hit, or redo find
2075 ? Move to previous find hit
2076 f Scroll diff view to next file
2077 <$M1T-S> Search for next hit in diff view
2078 <$M1T-R> Search for previous hit in diff view
2079 <$M1T-KP+> Increase font size
2080 <$M1T-plus> Increase font size
2081 <$M1T-KP-> Decrease font size
2082 <$M1T-minus> Decrease font size
2085 -justify left
-bg white
-border 2 -relief groove
2086 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
2087 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2088 pack
$w.ok
-side bottom
2089 bind $w <Visibility
> "focus $w.ok"
2090 bind $w <Key-Escape
> "destroy $w"
2091 bind $w <Key-Return
> "destroy $w"
2094 # Procedures for manipulating the file list window at the
2095 # bottom right of the overall window.
2097 proc treeview
{w l openlevs
} {
2098 global treecontents treediropen treeheight treeparent treeindex
2108 set treecontents
() {}
2109 $w conf
-state normal
2111 while {[string range
$f 0 $prefixend] ne
$prefix} {
2112 if {$lev <= $openlevs} {
2113 $w mark
set e
:$treeindex($prefix) "end -1c"
2114 $w mark gravity e
:$treeindex($prefix) left
2116 set treeheight
($prefix) $ht
2117 incr ht
[lindex
$htstack end
]
2118 set htstack
[lreplace
$htstack end end
]
2119 set prefixend
[lindex
$prefendstack end
]
2120 set prefendstack
[lreplace
$prefendstack end end
]
2121 set prefix
[string range
$prefix 0 $prefixend]
2124 set tail [string range
$f [expr {$prefixend+1}] end
]
2125 while {[set slash
[string first
"/" $tail]] >= 0} {
2128 lappend prefendstack
$prefixend
2129 incr prefixend
[expr {$slash + 1}]
2130 set d
[string range
$tail 0 $slash]
2131 lappend treecontents
($prefix) $d
2132 set oldprefix
$prefix
2134 set treecontents
($prefix) {}
2135 set treeindex
($prefix) [incr ix
]
2136 set treeparent
($prefix) $oldprefix
2137 set tail [string range
$tail [expr {$slash+1}] end
]
2138 if {$lev <= $openlevs} {
2140 set treediropen
($prefix) [expr {$lev < $openlevs}]
2141 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
2142 $w mark
set d
:$ix "end -1c"
2143 $w mark gravity d
:$ix left
2145 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2147 $w image create end
-align center
-image $bm -padx 1 \
2149 $w insert end
$d [highlight_tag
$prefix]
2150 $w mark
set s
:$ix "end -1c"
2151 $w mark gravity s
:$ix left
2156 if {$lev <= $openlevs} {
2159 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2161 $w insert end
$tail [highlight_tag
$f]
2163 lappend treecontents
($prefix) $tail
2166 while {$htstack ne
{}} {
2167 set treeheight
($prefix) $ht
2168 incr ht
[lindex
$htstack end
]
2169 set htstack
[lreplace
$htstack end end
]
2170 set prefixend
[lindex
$prefendstack end
]
2171 set prefendstack
[lreplace
$prefendstack end end
]
2172 set prefix
[string range
$prefix 0 $prefixend]
2174 $w conf
-state disabled
2177 proc linetoelt
{l
} {
2178 global treeheight treecontents
2183 foreach e
$treecontents($prefix) {
2188 if {[string index
$e end
] eq
"/"} {
2189 set n
$treeheight($prefix$e)
2201 proc highlight_tree
{y prefix
} {
2202 global treeheight treecontents cflist
2204 foreach e
$treecontents($prefix) {
2206 if {[highlight_tag
$path] ne
{}} {
2207 $cflist tag add bold
$y.0 "$y.0 lineend"
2210 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
2211 set y
[highlight_tree
$y $path]
2217 proc treeclosedir
{w dir
} {
2218 global treediropen treeheight treeparent treeindex
2220 set ix
$treeindex($dir)
2221 $w conf
-state normal
2222 $w delete s
:$ix e
:$ix
2223 set treediropen
($dir) 0
2224 $w image configure a
:$ix -image tri-rt
2225 $w conf
-state disabled
2226 set n
[expr {1 - $treeheight($dir)}]
2227 while {$dir ne
{}} {
2228 incr treeheight
($dir) $n
2229 set dir
$treeparent($dir)
2233 proc treeopendir
{w dir
} {
2234 global treediropen treeheight treeparent treecontents treeindex
2236 set ix
$treeindex($dir)
2237 $w conf
-state normal
2238 $w image configure a
:$ix -image tri-dn
2239 $w mark
set e
:$ix s
:$ix
2240 $w mark gravity e
:$ix right
2243 set n
[llength
$treecontents($dir)]
2244 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
2247 incr treeheight
($x) $n
2249 foreach e
$treecontents($dir) {
2251 if {[string index
$e end
] eq
"/"} {
2252 set iy
$treeindex($de)
2253 $w mark
set d
:$iy e
:$ix
2254 $w mark gravity d
:$iy left
2255 $w insert e
:$ix $str
2256 set treediropen
($de) 0
2257 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
2259 $w insert e
:$ix $e [highlight_tag
$de]
2260 $w mark
set s
:$iy e
:$ix
2261 $w mark gravity s
:$iy left
2262 set treeheight
($de) 1
2264 $w insert e
:$ix $str
2265 $w insert e
:$ix $e [highlight_tag
$de]
2268 $w mark gravity e
:$ix left
2269 $w conf
-state disabled
2270 set treediropen
($dir) 1
2271 set top
[lindex
[split [$w index @
0,0] .
] 0]
2272 set ht
[$w cget
-height]
2273 set l
[lindex
[split [$w index s
:$ix] .
] 0]
2276 } elseif
{$l + $n + 1 > $top + $ht} {
2277 set top
[expr {$l + $n + 2 - $ht}]
2285 proc treeclick
{w x y
} {
2286 global treediropen cmitmode ctext cflist cflist_top
2288 if {$cmitmode ne
"tree"} return
2289 if {![info exists cflist_top
]} return
2290 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2291 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2292 $cflist tag add highlight
$l.0 "$l.0 lineend"
2298 set e
[linetoelt
$l]
2299 if {[string index
$e end
] ne
"/"} {
2301 } elseif
{$treediropen($e)} {
2308 proc setfilelist
{id
} {
2309 global treefilelist cflist
2311 treeview
$cflist $treefilelist($id) 0
2314 image create bitmap tri-rt
-background black
-foreground blue
-data {
2315 #define tri-rt_width 13
2316 #define tri-rt_height 13
2317 static unsigned char tri-rt_bits
[] = {
2318 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2319 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2322 #define tri-rt-mask_width 13
2323 #define tri-rt-mask_height 13
2324 static unsigned char tri-rt-mask_bits
[] = {
2325 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2326 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2329 image create bitmap tri-dn
-background black
-foreground blue
-data {
2330 #define tri-dn_width 13
2331 #define tri-dn_height 13
2332 static unsigned char tri-dn_bits
[] = {
2333 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2334 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2337 #define tri-dn-mask_width 13
2338 #define tri-dn-mask_height 13
2339 static unsigned char tri-dn-mask_bits
[] = {
2340 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2341 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2345 image create bitmap reficon-T
-background black
-foreground yellow
-data {
2346 #define tagicon_width 13
2347 #define tagicon_height 9
2348 static unsigned char tagicon_bits
[] = {
2349 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2350 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2352 #define tagicon-mask_width 13
2353 #define tagicon-mask_height 9
2354 static unsigned char tagicon-mask_bits
[] = {
2355 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2356 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2359 #define headicon_width 13
2360 #define headicon_height 9
2361 static unsigned char headicon_bits
[] = {
2362 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2363 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2366 #define headicon-mask_width 13
2367 #define headicon-mask_height 9
2368 static unsigned char headicon-mask_bits
[] = {
2369 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2370 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2372 image create bitmap reficon-H
-background black
-foreground green \
2373 -data $rectdata -maskdata $rectmask
2374 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
2375 -data $rectdata -maskdata $rectmask
2377 proc init_flist
{first
} {
2378 global cflist cflist_top difffilestart
2380 $cflist conf
-state normal
2381 $cflist delete
0.0 end
2383 $cflist insert end
$first
2385 $cflist tag add highlight
1.0 "1.0 lineend"
2387 catch
{unset cflist_top
}
2389 $cflist conf
-state disabled
2390 set difffilestart
{}
2393 proc highlight_tag
{f
} {
2394 global highlight_paths
2396 foreach p
$highlight_paths {
2397 if {[string match
$p $f]} {
2404 proc highlight_filelist
{} {
2405 global cmitmode cflist
2407 $cflist conf
-state normal
2408 if {$cmitmode ne
"tree"} {
2409 set end
[lindex
[split [$cflist index end
] .
] 0]
2410 for {set l
2} {$l < $end} {incr l
} {
2411 set line
[$cflist get
$l.0 "$l.0 lineend"]
2412 if {[highlight_tag
$line] ne
{}} {
2413 $cflist tag add bold
$l.0 "$l.0 lineend"
2419 $cflist conf
-state disabled
2422 proc unhighlight_filelist
{} {
2425 $cflist conf
-state normal
2426 $cflist tag remove bold
1.0 end
2427 $cflist conf
-state disabled
2430 proc add_flist
{fl
} {
2433 $cflist conf
-state normal
2435 $cflist insert end
"\n"
2436 $cflist insert end
$f [highlight_tag
$f]
2438 $cflist conf
-state disabled
2441 proc sel_flist
{w x y
} {
2442 global ctext difffilestart cflist cflist_top cmitmode
2444 if {$cmitmode eq
"tree"} return
2445 if {![info exists cflist_top
]} return
2446 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2447 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2448 $cflist tag add highlight
$l.0 "$l.0 lineend"
2453 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
2457 proc pop_flist_menu
{w X Y x y
} {
2458 global ctext cflist cmitmode flist_menu flist_menu_file
2459 global treediffs diffids
2462 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2464 if {$cmitmode eq
"tree"} {
2465 set e
[linetoelt
$l]
2466 if {[string index
$e end
] eq
"/"} return
2468 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
2470 set flist_menu_file
$e
2471 tk_popup
$flist_menu $X $Y
2474 proc flist_hl
{only
} {
2475 global flist_menu_file findstring gdttype
2477 set x
[shellquote
$flist_menu_file]
2478 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
2481 append findstring
" " $x
2483 set gdttype
[mc
"touching paths:"]
2486 # Functions for adding and removing shell-type quoting
2488 proc shellquote
{str
} {
2489 if {![string match
"*\['\"\\ \t]*" $str]} {
2492 if {![string match
"*\['\"\\]*" $str]} {
2495 if {![string match
"*'*" $str]} {
2498 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2501 proc shellarglist
{l
} {
2507 append str
[shellquote
$a]
2512 proc shelldequote
{str
} {
2517 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
2518 append ret
[string range
$str $used end
]
2519 set used
[string length
$str]
2522 set first
[lindex
$first 0]
2523 set ch
[string index
$str $first]
2524 if {$first > $used} {
2525 append ret
[string range
$str $used [expr {$first - 1}]]
2528 if {$ch eq
" " ||
$ch eq
"\t"} break
2531 set first
[string first
"'" $str $used]
2533 error
"unmatched single-quote"
2535 append ret
[string range
$str $used [expr {$first - 1}]]
2540 if {$used >= [string length
$str]} {
2541 error
"trailing backslash"
2543 append ret
[string index
$str $used]
2548 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
2549 error
"unmatched double-quote"
2551 set first
[lindex
$first 0]
2552 set ch
[string index
$str $first]
2553 if {$first > $used} {
2554 append ret
[string range
$str $used [expr {$first - 1}]]
2557 if {$ch eq
"\""} break
2559 append ret
[string index
$str $used]
2563 return [list
$used $ret]
2566 proc shellsplit
{str
} {
2569 set str
[string trimleft
$str]
2570 if {$str eq
{}} break
2571 set dq
[shelldequote
$str]
2572 set n
[lindex
$dq 0]
2573 set word
[lindex
$dq 1]
2574 set str
[string range
$str $n end
]
2580 # Code to implement multiple views
2582 proc newview
{ishighlight
} {
2583 global nextviewnum newviewname newviewperm newishighlight
2584 global newviewargs revtreeargs
2586 set newishighlight
$ishighlight
2588 if {[winfo exists
$top]} {
2592 set newviewname
($nextviewnum) "View $nextviewnum"
2593 set newviewperm
($nextviewnum) 0
2594 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
2595 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
2600 global viewname viewperm newviewname newviewperm
2601 global viewargs newviewargs
2603 set top .gitkvedit-
$curview
2604 if {[winfo exists
$top]} {
2608 set newviewname
($curview) $viewname($curview)
2609 set newviewperm
($curview) $viewperm($curview)
2610 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
2611 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
2614 proc vieweditor
{top n title
} {
2615 global newviewname newviewperm viewfiles bgcolor
2618 wm title
$top $title
2619 label
$top.
nl -text [mc
"Name"]
2620 entry
$top.name
-width 20 -textvariable newviewname
($n)
2621 grid
$top.
nl $top.name
-sticky w
-pady 5
2622 checkbutton
$top.perm
-text [mc
"Remember this view"] \
2623 -variable newviewperm
($n)
2624 grid
$top.perm
- -pady 5 -sticky w
2625 message
$top.al
-aspect 1000 \
2626 -text [mc
"Commits to include (arguments to git rev-list):"]
2627 grid
$top.al
- -sticky w
-pady 5
2628 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
2629 -background $bgcolor
2630 grid
$top.args
- -sticky ew
-padx 5
2631 message
$top.l
-aspect 1000 \
2632 -text [mc
"Enter files and directories to include, one per line:"]
2633 grid
$top.l
- -sticky w
2634 text
$top.t
-width 40 -height 10 -background $bgcolor -font uifont
2635 if {[info exists viewfiles
($n)]} {
2636 foreach f
$viewfiles($n) {
2637 $top.t insert end
$f
2638 $top.t insert end
"\n"
2640 $top.t delete
{end
- 1c
} end
2641 $top.t mark
set insert
0.0
2643 grid
$top.t
- -sticky ew
-padx 5
2645 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n]
2646 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top]
2647 grid
$top.buts.ok
$top.buts.can
2648 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
2649 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
2650 grid
$top.buts
- -pady 10 -sticky ew
2654 proc doviewmenu
{m first cmd op argv
} {
2655 set nmenu
[$m index end
]
2656 for {set i
$first} {$i <= $nmenu} {incr i
} {
2657 if {[$m entrycget
$i -command] eq
$cmd} {
2658 eval $m $op $i $argv
2664 proc allviewmenus
{n op args
} {
2667 doviewmenu .bar.view
5 [list showview
$n] $op $args
2668 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2671 proc newviewok
{top n
} {
2672 global nextviewnum newviewperm newviewname newishighlight
2673 global viewname viewfiles viewperm selectedview curview
2674 global viewargs newviewargs viewhlmenu
2677 set newargs
[shellsplit
$newviewargs($n)]
2679 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
2685 foreach f
[split [$top.t get
0.0 end
] "\n"] {
2686 set ft
[string trim
$f]
2691 if {![info exists viewfiles
($n)]} {
2692 # creating a new view
2694 set viewname
($n) $newviewname($n)
2695 set viewperm
($n) $newviewperm($n)
2696 set viewfiles
($n) $files
2697 set viewargs
($n) $newargs
2699 if {!$newishighlight} {
2702 run addvhighlight
$n
2705 # editing an existing view
2706 set viewperm
($n) $newviewperm($n)
2707 if {$newviewname($n) ne
$viewname($n)} {
2708 set viewname
($n) $newviewname($n)
2709 doviewmenu .bar.view
5 [list showview
$n] \
2710 entryconf
[list
-label $viewname($n)]
2711 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2712 # entryconf [list -label $viewname($n) -value $viewname($n)]
2714 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n)} {
2715 set viewfiles
($n) $files
2716 set viewargs
($n) $newargs
2717 if {$curview == $n} {
2722 catch
{destroy
$top}
2726 global curview viewperm hlview selectedhlview
2728 if {$curview == 0} return
2729 if {[info exists hlview
] && $hlview == $curview} {
2730 set selectedhlview
[mc
"None"]
2733 allviewmenus
$curview delete
2734 set viewperm
($curview) 0
2738 proc addviewmenu
{n
} {
2739 global viewname viewhlmenu
2741 .bar.view add radiobutton
-label $viewname($n) \
2742 -command [list showview
$n] -variable selectedview
-value $n
2743 #$viewhlmenu add radiobutton -label $viewname($n) \
2744 # -command [list addvhighlight $n] -variable selectedhlview
2748 global curview viewfiles cached_commitrow ordertok
2749 global displayorder parentlist rowidlist rowisopt rowfinal
2750 global colormap rowtextx nextcolor canvxmax
2751 global numcommits viewcomplete
2752 global selectedline currentid canv canvy0
2754 global pending_select mainheadid
2757 global hlview selectedhlview commitinterest
2759 if {$n == $curview} return
2761 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2762 set span
[$canv yview
]
2763 set ytop
[expr {[lindex
$span 0] * $ymax}]
2764 set ybot
[expr {[lindex
$span 1] * $ymax}]
2765 set yscreen
[expr {($ybot - $ytop) / 2}]
2766 if {[info exists selectedline
]} {
2767 set selid
$currentid
2768 set y
[yc
$selectedline]
2769 if {$ytop < $y && $y < $ybot} {
2770 set yscreen
[expr {$y - $ytop}]
2772 } elseif
{[info exists pending_select
]} {
2773 set selid
$pending_select
2774 unset pending_select
2778 catch
{unset treediffs
}
2780 if {[info exists hlview
] && $hlview == $n} {
2782 set selectedhlview
[mc
"None"]
2784 catch
{unset commitinterest
}
2785 catch
{unset cached_commitrow
}
2786 catch
{unset ordertok
}
2790 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2791 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2794 if {![info exists viewcomplete
($n)]} {
2796 set pending_select
$selid
2807 set numcommits
$commitidx($n)
2809 catch
{unset colormap
}
2810 catch
{unset rowtextx
}
2812 set canvxmax
[$canv cget
-width]
2818 if {$selid ne
{} && [commitinview
$selid $n]} {
2819 set row
[rowofcommit
$selid]
2820 # try to get the selected row in the same position on the screen
2821 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2822 set ytop
[expr {[yc
$row] - $yscreen}]
2826 set yf
[expr {$ytop * 1.0 / $ymax}]
2828 allcanvs yview moveto
$yf
2832 } elseif
{$mainheadid ne
{} && [commitinview
$mainheadid $curview]} {
2833 selectline
[rowofcommit
$mainheadid] 1
2834 } elseif
{!$viewcomplete($n)} {
2836 set pending_select
$selid
2838 set pending_select
$mainheadid
2841 set row
[first_real_row
]
2842 if {$row < $numcommits} {
2846 if {!$viewcomplete($n)} {
2847 if {$numcommits == 0} {
2848 show_status
[mc
"Reading commits..."]
2850 } elseif
{$numcommits == 0} {
2851 show_status
[mc
"No commits selected"]
2855 # Stuff relating to the highlighting facility
2857 proc ishighlighted
{id
} {
2858 global vhighlights fhighlights nhighlights rhighlights
2860 if {[info exists nhighlights
($id)] && $nhighlights($id) > 0} {
2861 return $nhighlights($id)
2863 if {[info exists vhighlights
($id)] && $vhighlights($id) > 0} {
2864 return $vhighlights($id)
2866 if {[info exists fhighlights
($id)] && $fhighlights($id) > 0} {
2867 return $fhighlights($id)
2869 if {[info exists rhighlights
($id)] && $rhighlights($id) > 0} {
2870 return $rhighlights($id)
2875 proc bolden
{row font
} {
2876 global canv linehtag selectedline boldrows
2878 lappend boldrows
$row
2879 $canv itemconf
$linehtag($row) -font $font
2880 if {[info exists selectedline
] && $row == $selectedline} {
2882 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2883 -outline {{}} -tags secsel \
2884 -fill [$canv cget
-selectbackground]]
2889 proc bolden_name
{row font
} {
2890 global canv2 linentag selectedline boldnamerows
2892 lappend boldnamerows
$row
2893 $canv2 itemconf
$linentag($row) -font $font
2894 if {[info exists selectedline
] && $row == $selectedline} {
2895 $canv2 delete secsel
2896 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2897 -outline {{}} -tags secsel \
2898 -fill [$canv2 cget
-selectbackground]]
2907 foreach row
$boldrows {
2908 if {![ishighlighted
[commitonrow
$row]]} {
2909 bolden
$row mainfont
2911 lappend stillbold
$row
2914 set boldrows
$stillbold
2917 proc addvhighlight
{n
} {
2918 global hlview viewcomplete curview vhl_done commitidx
2920 if {[info exists hlview
]} {
2924 if {$n != $curview && ![info exists viewcomplete
($n)]} {
2927 set vhl_done
$commitidx($hlview)
2928 if {$vhl_done > 0} {
2933 proc delvhighlight
{} {
2934 global hlview vhighlights
2936 if {![info exists hlview
]} return
2938 catch
{unset vhighlights
}
2942 proc vhighlightmore
{} {
2943 global hlview vhl_done commitidx vhighlights curview
2945 set max
$commitidx($hlview)
2946 set vr
[visiblerows
]
2947 set r0
[lindex
$vr 0]
2948 set r1
[lindex
$vr 1]
2949 for {set i
$vhl_done} {$i < $max} {incr i
} {
2950 set id
[commitonrow
$i $hlview]
2951 if {[commitinview
$id $curview]} {
2952 set row
[rowofcommit
$id]
2953 if {$r0 <= $row && $row <= $r1} {
2954 if {![highlighted
$row]} {
2955 bolden
$row mainfontbold
2957 set vhighlights
($id) 1
2964 proc askvhighlight
{row id
} {
2965 global hlview vhighlights iddrawn
2967 if {[commitinview
$id $hlview]} {
2968 if {[info exists iddrawn
($id)] && ![ishighlighted
$id]} {
2969 bolden
$row mainfontbold
2971 set vhighlights
($id) 1
2973 set vhighlights
($id) 0
2977 proc hfiles_change
{} {
2978 global highlight_files filehighlight fhighlights fh_serial
2979 global highlight_paths gdttype
2981 if {[info exists filehighlight
]} {
2982 # delete previous highlights
2983 catch
{close
$filehighlight}
2985 catch
{unset fhighlights
}
2987 unhighlight_filelist
2989 set highlight_paths
{}
2990 after cancel do_file_hl
$fh_serial
2992 if {$highlight_files ne
{}} {
2993 after
300 do_file_hl
$fh_serial
2997 proc gdttype_change
{name ix op
} {
2998 global gdttype highlight_files findstring findpattern
3001 if {$findstring ne
{}} {
3002 if {$gdttype eq
[mc
"containing:"]} {
3003 if {$highlight_files ne
{}} {
3004 set highlight_files
{}
3009 if {$findpattern ne
{}} {
3013 set highlight_files
$findstring
3018 # enable/disable findtype/findloc menus too
3021 proc find_change
{name ix op
} {
3022 global gdttype findstring highlight_files
3025 if {$gdttype eq
[mc
"containing:"]} {
3028 if {$highlight_files ne
$findstring} {
3029 set highlight_files
$findstring
3036 proc findcom_change args
{
3037 global nhighlights boldnamerows
3038 global findpattern findtype findstring gdttype
3041 # delete previous highlights, if any
3042 foreach row
$boldnamerows {
3043 bolden_name
$row mainfont
3046 catch
{unset nhighlights
}
3049 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
3051 } elseif
{$findtype eq
[mc
"Regexp"]} {
3052 set findpattern
$findstring
3054 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3056 set findpattern
"*$e*"
3060 proc makepatterns
{l
} {
3063 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3064 if {[string index
$ee end
] eq
"/"} {
3074 proc do_file_hl
{serial
} {
3075 global highlight_files filehighlight highlight_paths gdttype fhl_list
3077 if {$gdttype eq
[mc
"touching paths:"]} {
3078 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
3079 set highlight_paths
[makepatterns
$paths]
3081 set gdtargs
[concat
-- $paths]
3082 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
3083 set gdtargs
[list
"-S$highlight_files"]
3085 # must be "containing:", i.e. we're searching commit info
3088 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
3089 set filehighlight
[open
$cmd r
+]
3090 fconfigure
$filehighlight -blocking 0
3091 filerun
$filehighlight readfhighlight
3097 proc flushhighlights
{} {
3098 global filehighlight fhl_list
3100 if {[info exists filehighlight
]} {
3102 puts
$filehighlight ""
3103 flush
$filehighlight
3107 proc askfilehighlight
{row id
} {
3108 global filehighlight fhighlights fhl_list
3110 lappend fhl_list
$id
3111 set fhighlights
($id) -1
3112 puts
$filehighlight $id
3115 proc readfhighlight
{} {
3116 global filehighlight fhighlights curview iddrawn
3117 global fhl_list find_dirn
3119 if {![info exists filehighlight
]} {
3123 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
3124 set line
[string trim
$line]
3125 set i
[lsearch
-exact $fhl_list $line]
3126 if {$i < 0} continue
3127 for {set j
0} {$j < $i} {incr j
} {
3128 set id
[lindex
$fhl_list $j]
3129 set fhighlights
($id) 0
3131 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
3132 if {$line eq
{}} continue
3133 if {![commitinview
$line $curview]} continue
3134 set row
[rowofcommit
$line]
3135 if {[info exists iddrawn
($line)] && ![ishighlighted
$line]} {
3136 bolden
$row mainfontbold
3138 set fhighlights
($line) 1
3140 if {[eof
$filehighlight]} {
3142 puts
"oops, git diff-tree died"
3143 catch
{close
$filehighlight}
3147 if {[info exists find_dirn
]} {
3153 proc doesmatch
{f
} {
3154 global findtype findpattern
3156 if {$findtype eq
[mc
"Regexp"]} {
3157 return [regexp
$findpattern $f]
3158 } elseif
{$findtype eq
[mc
"IgnCase"]} {
3159 return [string match
-nocase $findpattern $f]
3161 return [string match
$findpattern $f]
3165 proc askfindhighlight
{row id
} {
3166 global nhighlights commitinfo iddrawn
3168 global markingmatches
3170 if {![info exists commitinfo
($id)]} {
3173 set info
$commitinfo($id)
3175 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
3176 foreach f
$info ty
$fldtypes {
3177 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
3179 if {$ty eq
[mc
"Author"]} {
3186 if {$isbold && [info exists iddrawn
($id)]} {
3187 if {![ishighlighted
$id]} {
3188 bolden
$row mainfontbold
3190 bolden_name
$row mainfontbold
3193 if {$markingmatches} {
3194 markrowmatches
$row $id
3197 set nhighlights
($id) $isbold
3200 proc markrowmatches
{row id
} {
3201 global canv canv2 linehtag linentag commitinfo findloc
3203 set headline
[lindex
$commitinfo($id) 0]
3204 set author
[lindex
$commitinfo($id) 1]
3205 $canv delete match
$row
3206 $canv2 delete match
$row
3207 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
3208 set m
[findmatches
$headline]
3210 markmatches
$canv $row $headline $linehtag($row) $m \
3211 [$canv itemcget
$linehtag($row) -font] $row
3214 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
3215 set m
[findmatches
$author]
3217 markmatches
$canv2 $row $author $linentag($row) $m \
3218 [$canv2 itemcget
$linentag($row) -font] $row
3223 proc vrel_change
{name ix op
} {
3224 global highlight_related
3227 if {$highlight_related ne
[mc
"None"]} {
3232 # prepare for testing whether commits are descendents or ancestors of a
3233 proc rhighlight_sel
{a
} {
3234 global descendent desc_todo ancestor anc_todo
3235 global highlight_related
3237 catch
{unset descendent
}
3238 set desc_todo
[list
$a]
3239 catch
{unset ancestor
}
3240 set anc_todo
[list
$a]
3241 if {$highlight_related ne
[mc
"None"]} {
3247 proc rhighlight_none
{} {
3250 catch
{unset rhighlights
}
3254 proc is_descendent
{a
} {
3255 global curview children descendent desc_todo
3258 set la
[rowofcommit
$a]
3262 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3263 set do [lindex
$todo $i]
3264 if {[rowofcommit
$do] < $la} {
3265 lappend leftover
$do
3268 foreach nk
$children($v,$do) {
3269 if {![info exists descendent
($nk)]} {
3270 set descendent
($nk) 1
3278 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3282 set descendent
($a) 0
3283 set desc_todo
$leftover
3286 proc is_ancestor
{a
} {
3287 global curview parents ancestor anc_todo
3290 set la
[rowofcommit
$a]
3294 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3295 set do [lindex
$todo $i]
3296 if {![commitinview
$do $v] ||
[rowofcommit
$do] > $la} {
3297 lappend leftover
$do
3300 foreach np
$parents($v,$do) {
3301 if {![info exists ancestor
($np)]} {
3310 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3315 set anc_todo
$leftover
3318 proc askrelhighlight
{row id
} {
3319 global descendent highlight_related iddrawn rhighlights
3320 global selectedline ancestor
3322 if {![info exists selectedline
]} return
3324 if {$highlight_related eq
[mc
"Descendent"] ||
3325 $highlight_related eq
[mc
"Not descendent"]} {
3326 if {![info exists descendent
($id)]} {
3329 if {$descendent($id) == ($highlight_related eq
[mc
"Descendent"])} {
3332 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
3333 $highlight_related eq
[mc
"Not ancestor"]} {
3334 if {![info exists ancestor
($id)]} {
3337 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
3341 if {[info exists iddrawn
($id)]} {
3342 if {$isbold && ![ishighlighted
$id]} {
3343 bolden
$row mainfontbold
3346 set rhighlights
($id) $isbold
3349 # Graph layout functions
3351 proc shortids
{ids
} {
3354 if {[llength
$id] > 1} {
3355 lappend res
[shortids
$id]
3356 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
3357 lappend res
[string range
$id 0 7]
3368 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
3369 if {($n & $mask) != 0} {
3370 set ret
[concat
$ret $o]
3372 set o
[concat
$o $o]
3377 proc ordertoken
{id
} {
3378 global ordertok curview varcid varcstart varctok curview parents children
3379 global nullid nullid2
3381 if {[info exists ordertok
($id)]} {
3382 return $ordertok($id)
3387 if {[info exists varcid
($curview,$id)]} {
3388 set a
$varcid($curview,$id)
3389 set p
[lindex
$varcstart($curview) $a]
3391 set p
[lindex
$children($curview,$id) 0]
3393 if {[info exists ordertok
($p)]} {
3394 set tok
$ordertok($p)
3397 set id
[first_real_child
$curview,$p]
3400 set tok
[lindex
$varctok($curview) $varcid($curview,$p)]
3403 if {[llength
$parents($curview,$id)] == 1} {
3404 lappend todo
[list
$p {}]
3406 set j
[lsearch
-exact $parents($curview,$id) $p]
3408 puts
"oops didn't find [shortids $p] in parents of [shortids $id]"
3410 lappend todo
[list
$p [strrep
$j]]
3413 for {set i
[llength
$todo]} {[incr i
-1] >= 0} {} {
3414 set p
[lindex
$todo $i 0]
3415 append tok
[lindex
$todo $i 1]
3416 set ordertok
($p) $tok
3418 set ordertok
($origid) $tok
3422 # Work out where id should go in idlist so that order-token
3423 # values increase from left to right
3424 proc idcol
{idlist id
{i
0}} {
3425 set t
[ordertoken
$id]
3429 if {$i >= [llength
$idlist] ||
$t < [ordertoken
[lindex
$idlist $i]]} {
3430 if {$i > [llength
$idlist]} {
3431 set i
[llength
$idlist]
3433 while {[incr i
-1] >= 0 && $t < [ordertoken
[lindex
$idlist $i]]} {}
3436 if {$t > [ordertoken
[lindex
$idlist $i]]} {
3437 while {[incr i
] < [llength
$idlist] &&
3438 $t >= [ordertoken
[lindex
$idlist $i]]} {}
3444 proc initlayout
{} {
3445 global rowidlist rowisopt rowfinal displayorder parentlist
3446 global numcommits canvxmax canv
3448 global colormap rowtextx
3457 set canvxmax
[$canv cget
-width]
3458 catch
{unset colormap
}
3459 catch
{unset rowtextx
}
3462 proc setcanvscroll
{} {
3463 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3465 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3466 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
3467 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
3468 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
3471 proc visiblerows
{} {
3472 global canv numcommits linespc
3474 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3475 if {$ymax eq
{} ||
$ymax == 0} return
3477 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
3478 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
3482 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
3483 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
3484 if {$r1 >= $numcommits} {
3485 set r1
[expr {$numcommits - 1}]
3487 return [list
$r0 $r1]
3490 proc layoutmore
{} {
3491 global commitidx viewcomplete curview
3492 global numcommits pending_select selectedline curview
3493 global lastscrollset commitinterest
3495 set canshow
$commitidx($curview)
3496 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3497 if {$numcommits == 0} {
3501 set prev
$numcommits
3502 set numcommits
$canshow
3503 set t
[clock clicks
-milliseconds]
3504 if {$prev < 100 ||
$viewcomplete($curview) ||
$t - $lastscrollset > 500} {
3505 set lastscrollset
$t
3508 set rows
[visiblerows
]
3509 set r1
[lindex
$rows 1]
3510 if {$r1 >= $canshow} {
3511 set r1
[expr {$canshow - 1}]
3516 if {[info exists pending_select
] &&
3517 [commitinview
$pending_select $curview]} {
3518 selectline
[rowofcommit
$pending_select] 1
3522 proc doshowlocalchanges
{} {
3523 global curview mainheadid
3525 if {[commitinview
$mainheadid $curview]} {
3528 lappend commitinterest
($mainheadid) {dodiffindex
}
3532 proc dohidelocalchanges
{} {
3533 global nullid nullid2 lserial curview
3535 if {[commitinview
$nullid $curview]} {
3536 removerow
$nullid $curview
3538 if {[commitinview
$nullid2 $curview]} {
3539 removerow
$nullid2 $curview
3544 # spawn off a process to do git diff-index --cached HEAD
3545 proc dodiffindex
{} {
3546 global lserial showlocalchanges
3548 if {!$showlocalchanges} return
3550 set fd
[open
"|git diff-index --cached HEAD" r
]
3551 fconfigure
$fd -blocking 0
3552 filerun
$fd [list readdiffindex
$fd $lserial]
3555 proc readdiffindex
{fd serial
} {
3556 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3559 if {[gets
$fd line
] < 0} {
3565 # we only need to see one line and we don't really care what it says...
3568 if {$serial != $lserial} {
3572 # now see if there are any local changes not checked in to the index
3573 set fd
[open
"|git diff-files" r
]
3574 fconfigure
$fd -blocking 0
3575 filerun
$fd [list readdifffiles
$fd $serial]
3577 if {$isdiff && ![commitinview
$nullid2 $curview]} {
3578 # add the line for the changes in the index to the graph
3579 set hl
[mc
"Local changes checked in to index but not committed"]
3580 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
3581 set commitdata
($nullid2) "\n $hl\n"
3582 if {[commitinview
$nullid $curview]} {
3583 removerow
$nullid $curview
3585 insertrow
$nullid2 $mainheadid $curview
3586 } elseif
{!$isdiff && [commitinview
$nullid2 $curview]} {
3587 removerow
$nullid2 $curview
3592 proc readdifffiles
{fd serial
} {
3593 global mainheadid nullid nullid2 curview
3594 global commitinfo commitdata lserial
3597 if {[gets
$fd line
] < 0} {
3603 # we only need to see one line and we don't really care what it says...
3606 if {$serial != $lserial} {
3610 if {$isdiff && ![commitinview
$nullid $curview]} {
3611 # add the line for the local diff to the graph
3612 set hl
[mc
"Local uncommitted changes, not checked in to index"]
3613 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
3614 set commitdata
($nullid) "\n $hl\n"
3615 if {[commitinview
$nullid2 $curview]} {
3620 insertrow
$nullid $p $curview
3621 } elseif
{!$isdiff && [commitinview
$nullid $curview]} {
3622 removerow
$nullid $curview
3627 proc nextuse
{id row
} {
3628 global curview children
3630 if {[info exists children
($curview,$id)]} {
3631 foreach kid
$children($curview,$id) {
3632 if {![commitinview
$kid $curview]} {
3635 if {[rowofcommit
$kid] > $row} {
3636 return [rowofcommit
$kid]
3640 if {[commitinview
$id $curview]} {
3641 return [rowofcommit
$id]
3646 proc prevuse
{id row
} {
3647 global curview children
3650 if {[info exists children
($curview,$id)]} {
3651 foreach kid
$children($curview,$id) {
3652 if {![commitinview
$kid $curview]} break
3653 if {[rowofcommit
$kid] < $row} {
3654 set ret
[rowofcommit
$kid]
3661 proc make_idlist
{row
} {
3662 global displayorder parentlist uparrowlen downarrowlen mingaplen
3663 global commitidx curview children
3665 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
3669 set ra
[expr {$row - $downarrowlen}]
3673 set rb
[expr {$row + $uparrowlen}]
3674 if {$rb > $commitidx($curview)} {
3675 set rb
$commitidx($curview)
3677 make_disporder
$r [expr {$rb + 1}]
3679 for {} {$r < $ra} {incr r
} {
3680 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3681 foreach p
[lindex
$parentlist $r] {
3682 if {$p eq
$nextid} continue
3683 set rn
[nextuse
$p $r]
3685 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3686 lappend ids
[list
[ordertoken
$p] $p]
3690 for {} {$r < $row} {incr r
} {
3691 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3692 foreach p
[lindex
$parentlist $r] {
3693 if {$p eq
$nextid} continue
3694 set rn
[nextuse
$p $r]
3695 if {$rn < 0 ||
$rn >= $row} {
3696 lappend ids
[list
[ordertoken
$p] $p]
3700 set id
[lindex
$displayorder $row]
3701 lappend ids
[list
[ordertoken
$id] $id]
3703 foreach p
[lindex
$parentlist $r] {
3704 set firstkid
[lindex
$children($curview,$p) 0]
3705 if {[rowofcommit
$firstkid] < $row} {
3706 lappend ids
[list
[ordertoken
$p] $p]
3710 set id
[lindex
$displayorder $r]
3712 set firstkid
[lindex
$children($curview,$id) 0]
3713 if {$firstkid ne
{} && [rowofcommit
$firstkid] < $row} {
3714 lappend ids
[list
[ordertoken
$id] $id]
3719 foreach idx
[lsort
-unique $ids] {
3720 lappend idlist
[lindex
$idx 1]
3725 proc rowsequal
{a b
} {
3726 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3727 set a
[lreplace
$a $i $i]
3729 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3730 set b
[lreplace
$b $i $i]
3732 return [expr {$a eq
$b}]
3735 proc makeupline
{id row rend
col} {
3736 global rowidlist uparrowlen downarrowlen mingaplen
3738 for {set r
$rend} {1} {set r
$rstart} {
3739 set rstart
[prevuse
$id $r]
3740 if {$rstart < 0} return
3741 if {$rstart < $row} break
3743 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3744 set rstart
[expr {$rend - $uparrowlen - 1}]
3746 for {set r
$rstart} {[incr r
] <= $row} {} {
3747 set idlist
[lindex
$rowidlist $r]
3748 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3749 set col [idcol
$idlist $id $col]
3750 lset rowidlist
$r [linsert
$idlist $col $id]
3756 proc layoutrows
{row endrow
} {
3757 global rowidlist rowisopt rowfinal displayorder
3758 global uparrowlen downarrowlen maxwidth mingaplen
3759 global children parentlist
3760 global commitidx viewcomplete curview
3762 make_disporder
[expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3765 set rm1
[expr {$row - 1}]
3766 foreach id
[lindex
$rowidlist $rm1] {
3771 set final
[lindex
$rowfinal $rm1]
3773 for {} {$row < $endrow} {incr row
} {
3774 set rm1
[expr {$row - 1}]
3775 if {$rm1 < 0 ||
$idlist eq
{}} {
3776 set idlist
[make_idlist
$row]
3779 set id
[lindex
$displayorder $rm1]
3780 set col [lsearch
-exact $idlist $id]
3781 set idlist
[lreplace
$idlist $col $col]
3782 foreach p
[lindex
$parentlist $rm1] {
3783 if {[lsearch
-exact $idlist $p] < 0} {
3784 set col [idcol
$idlist $p $col]
3785 set idlist
[linsert
$idlist $col $p]
3786 # if not the first child, we have to insert a line going up
3787 if {$id ne
[lindex
$children($curview,$p) 0]} {
3788 makeupline
$p $rm1 $row $col
3792 set id
[lindex
$displayorder $row]
3793 if {$row > $downarrowlen} {
3794 set termrow
[expr {$row - $downarrowlen - 1}]
3795 foreach p
[lindex
$parentlist $termrow] {
3796 set i
[lsearch
-exact $idlist $p]
3797 if {$i < 0} continue
3798 set nr
[nextuse
$p $termrow]
3799 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3800 set idlist
[lreplace
$idlist $i $i]
3804 set col [lsearch
-exact $idlist $id]
3806 set col [idcol
$idlist $id]
3807 set idlist
[linsert
$idlist $col $id]
3808 if {$children($curview,$id) ne
{}} {
3809 makeupline
$id $rm1 $row $col
3812 set r
[expr {$row + $uparrowlen - 1}]
3813 if {$r < $commitidx($curview)} {
3815 foreach p
[lindex
$parentlist $r] {
3816 if {[lsearch
-exact $idlist $p] >= 0} continue
3817 set fk
[lindex
$children($curview,$p) 0]
3818 if {[rowofcommit
$fk] < $row} {
3819 set x
[idcol
$idlist $p $x]
3820 set idlist
[linsert
$idlist $x $p]
3823 if {[incr r
] < $commitidx($curview)} {
3824 set p
[lindex
$displayorder $r]
3825 if {[lsearch
-exact $idlist $p] < 0} {
3826 set fk
[lindex
$children($curview,$p) 0]
3827 if {$fk ne
{} && [rowofcommit
$fk] < $row} {
3828 set x
[idcol
$idlist $p $x]
3829 set idlist
[linsert
$idlist $x $p]
3835 if {$final && !$viewcomplete($curview) &&
3836 $row + $uparrowlen + $mingaplen + $downarrowlen
3837 >= $commitidx($curview)} {
3840 set l
[llength
$rowidlist]
3842 lappend rowidlist
$idlist
3844 lappend rowfinal
$final
3845 } elseif
{$row < $l} {
3846 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3847 lset rowidlist
$row $idlist
3850 lset rowfinal
$row $final
3852 set pad
[ntimes
[expr {$row - $l}] {}]
3853 set rowidlist
[concat
$rowidlist $pad]
3854 lappend rowidlist
$idlist
3855 set rowfinal
[concat
$rowfinal $pad]
3856 lappend rowfinal
$final
3857 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3863 proc changedrow
{row
} {
3864 global displayorder iddrawn rowisopt need_redisplay
3866 set l
[llength
$rowisopt]
3868 lset rowisopt
$row 0
3869 if {$row + 1 < $l} {
3870 lset rowisopt
[expr {$row + 1}] 0
3871 if {$row + 2 < $l} {
3872 lset rowisopt
[expr {$row + 2}] 0
3876 set id
[lindex
$displayorder $row]
3877 if {[info exists iddrawn
($id)]} {
3878 set need_redisplay
1
3882 proc insert_pad
{row
col npad
} {
3885 set pad
[ntimes
$npad {}]
3886 set idlist
[lindex
$rowidlist $row]
3887 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3888 set aft
[lrange
$idlist $col end
]
3889 set i
[lsearch
-exact $aft {}]
3891 set aft
[lreplace
$aft $i $i]
3893 lset rowidlist
$row [concat
$bef $pad $aft]
3897 proc optimize_rows
{row
col endrow
} {
3898 global rowidlist rowisopt displayorder curview children
3903 for {} {$row < $endrow} {incr row
; set col 0} {
3904 if {[lindex
$rowisopt $row]} continue
3906 set y0
[expr {$row - 1}]
3907 set ym
[expr {$row - 2}]
3908 set idlist
[lindex
$rowidlist $row]
3909 set previdlist
[lindex
$rowidlist $y0]
3910 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3912 set pprevidlist
[lindex
$rowidlist $ym]
3913 if {$pprevidlist eq
{}} continue
3919 for {} {$col < [llength
$idlist]} {incr
col} {
3920 set id
[lindex
$idlist $col]
3921 if {[lindex
$previdlist $col] eq
$id} continue
3926 set x0
[lsearch
-exact $previdlist $id]
3927 if {$x0 < 0} continue
3928 set z
[expr {$x0 - $col}]
3932 set xm
[lsearch
-exact $pprevidlist $id]
3934 set z0
[expr {$xm - $x0}]
3938 # if row y0 is the first child of $id then it's not an arrow
3939 if {[lindex
$children($curview,$id) 0] ne
3940 [lindex
$displayorder $y0]} {
3944 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3945 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3948 # Looking at lines from this row to the previous row,
3949 # make them go straight up if they end in an arrow on
3950 # the previous row; otherwise make them go straight up
3952 if {$z < -1 ||
($z < 0 && $isarrow)} {
3953 # Line currently goes left too much;
3954 # insert pads in the previous row, then optimize it
3955 set npad
[expr {-1 - $z + $isarrow}]
3956 insert_pad
$y0 $x0 $npad
3958 optimize_rows
$y0 $x0 $row
3960 set previdlist
[lindex
$rowidlist $y0]
3961 set x0
[lsearch
-exact $previdlist $id]
3962 set z
[expr {$x0 - $col}]
3964 set pprevidlist
[lindex
$rowidlist $ym]
3965 set xm
[lsearch
-exact $pprevidlist $id]
3966 set z0
[expr {$xm - $x0}]
3968 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3969 # Line currently goes right too much;
3970 # insert pads in this line
3971 set npad
[expr {$z - 1 + $isarrow}]
3972 insert_pad
$row $col $npad
3973 set idlist
[lindex
$rowidlist $row]
3975 set z
[expr {$x0 - $col}]
3978 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3979 # this line links to its first child on row $row-2
3980 set id
[lindex
$displayorder $ym]
3981 set xc
[lsearch
-exact $pprevidlist $id]
3983 set z0
[expr {$xc - $x0}]
3986 # avoid lines jigging left then immediately right
3987 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3988 insert_pad
$y0 $x0 1
3990 optimize_rows
$y0 $x0 $row
3991 set previdlist
[lindex
$rowidlist $y0]
3995 # Find the first column that doesn't have a line going right
3996 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
3997 set id
[lindex
$idlist $col]
3998 if {$id eq
{}} break
3999 set x0
[lsearch
-exact $previdlist $id]
4001 # check if this is the link to the first child
4002 set kid
[lindex
$displayorder $y0]
4003 if {[lindex
$children($curview,$id) 0] eq
$kid} {
4004 # it is, work out offset to child
4005 set x0
[lsearch
-exact $previdlist $kid]
4008 if {$x0 <= $col} break
4010 # Insert a pad at that column as long as it has a line and
4011 # isn't the last column
4012 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
4013 set idlist
[linsert
$idlist $col {}]
4014 lset rowidlist
$row $idlist
4022 global canvx0 linespc
4023 return [expr {$canvx0 + $col * $linespc}]
4027 global canvy0 linespc
4028 return [expr {$canvy0 + $row * $linespc}]
4031 proc linewidth
{id
} {
4032 global thickerline lthickness
4035 if {[info exists thickerline
] && $id eq
$thickerline} {
4036 set wid
[expr {2 * $lthickness}]
4041 proc rowranges
{id
} {
4042 global curview children uparrowlen downarrowlen
4045 set kids
$children($curview,$id)
4051 foreach child
$kids {
4052 if {![commitinview
$child $curview]} break
4053 set row
[rowofcommit
$child]
4054 if {![info exists prev
]} {
4055 lappend ret
[expr {$row + 1}]
4057 if {$row <= $prevrow} {
4058 puts
"oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4060 # see if the line extends the whole way from prevrow to row
4061 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4062 [lsearch
-exact [lindex
$rowidlist \
4063 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
4064 # it doesn't, see where it ends
4065 set r
[expr {$prevrow + $downarrowlen}]
4066 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4067 while {[incr r
-1] > $prevrow &&
4068 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4070 while {[incr r
] <= $row &&
4071 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4075 # see where it starts up again
4076 set r
[expr {$row - $uparrowlen}]
4077 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4078 while {[incr r
] < $row &&
4079 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4081 while {[incr r
-1] >= $prevrow &&
4082 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4088 if {$child eq
$id} {
4097 proc drawlineseg
{id row endrow arrowlow
} {
4098 global rowidlist displayorder iddrawn linesegs
4099 global canv colormap linespc curview maxlinelen parentlist
4101 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
4102 set le
[expr {$row + 1}]
4105 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
4111 set x
[lindex
$displayorder $le]
4116 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
4117 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
4133 if {[info exists linesegs
($id)]} {
4134 set lines
$linesegs($id)
4136 set r0
[lindex
$li 0]
4138 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
4148 set li
[lindex
$lines [expr {$i-1}]]
4149 set r1
[lindex
$li 1]
4150 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
4155 set x
[lindex
$cols [expr {$le - $row}]]
4156 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
4157 set dir
[expr {$xp - $x}]
4159 set ith
[lindex
$lines $i 2]
4160 set coords
[$canv coords
$ith]
4161 set ah
[$canv itemcget
$ith -arrow]
4162 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
4163 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
4164 if {$x2 ne
{} && $x - $x2 == $dir} {
4165 set coords
[lrange
$coords 0 end-2
]
4168 set coords
[list
[xc
$le $x] [yc
$le]]
4171 set itl
[lindex
$lines [expr {$i-1}] 2]
4172 set al
[$canv itemcget
$itl -arrow]
4173 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
4174 } elseif
{$arrowlow} {
4175 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
4176 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
4180 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
4181 for {set y
$le} {[incr y
-1] > $row} {} {
4183 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
4184 set ndir
[expr {$xp - $x}]
4185 if {$dir != $ndir ||
$xp < 0} {
4186 lappend coords
[xc
$y $x] [yc
$y]
4192 # join parent line to first child
4193 set ch
[lindex
$displayorder $row]
4194 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
4196 puts
"oops: drawlineseg: child $ch not on row $row"
4197 } elseif
{$xc != $x} {
4198 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
4199 set d
[expr {int
(0.5 * $linespc)}]
4202 set x2
[expr {$x1 - $d}]
4204 set x2
[expr {$x1 + $d}]
4207 set y1
[expr {$y2 + $d}]
4208 lappend coords
$x1 $y1 $x2 $y2
4209 } elseif
{$xc < $x - 1} {
4210 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
4211 } elseif
{$xc > $x + 1} {
4212 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
4216 lappend coords
[xc
$row $x] [yc
$row]
4218 set xn
[xc
$row $xp]
4220 lappend coords
$xn $yn
4224 set t
[$canv create line
$coords -width [linewidth
$id] \
4225 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
4228 set lines
[linsert
$lines $i [list
$row $le $t]]
4230 $canv coords
$ith $coords
4231 if {$arrow ne
$ah} {
4232 $canv itemconf
$ith -arrow $arrow
4234 lset lines
$i 0 $row
4237 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
4238 set ndir
[expr {$xo - $xp}]
4239 set clow
[$canv coords
$itl]
4240 if {$dir == $ndir} {
4241 set clow
[lrange
$clow 2 end
]
4243 set coords
[concat
$coords $clow]
4245 lset lines
[expr {$i-1}] 1 $le
4247 # coalesce two pieces
4249 set b
[lindex
$lines [expr {$i-1}] 0]
4250 set e
[lindex
$lines $i 1]
4251 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
4253 $canv coords
$itl $coords
4254 if {$arrow ne
$al} {
4255 $canv itemconf
$itl -arrow $arrow
4259 set linesegs
($id) $lines
4263 proc drawparentlinks
{id row
} {
4264 global rowidlist canv colormap curview parentlist
4265 global idpos linespc
4267 set rowids
[lindex
$rowidlist $row]
4268 set col [lsearch
-exact $rowids $id]
4269 if {$col < 0} return
4270 set olds
[lindex
$parentlist $row]
4271 set row2
[expr {$row + 1}]
4272 set x
[xc
$row $col]
4275 set d
[expr {int
(0.5 * $linespc)}]
4276 set ymid
[expr {$y + $d}]
4277 set ids
[lindex
$rowidlist $row2]
4278 # rmx = right-most X coord used
4281 set i
[lsearch
-exact $ids $p]
4283 puts
"oops, parent $p of $id not in list"
4286 set x2
[xc
$row2 $i]
4290 set j
[lsearch
-exact $rowids $p]
4292 # drawlineseg will do this one for us
4296 # should handle duplicated parents here...
4297 set coords
[list
$x $y]
4299 # if attaching to a vertical segment, draw a smaller
4300 # slant for visual distinctness
4303 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
4305 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
4307 } elseif
{$i < $col && $i < $j} {
4308 # segment slants towards us already
4309 lappend coords
[xc
$row $j] $y
4311 if {$i < $col - 1} {
4312 lappend coords
[expr {$x2 + $linespc}] $y
4313 } elseif
{$i > $col + 1} {
4314 lappend coords
[expr {$x2 - $linespc}] $y
4316 lappend coords
$x2 $y2
4319 lappend coords
$x2 $y2
4321 set t
[$canv create line
$coords -width [linewidth
$p] \
4322 -fill $colormap($p) -tags lines.
$p]
4326 if {$rmx > [lindex
$idpos($id) 1]} {
4327 lset idpos
($id) 1 $rmx
4332 proc drawlines
{id
} {
4335 $canv itemconf lines.
$id -width [linewidth
$id]
4338 proc drawcmittext
{id row
col} {
4339 global linespc canv canv2 canv3 fgcolor curview
4340 global cmitlisted commitinfo rowidlist parentlist
4341 global rowtextx idpos idtags idheads idotherrefs
4342 global linehtag linentag linedtag selectedline
4343 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4345 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4346 set listed
$cmitlisted($curview,$id)
4347 if {$id eq
$nullid} {
4349 } elseif
{$id eq
$nullid2} {
4352 set ofill
[expr {$listed != 0?
"blue": "white"}]
4354 set x
[xc
$row $col]
4356 set orad
[expr {$linespc / 3}]
4358 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
4359 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4360 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4361 } elseif
{$listed == 2} {
4362 # triangle pointing left for left-side commits
4363 set t
[$canv create polygon \
4364 [expr {$x - $orad}] $y \
4365 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4366 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4367 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4369 # triangle pointing right for right-side commits
4370 set t
[$canv create polygon \
4371 [expr {$x + $orad - 1}] $y \
4372 [expr {$x - $orad}] [expr {$y - $orad}] \
4373 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4374 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4377 $canv bind $t <1> {selcanvline
{} %x
%y
}
4378 set rmx
[llength
[lindex
$rowidlist $row]]
4379 set olds
[lindex
$parentlist $row]
4381 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
4383 set i
[lsearch
-exact $nextids $p]
4389 set xt
[xc
$row $rmx]
4390 set rowtextx
($row) $xt
4391 set idpos
($id) [list
$x $xt $y]
4392 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
4393 ||
[info exists idotherrefs
($id)]} {
4394 set xt
[drawtags
$id $x $xt $y]
4396 set headline
[lindex
$commitinfo($id) 0]
4397 set name
[lindex
$commitinfo($id) 1]
4398 set date [lindex
$commitinfo($id) 2]
4399 set date [formatdate
$date]
4402 set isbold
[ishighlighted
$id]
4404 lappend boldrows
$row
4405 set font mainfontbold
4407 lappend boldnamerows
$row
4408 set nfont mainfontbold
4411 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
4412 -text $headline -font $font -tags text
]
4413 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
4414 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
4415 -text $name -font $nfont -tags text
]
4416 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
4417 -text $date -font mainfont
-tags text
]
4418 if {[info exists selectedline
] && $selectedline == $row} {
4421 set xr
[expr {$xt + [font measure
$font $headline]}]
4422 if {$xr > $canvxmax} {
4428 proc drawcmitrow
{row
} {
4429 global displayorder rowidlist nrows_drawn
4430 global iddrawn markingmatches
4431 global commitinfo numcommits
4432 global filehighlight fhighlights findpattern nhighlights
4433 global hlview vhighlights
4434 global highlight_related rhighlights
4436 if {$row >= $numcommits} return
4438 set id
[lindex
$displayorder $row]
4439 if {[info exists hlview
] && ![info exists vhighlights
($id)]} {
4440 askvhighlight
$row $id
4442 if {[info exists filehighlight
] && ![info exists fhighlights
($id)]} {
4443 askfilehighlight
$row $id
4445 if {$findpattern ne
{} && ![info exists nhighlights
($id)]} {
4446 askfindhighlight
$row $id
4448 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($id)]} {
4449 askrelhighlight
$row $id
4451 if {![info exists iddrawn
($id)]} {
4452 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
4454 puts
"oops, row $row id $id not in list"
4457 if {![info exists commitinfo
($id)]} {
4461 drawcmittext
$id $row $col
4465 if {$markingmatches} {
4466 markrowmatches
$row $id
4470 proc drawcommits
{row
{endrow
{}}} {
4471 global numcommits iddrawn displayorder curview need_redisplay
4472 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4477 if {$endrow eq
{}} {
4480 if {$endrow >= $numcommits} {
4481 set endrow
[expr {$numcommits - 1}]
4484 set rl1
[expr {$row - $downarrowlen - 3}]
4488 set ro1
[expr {$row - 3}]
4492 set r2
[expr {$endrow + $uparrowlen + 3}]
4493 if {$r2 > $numcommits} {
4496 for {set r
$rl1} {$r < $r2} {incr r
} {
4497 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
4501 set rl1
[expr {$r + 1}]
4507 optimize_rows
$ro1 0 $r2
4508 if {$need_redisplay ||
$nrows_drawn > 2000} {
4513 # make the lines join to already-drawn rows either side
4514 set r
[expr {$row - 1}]
4515 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
4518 set er
[expr {$endrow + 1}]
4519 if {$er >= $numcommits ||
4520 ![info exists iddrawn
([lindex
$displayorder $er])]} {
4523 for {} {$r <= $er} {incr r
} {
4524 set id
[lindex
$displayorder $r]
4525 set wasdrawn
[info exists iddrawn
($id)]
4527 if {$r == $er} break
4528 set nextid
[lindex
$displayorder [expr {$r + 1}]]
4529 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
4530 drawparentlinks
$id $r
4532 set rowids
[lindex
$rowidlist $r]
4533 foreach lid
$rowids {
4534 if {$lid eq
{}} continue
4535 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
4537 # see if this is the first child of any of its parents
4538 foreach p
[lindex
$parentlist $r] {
4539 if {[lsearch
-exact $rowids $p] < 0} {
4540 # make this line extend up to the child
4541 set lineend
($p) [drawlineseg
$p $r $er 0]
4545 set lineend
($lid) [drawlineseg
$lid $r $er 1]
4551 proc undolayout
{row
} {
4552 global uparrowlen mingaplen downarrowlen
4553 global rowidlist rowisopt rowfinal need_redisplay
4555 set r
[expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4559 if {[llength
$rowidlist] > $r} {
4561 set rowidlist
[lrange
$rowidlist 0 $r]
4562 set rowfinal
[lrange
$rowfinal 0 $r]
4563 set rowisopt
[lrange
$rowisopt 0 $r]
4564 set need_redisplay
1
4569 proc drawvisible
{} {
4570 global canv linespc curview vrowmod selectedline targetrow targetid
4571 global need_redisplay cscroll numcommits
4573 set fs
[$canv yview
]
4574 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4575 if {$ymax eq
{} ||
$ymax == 0} return
4576 set f0
[lindex
$fs 0]
4577 set f1
[lindex
$fs 1]
4578 set y0
[expr {int
($f0 * $ymax)}]
4579 set y1
[expr {int
($f1 * $ymax)}]
4581 if {[info exists targetid
]} {
4582 if {[commitinview
$targetid $curview]} {
4583 set r
[rowofcommit
$targetid]
4584 if {$r != $targetrow} {
4585 # Fix up the scrollregion and change the scrolling position
4586 # now that our target row has moved.
4587 set diff [expr {($r - $targetrow) * $linespc}]
4590 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4593 set f0
[expr {$y0 / $ymax}]
4594 set f1
[expr {$y1 / $ymax}]
4595 allcanvs yview moveto
$f0
4596 $cscroll set $f0 $f1
4597 set need_redisplay
1
4604 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
4605 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
4606 if {$endrow >= $vrowmod($curview)} {
4607 update_arcrows
$curview
4609 if {[info exists selectedline
] &&
4610 $row <= $selectedline && $selectedline <= $endrow} {
4611 set targetrow
$selectedline
4613 set targetrow
[expr {int
(($row + $endrow) / 2)}]
4615 if {$targetrow >= $numcommits} {
4616 set targetrow
[expr {$numcommits - 1}]
4618 set targetid
[commitonrow
$targetrow]
4619 drawcommits
$row $endrow
4622 proc clear_display
{} {
4623 global iddrawn linesegs need_redisplay nrows_drawn
4624 global vhighlights fhighlights nhighlights rhighlights
4627 catch
{unset iddrawn
}
4628 catch
{unset linesegs
}
4629 catch
{unset vhighlights
}
4630 catch
{unset fhighlights
}
4631 catch
{unset nhighlights
}
4632 catch
{unset rhighlights
}
4633 set need_redisplay
0
4637 proc findcrossings
{id
} {
4638 global rowidlist parentlist numcommits displayorder
4642 foreach
{s e
} [rowranges
$id] {
4643 if {$e >= $numcommits} {
4644 set e
[expr {$numcommits - 1}]
4646 if {$e <= $s} continue
4647 for {set row
$e} {[incr row
-1] >= $s} {} {
4648 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
4650 set olds
[lindex
$parentlist $row]
4651 set kid
[lindex
$displayorder $row]
4652 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
4653 if {$kidx < 0} continue
4654 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
4656 set px
[lsearch
-exact $nextrow $p]
4657 if {$px < 0} continue
4658 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
4659 if {[lsearch
-exact $ccross $p] >= 0} continue
4660 if {$x == $px + ($kidx < $px?
-1: 1)} {
4662 } elseif
{[lsearch
-exact $cross $p] < 0} {
4669 return [concat
$ccross {{}} $cross]
4672 proc assigncolor
{id
} {
4673 global colormap colors nextcolor
4674 global parents children children curview
4676 if {[info exists colormap
($id)]} return
4677 set ncolors
[llength
$colors]
4678 if {[info exists children
($curview,$id)]} {
4679 set kids
$children($curview,$id)
4683 if {[llength
$kids] == 1} {
4684 set child
[lindex
$kids 0]
4685 if {[info exists colormap
($child)]
4686 && [llength
$parents($curview,$child)] == 1} {
4687 set colormap
($id) $colormap($child)
4693 foreach x
[findcrossings
$id] {
4695 # delimiter between corner crossings and other crossings
4696 if {[llength
$badcolors] >= $ncolors - 1} break
4697 set origbad
$badcolors
4699 if {[info exists colormap
($x)]
4700 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
4701 lappend badcolors
$colormap($x)
4704 if {[llength
$badcolors] >= $ncolors} {
4705 set badcolors
$origbad
4707 set origbad
$badcolors
4708 if {[llength
$badcolors] < $ncolors - 1} {
4709 foreach child
$kids {
4710 if {[info exists colormap
($child)]
4711 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
4712 lappend badcolors
$colormap($child)
4714 foreach p
$parents($curview,$child) {
4715 if {[info exists colormap
($p)]
4716 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
4717 lappend badcolors
$colormap($p)
4721 if {[llength
$badcolors] >= $ncolors} {
4722 set badcolors
$origbad
4725 for {set i
0} {$i <= $ncolors} {incr i
} {
4726 set c
[lindex
$colors $nextcolor]
4727 if {[incr nextcolor
] >= $ncolors} {
4730 if {[lsearch
-exact $badcolors $c]} break
4732 set colormap
($id) $c
4735 proc bindline
{t id
} {
4738 $canv bind $t <Enter
> "lineenter %x %y $id"
4739 $canv bind $t <Motion
> "linemotion %x %y $id"
4740 $canv bind $t <Leave
> "lineleave $id"
4741 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4744 proc drawtags
{id x xt y1
} {
4745 global idtags idheads idotherrefs mainhead
4746 global linespc lthickness
4747 global canv rowtextx curview fgcolor bgcolor
4752 if {[info exists idtags
($id)]} {
4753 set marks
$idtags($id)
4754 set ntags
[llength
$marks]
4756 if {[info exists idheads
($id)]} {
4757 set marks
[concat
$marks $idheads($id)]
4758 set nheads
[llength
$idheads($id)]
4760 if {[info exists idotherrefs
($id)]} {
4761 set marks
[concat
$marks $idotherrefs($id)]
4767 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4768 set yt
[expr {$y1 - 0.5 * $linespc}]
4769 set yb
[expr {$yt + $linespc - 1}]
4773 foreach tag
$marks {
4775 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4776 set wid
[font measure mainfontbold
$tag]
4778 set wid
[font measure mainfont
$tag]
4782 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4784 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4785 -width $lthickness -fill black
-tags tag.
$id]
4787 foreach tag
$marks x
$xvals wid
$wvals {
4788 set xl
[expr {$x + $delta}]
4789 set xr
[expr {$x + $delta + $wid + $lthickness}]
4791 if {[incr ntags
-1] >= 0} {
4793 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4794 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4795 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4796 $canv bind $t <1> [list showtag
$tag 1]
4797 set rowtextx
([rowofcommit
$id]) [expr {$xr + $linespc}]
4799 # draw a head or other ref
4800 if {[incr nheads
-1] >= 0} {
4802 if {$tag eq
$mainhead} {
4803 set font mainfontbold
4808 set xl
[expr {$xl - $delta/2}]
4809 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4810 -width 1 -outline black
-fill $col -tags tag.
$id
4811 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4812 set rwid
[font measure mainfont
$remoteprefix]
4813 set xi
[expr {$x + 1}]
4814 set yti
[expr {$yt + 1}]
4815 set xri
[expr {$x + $rwid}]
4816 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4817 -width 0 -fill "#ffddaa" -tags tag.
$id
4820 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4821 -font $font -tags [list tag.
$id text
]]
4823 $canv bind $t <1> [list showtag
$tag 1]
4824 } elseif
{$nheads >= 0} {
4825 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4831 proc xcoord
{i level
ln} {
4832 global canvx0 xspc1 xspc2
4834 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4835 if {$i > 0 && $i == $level} {
4836 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4837 } elseif
{$i > $level} {
4838 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4843 proc show_status
{msg
} {
4847 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4848 -tags text
-fill $fgcolor
4851 # Don't change the text pane cursor if it is currently the hand cursor,
4852 # showing that we are over a sha1 ID link.
4853 proc settextcursor
{c
} {
4854 global ctext curtextcursor
4856 if {[$ctext cget
-cursor] == $curtextcursor} {
4857 $ctext config
-cursor $c
4859 set curtextcursor
$c
4862 proc nowbusy
{what
{name
{}}} {
4863 global isbusy busyname statusw
4865 if {[array names isbusy
] eq
{}} {
4866 . config
-cursor watch
4870 set busyname
($what) $name
4872 $statusw conf
-text $name
4876 proc notbusy
{what
} {
4877 global isbusy maincursor textcursor busyname statusw
4881 if {$busyname($what) ne
{} &&
4882 [$statusw cget
-text] eq
$busyname($what)} {
4883 $statusw conf
-text {}
4886 if {[array names isbusy
] eq
{}} {
4887 . config
-cursor $maincursor
4888 settextcursor
$textcursor
4892 proc findmatches
{f
} {
4893 global findtype findstring
4894 if {$findtype == [mc
"Regexp"]} {
4895 set matches
[regexp
-indices -all -inline $findstring $f]
4898 if {$findtype == [mc
"IgnCase"]} {
4899 set f
[string tolower
$f]
4900 set fs
[string tolower
$fs]
4904 set l
[string length
$fs]
4905 while {[set j
[string first
$fs $f $i]] >= 0} {
4906 lappend matches
[list
$j [expr {$j+$l-1}]]
4907 set i
[expr {$j + $l}]
4913 proc dofind
{{dirn
1} {wrap
1}} {
4914 global findstring findstartline findcurline selectedline numcommits
4915 global gdttype filehighlight fh_serial find_dirn findallowwrap
4917 if {[info exists find_dirn
]} {
4918 if {$find_dirn == $dirn} return
4922 if {$findstring eq
{} ||
$numcommits == 0} return
4923 if {![info exists selectedline
]} {
4924 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4926 set findstartline
$selectedline
4928 set findcurline
$findstartline
4929 nowbusy finding
[mc
"Searching"]
4930 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4931 after cancel do_file_hl
$fh_serial
4932 do_file_hl
$fh_serial
4935 set findallowwrap
$wrap
4939 proc stopfinding
{} {
4940 global find_dirn findcurline fprogcoord
4942 if {[info exists find_dirn
]} {
4952 global commitdata commitinfo numcommits findpattern findloc
4953 global findstartline findcurline findallowwrap
4954 global find_dirn gdttype fhighlights fprogcoord
4955 global curview varcorder vrownum varccommits vrowmod
4957 if {![info exists find_dirn
]} {
4960 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4963 if {$find_dirn > 0} {
4965 if {$l >= $numcommits} {
4968 if {$l <= $findstartline} {
4969 set lim
[expr {$findstartline + 1}]
4972 set moretodo
$findallowwrap
4979 if {$l >= $findstartline} {
4980 set lim
[expr {$findstartline - 1}]
4983 set moretodo
$findallowwrap
4986 set n
[expr {($lim - $l) * $find_dirn}]
4991 if {$l + ($find_dirn > 0?
$n: 1) > $vrowmod($curview)} {
4992 update_arcrows
$curview
4996 set ai
[bsearch
$vrownum($curview) $l]
4997 set a
[lindex
$varcorder($curview) $ai]
4998 set arow
[lindex
$vrownum($curview) $ai]
4999 set ids
[lindex
$varccommits($curview,$a)]
5000 set arowend
[expr {$arow + [llength
$ids]}]
5001 if {$gdttype eq
[mc
"containing:"]} {
5002 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5003 if {$l < $arow ||
$l >= $arowend} {
5005 set a
[lindex
$varcorder($curview) $ai]
5006 set arow
[lindex
$vrownum($curview) $ai]
5007 set ids
[lindex
$varccommits($curview,$a)]
5008 set arowend
[expr {$arow + [llength
$ids]}]
5010 set id
[lindex
$ids [expr {$l - $arow}]]
5011 # shouldn't happen unless git log doesn't give all the commits...
5012 if {![info exists commitdata
($id)] ||
5013 ![doesmatch
$commitdata($id)]} {
5016 if {![info exists commitinfo
($id)]} {
5019 set info
$commitinfo($id)
5020 foreach f
$info ty
$fldtypes {
5021 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
5030 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5031 if {$l < $arow ||
$l >= $arowend} {
5033 set a
[lindex
$varcorder($curview) $ai]
5034 set arow
[lindex
$vrownum($curview) $ai]
5035 set ids
[lindex
$varccommits($curview,$a)]
5036 set arowend
[expr {$arow + [llength
$ids]}]
5038 set id
[lindex
$ids [expr {$l - $arow}]]
5039 if {![info exists fhighlights
($id)]} {
5040 # this sets fhighlights($id) to -1
5041 askfilehighlight
$l $id
5043 if {$fhighlights($id) > 0} {
5047 if {$fhighlights($id) < 0} {
5050 set findcurline
[expr {$l - $find_dirn}]
5055 if {$found ||
($domore && !$moretodo)} {
5071 set findcurline
[expr {$l - $find_dirn}]
5073 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
5077 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
5082 proc findselectline
{l
} {
5083 global findloc commentend ctext findcurline markingmatches gdttype
5085 set markingmatches
1
5088 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
5089 # highlight the matches in the comments
5090 set f
[$ctext get
1.0 $commentend]
5091 set matches
[findmatches
$f]
5092 foreach match
$matches {
5093 set start
[lindex
$match 0]
5094 set end
[expr {[lindex
$match 1] + 1}]
5095 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
5101 # mark the bits of a headline or author that match a find string
5102 proc markmatches
{canv l str tag matches font row
} {
5105 set bbox
[$canv bbox
$tag]
5106 set x0
[lindex
$bbox 0]
5107 set y0
[lindex
$bbox 1]
5108 set y1
[lindex
$bbox 3]
5109 foreach match
$matches {
5110 set start
[lindex
$match 0]
5111 set end
[lindex
$match 1]
5112 if {$start > $end} continue
5113 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
5114 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
5115 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
5116 [expr {$x0+$xlen+2}] $y1 \
5117 -outline {} -tags [list match
$l matches
] -fill yellow
]
5119 if {[info exists selectedline
] && $row == $selectedline} {
5120 $canv raise
$t secsel
5125 proc unmarkmatches
{} {
5126 global markingmatches
5128 allcanvs delete matches
5129 set markingmatches
0
5133 proc selcanvline
{w x y
} {
5134 global canv canvy0 ctext linespc
5136 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5137 if {$ymax == {}} return
5138 set yfrac
[lindex
[$canv yview
] 0]
5139 set y
[expr {$y + $yfrac * $ymax}]
5140 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
5145 set xmax
[lindex
[$canv cget
-scrollregion] 2]
5146 set xleft
[expr {[lindex
[$canv xview
] 0] * $xmax}]
5147 if {![info exists rowtextx
($l)] ||
$xleft + $x < $rowtextx($l)} return
5153 proc commit_descriptor
{p
} {
5155 if {![info exists commitinfo
($p)]} {
5159 if {[llength
$commitinfo($p)] > 1} {
5160 set l
[lindex
$commitinfo($p) 0]
5165 # append some text to the ctext widget, and make any SHA1 ID
5166 # that we know about be a clickable link.
5167 proc appendwithlinks
{text tags
} {
5168 global ctext linknum curview pendinglinks
5170 set start
[$ctext index
"end - 1c"]
5171 $ctext insert end
$text $tags
5172 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
5176 set linkid
[string range
$text $s $e]
5178 $ctext tag delete link
$linknum
5179 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
5180 setlink
$linkid link
$linknum
5185 proc setlink
{id lk
} {
5186 global curview ctext pendinglinks commitinterest
5188 if {[commitinview
$id $curview]} {
5189 $ctext tag conf
$lk -foreground blue
-underline 1
5190 $ctext tag
bind $lk <1> [list selectline
[rowofcommit
$id] 1]
5191 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
5192 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
5194 lappend pendinglinks
($id) $lk
5195 lappend commitinterest
($id) {makelink
%I
}
5199 proc makelink
{id
} {
5202 if {![info exists pendinglinks
($id)]} return
5203 foreach lk
$pendinglinks($id) {
5206 unset pendinglinks
($id)
5209 proc linkcursor
{w inc
} {
5210 global linkentercount curtextcursor
5212 if {[incr linkentercount
$inc] > 0} {
5213 $w configure
-cursor hand2
5215 $w configure
-cursor $curtextcursor
5216 if {$linkentercount < 0} {
5217 set linkentercount
0
5222 proc viewnextline
{dir
} {
5226 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5227 set wnow
[$canv yview
]
5228 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5229 set newtop
[expr {$wtop + $dir * $linespc}]
5232 } elseif
{$newtop > $ymax} {
5235 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5238 # add a list of tag or branch names at position pos
5239 # returns the number of names inserted
5240 proc appendrefs
{pos ids var
} {
5241 global ctext linknum curview
$var maxrefs
5243 if {[catch
{$ctext index
$pos}]} {
5246 $ctext conf
-state normal
5247 $ctext delete
$pos "$pos lineend"
5250 foreach tag
[set $var\
($id\
)] {
5251 lappend tags
[list
$tag $id]
5254 if {[llength
$tags] > $maxrefs} {
5255 $ctext insert
$pos "many ([llength $tags])"
5257 set tags
[lsort
-index 0 -decreasing $tags]
5260 set id
[lindex
$ti 1]
5263 $ctext tag delete
$lk
5264 $ctext insert
$pos $sep
5265 $ctext insert
$pos [lindex
$ti 0] $lk
5270 $ctext conf
-state disabled
5271 return [llength
$tags]
5274 # called when we have finished computing the nearby tags
5275 proc dispneartags
{delay
} {
5276 global selectedline currentid showneartags tagphase
5278 if {![info exists selectedline
] ||
!$showneartags} return
5279 after cancel dispnexttag
5281 after
200 dispnexttag
5284 after idle dispnexttag
5289 proc dispnexttag
{} {
5290 global selectedline currentid showneartags tagphase ctext
5292 if {![info exists selectedline
] ||
!$showneartags} return
5293 switch
-- $tagphase {
5295 set dtags
[desctags
$currentid]
5297 appendrefs precedes
$dtags idtags
5301 set atags
[anctags
$currentid]
5303 appendrefs follows
$atags idtags
5307 set dheads
[descheads
$currentid]
5308 if {$dheads ne
{}} {
5309 if {[appendrefs branch
$dheads idheads
] > 1
5310 && [$ctext get
"branch -3c"] eq
"h"} {
5311 # turn "Branch" into "Branches"
5312 $ctext conf
-state normal
5313 $ctext insert
"branch -2c" "es"
5314 $ctext conf
-state disabled
5319 if {[incr tagphase
] <= 2} {
5320 after idle dispnexttag
5324 proc make_secsel
{l
} {
5325 global linehtag linentag linedtag canv canv2 canv3
5327 if {![info exists linehtag
($l)]} return
5329 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
5330 -tags secsel
-fill [$canv cget
-selectbackground]]
5332 $canv2 delete secsel
5333 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
5334 -tags secsel
-fill [$canv2 cget
-selectbackground]]
5336 $canv3 delete secsel
5337 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
5338 -tags secsel
-fill [$canv3 cget
-selectbackground]]
5342 proc selectline
{l isnew
} {
5343 global canv ctext commitinfo selectedline
5344 global canvy0 linespc parents children curview
5345 global currentid sha1entry
5346 global commentend idtags linknum
5347 global mergemax numcommits pending_select
5348 global cmitmode showneartags allcommits
5350 catch
{unset pending_select
}
5355 if {$l < 0 ||
$l >= $numcommits} return
5356 set y
[expr {$canvy0 + $l * $linespc}]
5357 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5358 set ytop
[expr {$y - $linespc - 1}]
5359 set ybot
[expr {$y + $linespc + 1}]
5360 set wnow
[$canv yview
]
5361 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5362 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
5363 set wh
[expr {$wbot - $wtop}]
5365 if {$ytop < $wtop} {
5366 if {$ybot < $wtop} {
5367 set newtop
[expr {$y - $wh / 2.0}]
5370 if {$newtop > $wtop - $linespc} {
5371 set newtop
[expr {$wtop - $linespc}]
5374 } elseif
{$ybot > $wbot} {
5375 if {$ytop > $wbot} {
5376 set newtop
[expr {$y - $wh / 2.0}]
5378 set newtop
[expr {$ybot - $wh}]
5379 if {$newtop < $wtop + $linespc} {
5380 set newtop
[expr {$wtop + $linespc}]
5384 if {$newtop != $wtop} {
5388 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5394 set id
[commitonrow
$l]
5396 addtohistory
[list selbyid
$id]
5401 $sha1entry delete
0 end
5402 $sha1entry insert
0 $id
5403 $sha1entry selection from
0
5404 $sha1entry selection to end
5407 $ctext conf
-state normal
5410 set info
$commitinfo($id)
5411 set date [formatdate
[lindex
$info 2]]
5412 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
5413 set date [formatdate
[lindex
$info 4]]
5414 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
5415 if {[info exists idtags
($id)]} {
5416 $ctext insert end
[mc
"Tags:"]
5417 foreach tag
$idtags($id) {
5418 $ctext insert end
" $tag"
5420 $ctext insert end
"\n"
5424 set olds
$parents($curview,$id)
5425 if {[llength
$olds] > 1} {
5428 if {$np >= $mergemax} {
5433 $ctext insert end
"[mc "Parent
"]: " $tag
5434 appendwithlinks
[commit_descriptor
$p] {}
5439 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
5443 foreach c
$children($curview,$id) {
5444 append headers
"[mc "Child
"]: [commit_descriptor $c]"
5447 # make anything that looks like a SHA1 ID be a clickable link
5448 appendwithlinks
$headers {}
5449 if {$showneartags} {
5450 if {![info exists allcommits
]} {
5453 $ctext insert end
"[mc "Branch
"]: "
5454 $ctext mark
set branch
"end -1c"
5455 $ctext mark gravity branch left
5456 $ctext insert end
"\n[mc "Follows
"]: "
5457 $ctext mark
set follows
"end -1c"
5458 $ctext mark gravity follows left
5459 $ctext insert end
"\n[mc "Precedes
"]: "
5460 $ctext mark
set precedes
"end -1c"
5461 $ctext mark gravity precedes left
5462 $ctext insert end
"\n"
5465 $ctext insert end
"\n"
5466 set comment
[lindex
$info 5]
5467 if {[string first
"\r" $comment] >= 0} {
5468 set comment
[string map
{"\r" "\n "} $comment]
5470 appendwithlinks
$comment {comment
}
5472 $ctext tag remove found
1.0 end
5473 $ctext conf
-state disabled
5474 set commentend
[$ctext index
"end - 1c"]
5476 init_flist
[mc
"Comments"]
5477 if {$cmitmode eq
"tree"} {
5479 } elseif
{[llength
$olds] <= 1} {
5486 proc selfirstline
{} {
5491 proc sellastline
{} {
5494 set l
[expr {$numcommits - 1}]
5498 proc selnextline
{dir
} {
5501 if {![info exists selectedline
]} return
5502 set l
[expr {$selectedline + $dir}]
5507 proc selnextpage
{dir
} {
5508 global canv linespc selectedline numcommits
5510 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
5514 allcanvs yview scroll
[expr {$dir * $lpp}] units
5516 if {![info exists selectedline
]} return
5517 set l
[expr {$selectedline + $dir * $lpp}]
5520 } elseif
{$l >= $numcommits} {
5521 set l
[expr $numcommits - 1]
5527 proc unselectline
{} {
5528 global selectedline currentid
5530 catch
{unset selectedline
}
5531 catch
{unset currentid
}
5532 allcanvs delete secsel
5536 proc reselectline
{} {
5539 if {[info exists selectedline
]} {
5540 selectline
$selectedline 0
5544 proc addtohistory
{cmd
} {
5545 global
history historyindex curview
5547 set elt
[list
$curview $cmd]
5548 if {$historyindex > 0
5549 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
5553 if {$historyindex < [llength
$history]} {
5554 set history [lreplace
$history $historyindex end
$elt]
5556 lappend
history $elt
5559 if {$historyindex > 1} {
5560 .tf.bar.leftbut conf
-state normal
5562 .tf.bar.leftbut conf
-state disabled
5564 .tf.bar.rightbut conf
-state disabled
5570 set view
[lindex
$elt 0]
5571 set cmd
[lindex
$elt 1]
5572 if {$curview != $view} {
5579 global
history historyindex
5582 if {$historyindex > 1} {
5583 incr historyindex
-1
5584 godo
[lindex
$history [expr {$historyindex - 1}]]
5585 .tf.bar.rightbut conf
-state normal
5587 if {$historyindex <= 1} {
5588 .tf.bar.leftbut conf
-state disabled
5593 global
history historyindex
5596 if {$historyindex < [llength
$history]} {
5597 set cmd
[lindex
$history $historyindex]
5600 .tf.bar.leftbut conf
-state normal
5602 if {$historyindex >= [llength
$history]} {
5603 .tf.bar.rightbut conf
-state disabled
5608 global treefilelist treeidlist diffids diffmergeid treepending
5609 global nullid nullid2
5612 catch
{unset diffmergeid
}
5613 if {![info exists treefilelist
($id)]} {
5614 if {![info exists treepending
]} {
5615 if {$id eq
$nullid} {
5616 set cmd
[list | git ls-files
]
5617 } elseif
{$id eq
$nullid2} {
5618 set cmd
[list | git ls-files
--stage -t]
5620 set cmd
[list | git ls-tree
-r $id]
5622 if {[catch
{set gtf
[open
$cmd r
]}]} {
5626 set treefilelist
($id) {}
5627 set treeidlist
($id) {}
5628 fconfigure
$gtf -blocking 0
5629 filerun
$gtf [list gettreeline
$gtf $id]
5636 proc gettreeline
{gtf id
} {
5637 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5640 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
5641 if {$diffids eq
$nullid} {
5644 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
5645 set i
[string first
"\t" $line]
5646 if {$i < 0} continue
5647 set sha1
[lindex
$line 2]
5648 set fname
[string range
$line [expr {$i+1}] end
]
5649 if {[string index
$fname 0] eq
"\""} {
5650 set fname
[lindex
$fname 0]
5652 lappend treeidlist
($id) $sha1
5654 lappend treefilelist
($id) $fname
5657 return [expr {$nl >= 1000?
2: 1}]
5661 if {$cmitmode ne
"tree"} {
5662 if {![info exists diffmergeid
]} {
5663 gettreediffs
$diffids
5665 } elseif
{$id ne
$diffids} {
5674 global treefilelist treeidlist diffids nullid nullid2
5675 global ctext commentend
5677 set i
[lsearch
-exact $treefilelist($diffids) $f]
5679 puts
"oops, $f not in list for id $diffids"
5682 if {$diffids eq
$nullid} {
5683 if {[catch
{set bf
[open
$f r
]} err
]} {
5684 puts
"oops, can't read $f: $err"
5688 set blob
[lindex
$treeidlist($diffids) $i]
5689 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5690 puts
"oops, error reading blob $blob: $err"
5694 fconfigure
$bf -blocking 0
5695 filerun
$bf [list getblobline
$bf $diffids]
5696 $ctext config
-state normal
5697 clear_ctext
$commentend
5698 $ctext insert end
"\n"
5699 $ctext insert end
"$f\n" filesep
5700 $ctext config
-state disabled
5701 $ctext yview
$commentend
5705 proc getblobline
{bf id
} {
5706 global diffids cmitmode ctext
5708 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5712 $ctext config
-state normal
5714 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5715 $ctext insert end
"$line\n"
5718 # delete last newline
5719 $ctext delete
"end - 2c" "end - 1c"
5723 $ctext config
-state disabled
5724 return [expr {$nl >= 1000?
2: 1}]
5727 proc mergediff
{id
} {
5728 global diffmergeid mdifffd
5731 global limitdiffs viewfiles curview
5735 # this doesn't seem to actually affect anything...
5736 set cmd
[concat | git diff-tree
--no-commit-id --cc $id]
5737 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5738 set cmd
[concat
$cmd -- $viewfiles($curview)]
5740 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5741 error_popup
"[mc "Error getting merge diffs
:"] $err"
5744 fconfigure
$mdf -blocking 0
5745 set mdifffd
($id) $mdf
5746 set np
[llength
$parents($curview,$id)]
5748 filerun
$mdf [list getmergediffline
$mdf $id $np]
5751 proc getmergediffline
{mdf id np
} {
5752 global diffmergeid ctext cflist mergemax
5753 global difffilestart mdifffd
5755 $ctext conf
-state normal
5757 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5758 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5759 ||
$mdf != $mdifffd($id)} {
5763 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5764 # start of a new file
5765 $ctext insert end
"\n"
5766 set here
[$ctext index
"end - 1c"]
5767 lappend difffilestart
$here
5768 add_flist
[list
$fname]
5769 set l
[expr {(78 - [string length
$fname]) / 2}]
5770 set pad
[string range
"----------------------------------------" 1 $l]
5771 $ctext insert end
"$pad $fname $pad\n" filesep
5772 } elseif
{[regexp
{^@@
} $line]} {
5773 $ctext insert end
"$line\n" hunksep
5774 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5777 # parse the prefix - one ' ', '-' or '+' for each parent
5782 for {set j
0} {$j < $np} {incr j
} {
5783 set c
[string range
$line $j $j]
5786 } elseif
{$c == "-"} {
5788 } elseif
{$c == "+"} {
5797 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5798 # line doesn't appear in result, parents in $minuses have the line
5799 set num
[lindex
$minuses 0]
5800 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5801 # line appears in result, parents in $pluses don't have the line
5802 lappend tags mresult
5803 set num
[lindex
$spaces 0]
5806 if {$num >= $mergemax} {
5811 $ctext insert end
"$line\n" $tags
5814 $ctext conf
-state disabled
5819 return [expr {$nr >= 1000?
2: 1}]
5822 proc startdiff
{ids
} {
5823 global treediffs diffids treepending diffmergeid nullid nullid2
5827 catch
{unset diffmergeid
}
5828 if {![info exists treediffs
($ids)] ||
5829 [lsearch
-exact $ids $nullid] >= 0 ||
5830 [lsearch
-exact $ids $nullid2] >= 0} {
5831 if {![info exists treepending
]} {
5839 proc path_filter
{filter name
} {
5841 set l
[string length
$p]
5842 if {[string index
$p end
] eq
"/"} {
5843 if {[string compare
-length $l $p $name] == 0} {
5847 if {[string compare
-length $l $p $name] == 0 &&
5848 ([string length
$name] == $l ||
5849 [string index
$name $l] eq
"/")} {
5857 proc addtocflist
{ids
} {
5860 add_flist
$treediffs($ids)
5864 proc diffcmd
{ids flags
} {
5865 global nullid nullid2
5867 set i
[lsearch
-exact $ids $nullid]
5868 set j
[lsearch
-exact $ids $nullid2]
5870 if {[llength
$ids] > 1 && $j < 0} {
5871 # comparing working directory with some specific revision
5872 set cmd
[concat | git diff-index
$flags]
5874 lappend cmd
-R [lindex
$ids 1]
5876 lappend cmd
[lindex
$ids 0]
5879 # comparing working directory with index
5880 set cmd
[concat | git diff-files
$flags]
5885 } elseif
{$j >= 0} {
5886 set cmd
[concat | git diff-index
--cached $flags]
5887 if {[llength
$ids] > 1} {
5888 # comparing index with specific revision
5890 lappend cmd
-R [lindex
$ids 1]
5892 lappend cmd
[lindex
$ids 0]
5895 # comparing index with HEAD
5899 set cmd
[concat | git diff-tree
-r $flags $ids]
5904 proc gettreediffs
{ids
} {
5905 global treediff treepending
5907 set treepending
$ids
5909 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5910 fconfigure
$gdtf -blocking 0
5911 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5914 proc gettreediffline
{gdtf ids
} {
5915 global treediff treediffs treepending diffids diffmergeid
5916 global cmitmode viewfiles curview limitdiffs
5919 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5920 set i
[string first
"\t" $line]
5922 set file [string range
$line [expr {$i+1}] end
]
5923 if {[string index
$file 0] eq
"\""} {
5924 set file [lindex
$file 0]
5926 lappend treediff
$file
5930 return [expr {$nr >= 1000?
2: 1}]
5933 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5935 foreach f
$treediff {
5936 if {[path_filter
$viewfiles($curview) $f]} {
5940 set treediffs
($ids) $flist
5942 set treediffs
($ids) $treediff
5945 if {$cmitmode eq
"tree"} {
5947 } elseif
{$ids != $diffids} {
5948 if {![info exists diffmergeid
]} {
5949 gettreediffs
$diffids
5957 # empty string or positive integer
5958 proc diffcontextvalidate
{v
} {
5959 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5962 proc diffcontextchange
{n1 n2 op
} {
5963 global diffcontextstring diffcontext
5965 if {[string is integer
-strict $diffcontextstring]} {
5966 if {$diffcontextstring > 0} {
5967 set diffcontext
$diffcontextstring
5973 proc getblobdiffs
{ids
} {
5974 global blobdifffd diffids env
5975 global diffinhdr treediffs
5977 global limitdiffs viewfiles curview
5979 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5980 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5981 set cmd
[concat
$cmd -- $viewfiles($curview)]
5983 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5984 puts
"error getting diffs: $err"
5988 fconfigure
$bdf -blocking 0
5989 set blobdifffd
($ids) $bdf
5990 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5993 proc setinlist
{var i val
} {
5996 while {[llength
[set $var]] < $i} {
5999 if {[llength
[set $var]] == $i} {
6006 proc makediffhdr
{fname ids
} {
6007 global ctext curdiffstart treediffs
6009 set i
[lsearch
-exact $treediffs($ids) $fname]
6011 setinlist difffilestart
$i $curdiffstart
6013 set l
[expr {(78 - [string length
$fname]) / 2}]
6014 set pad
[string range
"----------------------------------------" 1 $l]
6015 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
6018 proc getblobdiffline
{bdf ids
} {
6019 global diffids blobdifffd ctext curdiffstart
6020 global diffnexthead diffnextnote difffilestart
6021 global diffinhdr treediffs
6024 $ctext conf
-state normal
6025 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
6026 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
6030 if {![string compare
-length 11 "diff --git " $line]} {
6031 # trim off "diff --git "
6032 set line
[string range
$line 11 end
]
6034 # start of a new file
6035 $ctext insert end
"\n"
6036 set curdiffstart
[$ctext index
"end - 1c"]
6037 $ctext insert end
"\n" filesep
6038 # If the name hasn't changed the length will be odd,
6039 # the middle char will be a space, and the two bits either
6040 # side will be a/name and b/name, or "a/name" and "b/name".
6041 # If the name has changed we'll get "rename from" and
6042 # "rename to" or "copy from" and "copy to" lines following this,
6043 # and we'll use them to get the filenames.
6044 # This complexity is necessary because spaces in the filename(s)
6045 # don't get escaped.
6046 set l
[string length
$line]
6047 set i
[expr {$l / 2}]
6048 if {!(($l & 1) && [string index
$line $i] eq
" " &&
6049 [string range
$line 2 [expr {$i - 1}]] eq \
6050 [string range
$line [expr {$i + 3}] end
])} {
6053 # unescape if quoted and chop off the a/ from the front
6054 if {[string index
$line 0] eq
"\""} {
6055 set fname
[string range
[lindex
$line 0] 2 end
]
6057 set fname
[string range
$line 2 [expr {$i - 1}]]
6059 makediffhdr
$fname $ids
6061 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
6062 $line match f1l f1c f2l f2c rest
]} {
6063 $ctext insert end
"$line\n" hunksep
6066 } elseif
{$diffinhdr} {
6067 if {![string compare
-length 12 "rename from " $line]} {
6068 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
6069 if {[string index
$fname 0] eq
"\""} {
6070 set fname
[lindex
$fname 0]
6072 set i
[lsearch
-exact $treediffs($ids) $fname]
6074 setinlist difffilestart
$i $curdiffstart
6076 } elseif
{![string compare
-length 10 $line "rename to "] ||
6077 ![string compare
-length 8 $line "copy to "]} {
6078 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
6079 if {[string index
$fname 0] eq
"\""} {
6080 set fname
[lindex
$fname 0]
6082 makediffhdr
$fname $ids
6083 } elseif
{[string compare
-length 3 $line "---"] == 0} {
6086 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
6090 $ctext insert end
"$line\n" filesep
6093 set x
[string range
$line 0 0]
6094 if {$x == "-" ||
$x == "+"} {
6095 set tag
[expr {$x == "+"}]
6096 $ctext insert end
"$line\n" d
$tag
6097 } elseif
{$x == " "} {
6098 $ctext insert end
"$line\n"
6100 # "\ No newline at end of file",
6101 # or something else we don't recognize
6102 $ctext insert end
"$line\n" hunksep
6106 $ctext conf
-state disabled
6111 return [expr {$nr >= 1000?
2: 1}]
6114 proc changediffdisp
{} {
6115 global ctext diffelide
6117 $ctext tag conf d0
-elide [lindex
$diffelide 0]
6118 $ctext tag conf d1
-elide [lindex
$diffelide 1]
6122 global difffilestart ctext
6123 set prev
[lindex
$difffilestart 0]
6124 set here
[$ctext index @
0,0]
6125 foreach loc
$difffilestart {
6126 if {[$ctext compare
$loc >= $here]} {
6136 global difffilestart ctext
6137 set here
[$ctext index @
0,0]
6138 foreach loc
$difffilestart {
6139 if {[$ctext compare
$loc > $here]} {
6146 proc clear_ctext
{{first
1.0}} {
6147 global ctext smarktop smarkbot
6150 set l
[lindex
[split $first .
] 0]
6151 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
6154 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
6157 $ctext delete
$first end
6158 if {$first eq
"1.0"} {
6159 catch
{unset pendinglinks
}
6163 proc settabs
{{firstab
{}}} {
6164 global firsttabstop tabstop ctext have_tk85
6166 if {$firstab ne
{} && $have_tk85} {
6167 set firsttabstop
$firstab
6169 set w
[font measure textfont
"0"]
6170 if {$firsttabstop != 0} {
6171 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
6172 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6173 } elseif
{$have_tk85 ||
$tabstop != 8} {
6174 $ctext conf
-tabs [expr {$tabstop * $w}]
6176 $ctext conf
-tabs {}
6180 proc incrsearch
{name ix op
} {
6181 global ctext searchstring searchdirn
6183 $ctext tag remove found
1.0 end
6184 if {[catch
{$ctext index anchor
}]} {
6185 # no anchor set, use start of selection, or of visible area
6186 set sel
[$ctext tag ranges sel
]
6188 $ctext mark
set anchor
[lindex
$sel 0]
6189 } elseif
{$searchdirn eq
"-forwards"} {
6190 $ctext mark
set anchor @
0,0
6192 $ctext mark
set anchor @
0,[winfo height
$ctext]
6195 if {$searchstring ne
{}} {
6196 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
6205 global sstring ctext searchstring searchdirn
6208 $sstring icursor end
6209 set searchdirn
-forwards
6210 if {$searchstring ne
{}} {
6211 set sel
[$ctext tag ranges sel
]
6213 set start
"[lindex $sel 0] + 1c"
6214 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6217 set match
[$ctext search
-count mlen
-- $searchstring $start]
6218 $ctext tag remove sel
1.0 end
6224 set mend
"$match + $mlen c"
6225 $ctext tag add sel
$match $mend
6226 $ctext mark
unset anchor
6230 proc dosearchback
{} {
6231 global sstring ctext searchstring searchdirn
6234 $sstring icursor end
6235 set searchdirn
-backwards
6236 if {$searchstring ne
{}} {
6237 set sel
[$ctext tag ranges sel
]
6239 set start
[lindex
$sel 0]
6240 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6241 set start @
0,[winfo height
$ctext]
6243 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
6244 $ctext tag remove sel
1.0 end
6250 set mend
"$match + $ml c"
6251 $ctext tag add sel
$match $mend
6252 $ctext mark
unset anchor
6256 proc searchmark
{first last
} {
6257 global ctext searchstring
6261 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
6262 if {$match eq
{}} break
6263 set mend
"$match + $mlen c"
6264 $ctext tag add found
$match $mend
6268 proc searchmarkvisible
{doall
} {
6269 global ctext smarktop smarkbot
6271 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
6272 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
6273 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
6274 # no overlap with previous
6275 searchmark
$topline $botline
6276 set smarktop
$topline
6277 set smarkbot
$botline
6279 if {$topline < $smarktop} {
6280 searchmark
$topline [expr {$smarktop-1}]
6281 set smarktop
$topline
6283 if {$botline > $smarkbot} {
6284 searchmark
[expr {$smarkbot+1}] $botline
6285 set smarkbot
$botline
6290 proc scrolltext
{f0 f1
} {
6293 .bleft.sb
set $f0 $f1
6294 if {$searchstring ne
{}} {
6300 global linespc charspc canvx0 canvy0
6301 global xspc1 xspc2 lthickness
6303 set linespc
[font metrics mainfont
-linespace]
6304 set charspc
[font measure mainfont
"m"]
6305 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
6306 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
6307 set lthickness
[expr {int
($linespc / 9) + 1}]
6308 set xspc1
(0) $linespc
6316 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6317 if {$ymax eq
{} ||
$ymax == 0} return
6318 set span
[$canv yview
]
6321 allcanvs yview moveto
[lindex
$span 0]
6323 if {[info exists selectedline
]} {
6324 selectline
$selectedline 0
6325 allcanvs yview moveto
[lindex
$span 0]
6329 proc parsefont
{f n
} {
6332 set fontattr
($f,family
) [lindex
$n 0]
6334 if {$s eq
{} ||
$s == 0} {
6337 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
6339 set fontattr
($f,size
) $s
6340 set fontattr
($f,weight
) normal
6341 set fontattr
($f,slant
) roman
6342 foreach style
[lrange
$n 2 end
] {
6345 "bold" {set fontattr
($f,weight
) $style}
6347 "italic" {set fontattr
($f,slant
) $style}
6352 proc fontflags
{f
{isbold
0}} {
6355 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
6356 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
6357 -slant $fontattr($f,slant
)]
6363 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
6364 if {$fontattr($f,weight
) eq
"bold"} {
6367 if {$fontattr($f,slant
) eq
"italic"} {
6373 proc incrfont
{inc
} {
6374 global mainfont textfont ctext canv cflist showrefstop
6375 global stopped entries fontattr
6378 set s
$fontattr(mainfont
,size
)
6383 set fontattr
(mainfont
,size
) $s
6384 font config mainfont
-size $s
6385 font config mainfontbold
-size $s
6386 set mainfont
[fontname mainfont
]
6387 set s
$fontattr(textfont
,size
)
6392 set fontattr
(textfont
,size
) $s
6393 font config textfont
-size $s
6394 font config textfontbold
-size $s
6395 set textfont
[fontname textfont
]
6402 global sha1entry sha1string
6403 if {[string length
$sha1string] == 40} {
6404 $sha1entry delete
0 end
6408 proc sha1change
{n1 n2 op
} {
6409 global sha1string currentid sha1but
6410 if {$sha1string == {}
6411 ||
([info exists currentid
] && $sha1string == $currentid)} {
6416 if {[$sha1but cget
-state] == $state} return
6417 if {$state == "normal"} {
6418 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
6420 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
6424 proc gotocommit
{} {
6425 global sha1string tagids headids curview varcid
6427 if {$sha1string == {}
6428 ||
([info exists currentid
] && $sha1string == $currentid)} return
6429 if {[info exists tagids
($sha1string)]} {
6430 set id
$tagids($sha1string)
6431 } elseif
{[info exists headids
($sha1string)]} {
6432 set id
$headids($sha1string)
6434 set id
[string tolower
$sha1string]
6435 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
6436 set matches
[array names varcid
"$curview,$id*"]
6437 if {$matches ne
{}} {
6438 if {[llength
$matches] > 1} {
6439 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
6442 set id
[lindex
[split [lindex
$matches 0] ","] 1]
6446 if {[commitinview
$id $curview]} {
6447 selectline
[rowofcommit
$id] 1
6450 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
6451 set msg
[mc
"SHA1 id %s is not known" $sha1string]
6453 set msg
[mc
"Tag/Head %s is not known" $sha1string]
6458 proc lineenter
{x y id
} {
6459 global hoverx hovery hoverid hovertimer
6460 global commitinfo canv
6462 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6466 if {[info exists hovertimer
]} {
6467 after cancel
$hovertimer
6469 set hovertimer
[after
500 linehover
]
6473 proc linemotion
{x y id
} {
6474 global hoverx hovery hoverid hovertimer
6476 if {[info exists hoverid
] && $id == $hoverid} {
6479 if {[info exists hovertimer
]} {
6480 after cancel
$hovertimer
6482 set hovertimer
[after
500 linehover
]
6486 proc lineleave
{id
} {
6487 global hoverid hovertimer canv
6489 if {[info exists hoverid
] && $id == $hoverid} {
6491 if {[info exists hovertimer
]} {
6492 after cancel
$hovertimer
6500 global hoverx hovery hoverid hovertimer
6501 global canv linespc lthickness
6504 set text
[lindex
$commitinfo($hoverid) 0]
6505 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6506 if {$ymax == {}} return
6507 set yfrac
[lindex
[$canv yview
] 0]
6508 set x
[expr {$hoverx + 2 * $linespc}]
6509 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6510 set x0
[expr {$x - 2 * $lthickness}]
6511 set y0
[expr {$y - 2 * $lthickness}]
6512 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
6513 set y1
[expr {$y + $linespc + 2 * $lthickness}]
6514 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
6515 -fill \
#ffff80 -outline black -width 1 -tags hover]
6517 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
6522 proc clickisonarrow
{id y
} {
6525 set ranges
[rowranges
$id]
6526 set thresh
[expr {2 * $lthickness + 6}]
6527 set n
[expr {[llength
$ranges] - 1}]
6528 for {set i
1} {$i < $n} {incr i
} {
6529 set row
[lindex
$ranges $i]
6530 if {abs
([yc
$row] - $y) < $thresh} {
6537 proc arrowjump
{id n y
} {
6540 # 1 <-> 2, 3 <-> 4, etc...
6541 set n
[expr {(($n - 1) ^
1) + 1}]
6542 set row
[lindex
[rowranges
$id] $n]
6544 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6545 if {$ymax eq
{} ||
$ymax <= 0} return
6546 set view
[$canv yview
]
6547 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
6548 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
6552 allcanvs yview moveto
$yfrac
6555 proc lineclick
{x y id isnew
} {
6556 global ctext commitinfo children canv thickerline curview
6558 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6563 # draw this line thicker than normal
6567 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6568 if {$ymax eq
{}} return
6569 set yfrac
[lindex
[$canv yview
] 0]
6570 set y
[expr {$y + $yfrac * $ymax}]
6572 set dirn
[clickisonarrow
$id $y]
6574 arrowjump
$id $dirn $y
6579 addtohistory
[list lineclick
$x $y $id 0]
6581 # fill the details pane with info about this line
6582 $ctext conf
-state normal
6585 $ctext insert end
"[mc "Parent
"]:\t"
6586 $ctext insert end
$id link0
6588 set info
$commitinfo($id)
6589 $ctext insert end
"\n\t[lindex $info 0]\n"
6590 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
6591 set date [formatdate
[lindex
$info 2]]
6592 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
6593 set kids
$children($curview,$id)
6595 $ctext insert end
"\n[mc "Children
"]:"
6597 foreach child
$kids {
6599 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
6600 set info
$commitinfo($child)
6601 $ctext insert end
"\n\t"
6602 $ctext insert end
$child link
$i
6603 setlink
$child link
$i
6604 $ctext insert end
"\n\t[lindex $info 0]"
6605 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
6606 set date [formatdate
[lindex
$info 2]]
6607 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
6610 $ctext conf
-state disabled
6614 proc normalline
{} {
6616 if {[info exists thickerline
]} {
6625 if {[commitinview
$id $curview]} {
6626 selectline
[rowofcommit
$id] 1
6632 if {![info exists startmstime
]} {
6633 set startmstime
[clock clicks
-milliseconds]
6635 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
6638 proc rowmenu
{x y id
} {
6639 global rowctxmenu selectedline rowmenuid curview
6640 global nullid nullid2 fakerowmenu mainhead
6644 if {![info exists selectedline
]
6645 ||
[rowofcommit
$id] eq
$selectedline} {
6650 if {$id ne
$nullid && $id ne
$nullid2} {
6651 set menu
$rowctxmenu
6652 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6654 set menu
$fakerowmenu
6656 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6657 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6658 $menu entryconfigure
[mc
"Make patch"] -state $state
6659 tk_popup
$menu $x $y
6662 proc diffvssel
{dirn
} {
6663 global rowmenuid selectedline
6665 if {![info exists selectedline
]} return
6667 set oldid
[commitonrow
$selectedline]
6668 set newid
$rowmenuid
6670 set oldid
$rowmenuid
6671 set newid
[commitonrow
$selectedline]
6673 addtohistory
[list doseldiff
$oldid $newid]
6674 doseldiff
$oldid $newid
6677 proc doseldiff
{oldid newid
} {
6681 $ctext conf
-state normal
6683 init_flist
[mc
"Top"]
6684 $ctext insert end
"[mc "From
"] "
6685 $ctext insert end
$oldid link0
6686 setlink
$oldid link0
6687 $ctext insert end
"\n "
6688 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6689 $ctext insert end
"\n\n[mc "To
"] "
6690 $ctext insert end
$newid link1
6691 setlink
$newid link1
6692 $ctext insert end
"\n "
6693 $ctext insert end
[lindex
$commitinfo($newid) 0]
6694 $ctext insert end
"\n"
6695 $ctext conf
-state disabled
6696 $ctext tag remove found
1.0 end
6697 startdiff
[list
$oldid $newid]
6701 global rowmenuid currentid commitinfo patchtop patchnum
6703 if {![info exists currentid
]} return
6704 set oldid
$currentid
6705 set oldhead
[lindex
$commitinfo($oldid) 0]
6706 set newid
$rowmenuid
6707 set newhead
[lindex
$commitinfo($newid) 0]
6710 catch
{destroy
$top}
6712 label
$top.title
-text [mc
"Generate patch"]
6713 grid
$top.title
- -pady 10
6714 label
$top.from
-text [mc
"From:"]
6715 entry
$top.fromsha1
-width 40 -relief flat
6716 $top.fromsha1 insert
0 $oldid
6717 $top.fromsha1 conf
-state readonly
6718 grid
$top.from
$top.fromsha1
-sticky w
6719 entry
$top.fromhead
-width 60 -relief flat
6720 $top.fromhead insert
0 $oldhead
6721 $top.fromhead conf
-state readonly
6722 grid x
$top.fromhead
-sticky w
6723 label
$top.to
-text [mc
"To:"]
6724 entry
$top.tosha1
-width 40 -relief flat
6725 $top.tosha1 insert
0 $newid
6726 $top.tosha1 conf
-state readonly
6727 grid
$top.to
$top.tosha1
-sticky w
6728 entry
$top.tohead
-width 60 -relief flat
6729 $top.tohead insert
0 $newhead
6730 $top.tohead conf
-state readonly
6731 grid x
$top.tohead
-sticky w
6732 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6733 grid
$top.
rev x
-pady 10
6734 label
$top.flab
-text [mc
"Output file:"]
6735 entry
$top.fname
-width 60
6736 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6738 grid
$top.flab
$top.fname
-sticky w
6740 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6741 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6742 grid
$top.buts.gen
$top.buts.can
6743 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6744 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6745 grid
$top.buts
- -pady 10 -sticky ew
6749 proc mkpatchrev
{} {
6752 set oldid
[$patchtop.fromsha1 get
]
6753 set oldhead
[$patchtop.fromhead get
]
6754 set newid
[$patchtop.tosha1 get
]
6755 set newhead
[$patchtop.tohead get
]
6756 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6757 v
[list
$newid $newhead $oldid $oldhead] {
6758 $patchtop.
$e conf
-state normal
6759 $patchtop.
$e delete
0 end
6760 $patchtop.
$e insert
0 $v
6761 $patchtop.
$e conf
-state readonly
6766 global patchtop nullid nullid2
6768 set oldid
[$patchtop.fromsha1 get
]
6769 set newid
[$patchtop.tosha1 get
]
6770 set fname
[$patchtop.fname get
]
6771 set cmd
[diffcmd
[list
$oldid $newid] -p]
6772 # trim off the initial "|"
6773 set cmd
[lrange
$cmd 1 end
]
6774 lappend cmd
>$fname &
6775 if {[catch
{eval exec $cmd} err
]} {
6776 error_popup
"[mc "Error creating
patch:"] $err"
6778 catch
{destroy
$patchtop}
6782 proc mkpatchcan
{} {
6785 catch
{destroy
$patchtop}
6790 global rowmenuid mktagtop commitinfo
6794 catch
{destroy
$top}
6796 label
$top.title
-text [mc
"Create tag"]
6797 grid
$top.title
- -pady 10
6798 label
$top.id
-text [mc
"ID:"]
6799 entry
$top.sha1
-width 40 -relief flat
6800 $top.sha1 insert
0 $rowmenuid
6801 $top.sha1 conf
-state readonly
6802 grid
$top.id
$top.sha1
-sticky w
6803 entry
$top.
head -width 60 -relief flat
6804 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6805 $top.
head conf
-state readonly
6806 grid x
$top.
head -sticky w
6807 label
$top.tlab
-text [mc
"Tag name:"]
6808 entry
$top.tag
-width 60
6809 grid
$top.tlab
$top.tag
-sticky w
6811 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6812 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6813 grid
$top.buts.gen
$top.buts.can
6814 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6815 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6816 grid
$top.buts
- -pady 10 -sticky ew
6821 global mktagtop env tagids idtags
6823 set id
[$mktagtop.sha1 get
]
6824 set tag
[$mktagtop.tag get
]
6826 error_popup
[mc
"No tag name specified"]
6829 if {[info exists tagids
($tag)]} {
6830 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6835 set fname
[file join $dir "refs/tags" $tag]
6836 set f
[open
$fname w
]
6840 error_popup
"[mc "Error creating tag
:"] $err"
6844 set tagids
($tag) $id
6845 lappend idtags
($id) $tag
6852 proc redrawtags
{id
} {
6853 global canv linehtag idpos currentid curview
6854 global canvxmax iddrawn
6856 if {![commitinview
$id $curview]} return
6857 if {![info exists iddrawn
($id)]} return
6858 set row
[rowofcommit
$id]
6859 $canv delete tag.
$id
6860 set xt
[eval drawtags
$id $idpos($id)]
6861 $canv coords
$linehtag($row) $xt [lindex
$idpos($id) 2]
6862 set text
[$canv itemcget
$linehtag($row) -text]
6863 set font
[$canv itemcget
$linehtag($row) -font]
6864 set xr
[expr {$xt + [font measure
$font $text]}]
6865 if {$xr > $canvxmax} {
6869 if {[info exists currentid
] && $currentid == $id} {
6877 catch
{destroy
$mktagtop}
6886 proc writecommit
{} {
6887 global rowmenuid wrcomtop commitinfo wrcomcmd
6889 set top .writecommit
6891 catch
{destroy
$top}
6893 label
$top.title
-text [mc
"Write commit to file"]
6894 grid
$top.title
- -pady 10
6895 label
$top.id
-text [mc
"ID:"]
6896 entry
$top.sha1
-width 40 -relief flat
6897 $top.sha1 insert
0 $rowmenuid
6898 $top.sha1 conf
-state readonly
6899 grid
$top.id
$top.sha1
-sticky w
6900 entry
$top.
head -width 60 -relief flat
6901 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6902 $top.
head conf
-state readonly
6903 grid x
$top.
head -sticky w
6904 label
$top.clab
-text [mc
"Command:"]
6905 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6906 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6907 label
$top.flab
-text [mc
"Output file:"]
6908 entry
$top.fname
-width 60
6909 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6910 grid
$top.flab
$top.fname
-sticky w
6912 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6913 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6914 grid
$top.buts.gen
$top.buts.can
6915 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6916 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6917 grid
$top.buts
- -pady 10 -sticky ew
6924 set id
[$wrcomtop.sha1 get
]
6925 set cmd
"echo $id | [$wrcomtop.cmd get]"
6926 set fname
[$wrcomtop.fname get
]
6927 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6928 error_popup
"[mc "Error writing commit
:"] $err"
6930 catch
{destroy
$wrcomtop}
6937 catch
{destroy
$wrcomtop}
6942 global rowmenuid mkbrtop
6945 catch
{destroy
$top}
6947 label
$top.title
-text [mc
"Create new branch"]
6948 grid
$top.title
- -pady 10
6949 label
$top.id
-text [mc
"ID:"]
6950 entry
$top.sha1
-width 40 -relief flat
6951 $top.sha1 insert
0 $rowmenuid
6952 $top.sha1 conf
-state readonly
6953 grid
$top.id
$top.sha1
-sticky w
6954 label
$top.nlab
-text [mc
"Name:"]
6955 entry
$top.name
-width 40
6956 grid
$top.nlab
$top.name
-sticky w
6958 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6959 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6960 grid
$top.buts.go
$top.buts.can
6961 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6962 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6963 grid
$top.buts
- -pady 10 -sticky ew
6968 global headids idheads
6970 set name
[$top.name get
]
6971 set id
[$top.sha1 get
]
6973 error_popup
[mc
"Please specify a name for the new branch"]
6976 catch
{destroy
$top}
6980 exec git branch
$name $id
6985 set headids
($name) $id
6986 lappend idheads
($id) $name
6995 proc cherrypick
{} {
6996 global rowmenuid curview
6999 set oldhead
[exec git rev-parse HEAD
]
7000 set dheads
[descheads
$rowmenuid]
7001 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
7002 set ok
[confirm_popup
[mc
"Commit %s is already\
7003 included in branch %s -- really re-apply it?" \
7004 [string range
$rowmenuid 0 7] $mainhead]]
7007 nowbusy cherrypick
[mc
"Cherry-picking"]
7009 # Unfortunately git-cherry-pick writes stuff to stderr even when
7010 # no error occurs, and exec takes that as an indication of error...
7011 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
7016 set newhead
[exec git rev-parse HEAD
]
7017 if {$newhead eq
$oldhead} {
7019 error_popup
[mc
"No changes committed"]
7022 addnewchild
$newhead $oldhead
7023 if {[commitinview
$oldhead $curview]} {
7024 insertrow
$newhead $oldhead $curview
7025 if {$mainhead ne
{}} {
7026 movehead
$newhead $mainhead
7027 movedhead
$newhead $mainhead
7037 global mainheadid mainhead rowmenuid confirm_ok resettype
7040 set w
".confirmreset"
7043 wm title
$w [mc
"Confirm reset"]
7044 message
$w.m
-text \
7045 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
7046 -justify center
-aspect 1000
7047 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
7048 frame
$w.f
-relief sunken
-border 2
7049 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
7050 grid
$w.f.rt
-sticky w
7052 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
7053 -text [mc
"Soft: Leave working tree and index untouched"]
7054 grid
$w.f.soft
-sticky w
7055 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
7056 -text [mc
"Mixed: Leave working tree untouched, reset index"]
7057 grid
$w.f.mixed
-sticky w
7058 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
7059 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
7060 grid
$w.f.hard
-sticky w
7061 pack
$w.f
-side top
-fill x
7062 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
7063 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
7064 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
7065 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
7066 bind $w <Visibility
> "grab $w; focus $w"
7068 if {!$confirm_ok} return
7069 if {[catch
{set fd
[open \
7070 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
7074 filerun
$fd [list readresetstat
$fd]
7075 nowbusy
reset [mc
"Resetting"]
7080 proc readresetstat
{fd
} {
7081 global mainhead mainheadid showlocalchanges rprogcoord
7083 if {[gets
$fd line
] >= 0} {
7084 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
7085 set rprogcoord
[expr {1.0 * $m / $n}]
7093 if {[catch
{close
$fd} err
]} {
7096 set oldhead
$mainheadid
7097 set newhead
[exec git rev-parse HEAD
]
7098 if {$newhead ne
$oldhead} {
7099 movehead
$newhead $mainhead
7100 movedhead
$newhead $mainhead
7101 set mainheadid
$newhead
7105 if {$showlocalchanges} {
7111 # context menu for a head
7112 proc headmenu
{x y id
head} {
7113 global headmenuid headmenuhead headctxmenu mainhead
7117 set headmenuhead
$head
7119 if {$head eq
$mainhead} {
7122 $headctxmenu entryconfigure
0 -state $state
7123 $headctxmenu entryconfigure
1 -state $state
7124 tk_popup
$headctxmenu $x $y
7128 global headmenuid headmenuhead mainhead headids
7129 global showlocalchanges mainheadid
7131 # check the tree is clean first??
7132 set oldmainhead
$mainhead
7133 nowbusy checkout
[mc
"Checking out"]
7137 exec git checkout
-q $headmenuhead
7143 set mainhead
$headmenuhead
7144 set mainheadid
$headmenuid
7145 if {[info exists headids
($oldmainhead)]} {
7146 redrawtags
$headids($oldmainhead)
7148 redrawtags
$headmenuid
7151 if {$showlocalchanges} {
7157 global headmenuid headmenuhead mainhead
7160 set head $headmenuhead
7162 # this check shouldn't be needed any more...
7163 if {$head eq
$mainhead} {
7164 error_popup
[mc
"Cannot delete the currently checked-out branch"]
7167 set dheads
[descheads
$id]
7168 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
7169 # the stuff on this branch isn't on any other branch
7170 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
7171 branch.\nReally delete branch %s?" $head $head]]} return
7175 if {[catch
{exec git branch
-D $head} err
]} {
7180 removehead
$id $head
7181 removedhead
$id $head
7188 # Display a list of tags and heads
7190 global showrefstop bgcolor fgcolor selectbgcolor
7191 global bglist fglist reflistfilter reflist maincursor
7194 set showrefstop
$top
7195 if {[winfo exists
$top]} {
7201 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
7202 text
$top.list
-background $bgcolor -foreground $fgcolor \
7203 -selectbackground $selectbgcolor -font mainfont \
7204 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7205 -width 30 -height 20 -cursor $maincursor \
7206 -spacing1 1 -spacing3 1 -state disabled
7207 $top.list tag configure highlight
-background $selectbgcolor
7208 lappend bglist
$top.list
7209 lappend fglist
$top.list
7210 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
7211 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
7212 grid
$top.list
$top.ysb
-sticky nsew
7213 grid
$top.xsb x
-sticky ew
7215 label
$top.f.l
-text "[mc "Filter
"]: "
7216 entry
$top.f.e
-width 20 -textvariable reflistfilter
7217 set reflistfilter
"*"
7218 trace add variable reflistfilter
write reflistfilter_change
7219 pack
$top.f.e
-side right
-fill x
-expand 1
7220 pack
$top.f.l
-side left
7221 grid
$top.f
- -sticky ew
-pady 2
7222 button
$top.close
-command [list destroy
$top] -text [mc
"Close"]
7224 grid columnconfigure
$top 0 -weight 1
7225 grid rowconfigure
$top 0 -weight 1
7226 bind $top.list
<1> {break}
7227 bind $top.list
<B1-Motion
> {break}
7228 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
7233 proc sel_reflist
{w x y
} {
7234 global showrefstop reflist headids tagids otherrefids
7236 if {![winfo exists
$showrefstop]} return
7237 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
7238 set ref
[lindex
$reflist [expr {$l-1}]]
7239 set n
[lindex
$ref 0]
7240 switch
-- [lindex
$ref 1] {
7241 "H" {selbyid
$headids($n)}
7242 "T" {selbyid
$tagids($n)}
7243 "o" {selbyid
$otherrefids($n)}
7245 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
7248 proc unsel_reflist
{} {
7251 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7252 $showrefstop.list tag remove highlight
0.0 end
7255 proc reflistfilter_change
{n1 n2 op
} {
7256 global reflistfilter
7258 after cancel refill_reflist
7259 after
200 refill_reflist
7262 proc refill_reflist
{} {
7263 global reflist reflistfilter showrefstop headids tagids otherrefids
7264 global curview commitinterest
7266 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7268 foreach n
[array names headids
] {
7269 if {[string match
$reflistfilter $n]} {
7270 if {[commitinview
$headids($n) $curview]} {
7271 lappend refs
[list
$n H
]
7273 set commitinterest
($headids($n)) {run refill_reflist
}
7277 foreach n
[array names tagids
] {
7278 if {[string match
$reflistfilter $n]} {
7279 if {[commitinview
$tagids($n) $curview]} {
7280 lappend refs
[list
$n T
]
7282 set commitinterest
($tagids($n)) {run refill_reflist
}
7286 foreach n
[array names otherrefids
] {
7287 if {[string match
$reflistfilter $n]} {
7288 if {[commitinview
$otherrefids($n) $curview]} {
7289 lappend refs
[list
$n o
]
7291 set commitinterest
($otherrefids($n)) {run refill_reflist
}
7295 set refs
[lsort
-index 0 $refs]
7296 if {$refs eq
$reflist} return
7298 # Update the contents of $showrefstop.list according to the
7299 # differences between $reflist (old) and $refs (new)
7300 $showrefstop.list conf
-state normal
7301 $showrefstop.list insert end
"\n"
7304 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
7305 if {$i < [llength
$reflist]} {
7306 if {$j < [llength
$refs]} {
7307 set cmp [string compare
[lindex
$reflist $i 0] \
7308 [lindex
$refs $j 0]]
7310 set cmp [string compare
[lindex
$reflist $i 1] \
7311 [lindex
$refs $j 1]]
7321 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
7329 set l
[expr {$j + 1}]
7330 $showrefstop.list image create
$l.0 -align baseline \
7331 -image reficon-
[lindex
$refs $j 1] -padx 2
7332 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
7338 # delete last newline
7339 $showrefstop.list delete end-2c end-1c
7340 $showrefstop.list conf
-state disabled
7343 # Stuff for finding nearby tags
7344 proc getallcommits
{} {
7345 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7346 global idheads idtags idotherrefs allparents tagobjid
7348 if {![info exists allcommits
]} {
7354 set allccache
[file join [gitdir
] "gitk.cache"]
7356 set f
[open
$allccache r
]
7365 set cmd
[list | git rev-list
--parents]
7366 set allcupdate
[expr {$seeds ne
{}}]
7370 set refs
[concat
[array names idheads
] [array names idtags
] \
7371 [array names idotherrefs
]]
7374 foreach name
[array names tagobjid
] {
7375 lappend tagobjs
$tagobjid($name)
7377 foreach id
[lsort
-unique $refs] {
7378 if {![info exists allparents
($id)] &&
7379 [lsearch
-exact $tagobjs $id] < 0} {
7390 set fd
[open
[concat
$cmd $ids] r
]
7391 fconfigure
$fd -blocking 0
7394 filerun
$fd [list getallclines
$fd]
7400 # Since most commits have 1 parent and 1 child, we group strings of
7401 # such commits into "arcs" joining branch/merge points (BMPs), which
7402 # are commits that either don't have 1 parent or don't have 1 child.
7404 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7405 # arcout(id) - outgoing arcs for BMP
7406 # arcids(a) - list of IDs on arc including end but not start
7407 # arcstart(a) - BMP ID at start of arc
7408 # arcend(a) - BMP ID at end of arc
7409 # growing(a) - arc a is still growing
7410 # arctags(a) - IDs out of arcids (excluding end) that have tags
7411 # archeads(a) - IDs out of arcids (excluding end) that have heads
7412 # The start of an arc is at the descendent end, so "incoming" means
7413 # coming from descendents, and "outgoing" means going towards ancestors.
7415 proc getallclines
{fd
} {
7416 global allparents allchildren idtags idheads nextarc
7417 global arcnos arcids arctags arcout arcend arcstart archeads growing
7418 global seeds allcommits cachedarcs allcupdate
7421 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
7422 set id
[lindex
$line 0]
7423 if {[info exists allparents
($id)]} {
7428 set olds
[lrange
$line 1 end
]
7429 set allparents
($id) $olds
7430 if {![info exists allchildren
($id)]} {
7431 set allchildren
($id) {}
7436 if {[llength
$olds] == 1 && [llength
$a] == 1} {
7437 lappend arcids
($a) $id
7438 if {[info exists idtags
($id)]} {
7439 lappend arctags
($a) $id
7441 if {[info exists idheads
($id)]} {
7442 lappend archeads
($a) $id
7444 if {[info exists allparents
($olds)]} {
7445 # seen parent already
7446 if {![info exists arcout
($olds)]} {
7449 lappend arcids
($a) $olds
7450 set arcend
($a) $olds
7453 lappend allchildren
($olds) $id
7454 lappend arcnos
($olds) $a
7458 foreach a
$arcnos($id) {
7459 lappend arcids
($a) $id
7466 lappend allchildren
($p) $id
7467 set a
[incr nextarc
]
7468 set arcstart
($a) $id
7475 if {[info exists allparents
($p)]} {
7476 # seen it already, may need to make a new branch
7477 if {![info exists arcout
($p)]} {
7480 lappend arcids
($a) $p
7484 lappend arcnos
($p) $a
7489 global cached_dheads cached_dtags cached_atags
7490 catch
{unset cached_dheads
}
7491 catch
{unset cached_dtags
}
7492 catch
{unset cached_atags
}
7495 return [expr {$nid >= 1000?
2: 1}]
7499 fconfigure
$fd -blocking 1
7502 # got an error reading the list of commits
7503 # if we were updating, try rereading the whole thing again
7509 error_popup
"[mc "Error reading commit topology information
;\
7510 branch and preceding
/following tag information\
7511 will be incomplete.
"]\n($err)"
7514 if {[incr allcommits
-1] == 0} {
7524 proc recalcarc
{a
} {
7525 global arctags archeads arcids idtags idheads
7529 foreach id
[lrange
$arcids($a) 0 end-1
] {
7530 if {[info exists idtags
($id)]} {
7533 if {[info exists idheads
($id)]} {
7538 set archeads
($a) $ah
7542 global arcnos arcids nextarc arctags archeads idtags idheads
7543 global arcstart arcend arcout allparents growing
7546 if {[llength
$a] != 1} {
7547 puts
"oops splitarc called but [llength $a] arcs already"
7551 set i
[lsearch
-exact $arcids($a) $p]
7553 puts
"oops splitarc $p not in arc $a"
7556 set na
[incr nextarc
]
7557 if {[info exists arcend
($a)]} {
7558 set arcend
($na) $arcend($a)
7560 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
7561 set j
[lsearch
-exact $arcnos($l) $a]
7562 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
7564 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
7565 set arcids
($a) [lrange
$arcids($a) 0 $i]
7567 set arcstart
($na) $p
7569 set arcids
($na) $tail
7570 if {[info exists growing
($a)]} {
7576 if {[llength
$arcnos($id)] == 1} {
7579 set j
[lsearch
-exact $arcnos($id) $a]
7580 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
7584 # reconstruct tags and heads lists
7585 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
7590 set archeads
($na) {}
7594 # Update things for a new commit added that is a child of one
7595 # existing commit. Used when cherry-picking.
7596 proc addnewchild
{id p
} {
7597 global allparents allchildren idtags nextarc
7598 global arcnos arcids arctags arcout arcend arcstart archeads growing
7599 global seeds allcommits
7601 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
7602 set allparents
($id) [list
$p]
7603 set allchildren
($id) {}
7606 lappend allchildren
($p) $id
7607 set a
[incr nextarc
]
7608 set arcstart
($a) $id
7611 set arcids
($a) [list
$p]
7613 if {![info exists arcout
($p)]} {
7616 lappend arcnos
($p) $a
7617 set arcout
($id) [list
$a]
7620 # This implements a cache for the topology information.
7621 # The cache saves, for each arc, the start and end of the arc,
7622 # the ids on the arc, and the outgoing arcs from the end.
7623 proc readcache
{f
} {
7624 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7625 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7630 if {$lim - $a > 500} {
7631 set lim
[expr {$a + 500}]
7635 # finish reading the cache and setting up arctags, etc.
7637 if {$line ne
"1"} {error
"bad final version"}
7639 foreach id
[array names idtags
] {
7640 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7641 [llength
$allparents($id)] == 1} {
7642 set a
[lindex
$arcnos($id) 0]
7643 if {$arctags($a) eq
{}} {
7648 foreach id
[array names idheads
] {
7649 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7650 [llength
$allparents($id)] == 1} {
7651 set a
[lindex
$arcnos($id) 0]
7652 if {$archeads($a) eq
{}} {
7657 foreach id
[lsort
-unique $possible_seeds] {
7658 if {$arcnos($id) eq
{}} {
7664 while {[incr a
] <= $lim} {
7666 if {[llength
$line] != 3} {error
"bad line"}
7667 set s
[lindex
$line 0]
7669 lappend arcout
($s) $a
7670 if {![info exists arcnos
($s)]} {
7671 lappend possible_seeds
$s
7674 set e
[lindex
$line 1]
7679 if {![info exists arcout
($e)]} {
7683 set arcids
($a) [lindex
$line 2]
7684 foreach id
$arcids($a) {
7685 lappend allparents
($s) $id
7687 lappend arcnos
($id) $a
7689 if {![info exists allparents
($s)]} {
7690 set allparents
($s) {}
7695 set nextarc
[expr {$a - 1}]
7708 global nextarc cachedarcs possible_seeds
7712 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7713 # make sure it's an integer
7714 set cachedarcs
[expr {int
([lindex
$line 1])}]
7715 if {$cachedarcs < 0} {error
"bad number of arcs"}
7717 set possible_seeds
{}
7725 proc dropcache
{err
} {
7726 global allcwait nextarc cachedarcs seeds
7728 #puts "dropping cache ($err)"
7729 foreach v
{arcnos arcout arcids arcstart arcend growing \
7730 arctags archeads allparents allchildren
} {
7741 proc writecache
{f
} {
7742 global cachearc cachedarcs allccache
7743 global arcstart arcend arcnos arcids arcout
7747 if {$lim - $a > 1000} {
7748 set lim
[expr {$a + 1000}]
7751 while {[incr a
] <= $lim} {
7752 if {[info exists arcend
($a)]} {
7753 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7755 puts
$f [list
$arcstart($a) {} $arcids($a)]
7760 catch
{file delete
$allccache}
7761 #puts "writing cache failed ($err)"
7764 set cachearc
[expr {$a - 1}]
7765 if {$a > $cachedarcs} {
7774 global nextarc cachedarcs cachearc allccache
7776 if {$nextarc == $cachedarcs} return
7778 set cachedarcs
$nextarc
7780 set f
[open
$allccache w
]
7781 puts
$f [list
1 $cachedarcs]
7786 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7787 # or 0 if neither is true.
7788 proc anc_or_desc
{a b
} {
7789 global arcout arcstart arcend arcnos cached_isanc
7791 if {$arcnos($a) eq
$arcnos($b)} {
7792 # Both are on the same arc(s); either both are the same BMP,
7793 # or if one is not a BMP, the other is also not a BMP or is
7794 # the BMP at end of the arc (and it only has 1 incoming arc).
7795 # Or both can be BMPs with no incoming arcs.
7796 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7799 # assert {[llength $arcnos($a)] == 1}
7800 set arc
[lindex
$arcnos($a) 0]
7801 set i
[lsearch
-exact $arcids($arc) $a]
7802 set j
[lsearch
-exact $arcids($arc) $b]
7803 if {$i < 0 ||
$i > $j} {
7810 if {![info exists arcout
($a)]} {
7811 set arc
[lindex
$arcnos($a) 0]
7812 if {[info exists arcend
($arc)]} {
7813 set aend
$arcend($arc)
7817 set a
$arcstart($arc)
7821 if {![info exists arcout
($b)]} {
7822 set arc
[lindex
$arcnos($b) 0]
7823 if {[info exists arcend
($arc)]} {
7824 set bend
$arcend($arc)
7828 set b
$arcstart($arc)
7838 if {[info exists cached_isanc
($a,$bend)]} {
7839 if {$cached_isanc($a,$bend)} {
7843 if {[info exists cached_isanc
($b,$aend)]} {
7844 if {$cached_isanc($b,$aend)} {
7847 if {[info exists cached_isanc
($a,$bend)]} {
7852 set todo
[list
$a $b]
7855 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7856 set x
[lindex
$todo $i]
7857 if {$anc($x) eq
{}} {
7860 foreach arc
$arcnos($x) {
7861 set xd
$arcstart($arc)
7863 set cached_isanc
($a,$bend) 1
7864 set cached_isanc
($b,$aend) 0
7866 } elseif
{$xd eq
$aend} {
7867 set cached_isanc
($b,$aend) 1
7868 set cached_isanc
($a,$bend) 0
7871 if {![info exists anc
($xd)]} {
7872 set anc
($xd) $anc($x)
7874 } elseif
{$anc($xd) ne
$anc($x)} {
7879 set cached_isanc
($a,$bend) 0
7880 set cached_isanc
($b,$aend) 0
7884 # This identifies whether $desc has an ancestor that is
7885 # a growing tip of the graph and which is not an ancestor of $anc
7886 # and returns 0 if so and 1 if not.
7887 # If we subsequently discover a tag on such a growing tip, and that
7888 # turns out to be a descendent of $anc (which it could, since we
7889 # don't necessarily see children before parents), then $desc
7890 # isn't a good choice to display as a descendent tag of
7891 # $anc (since it is the descendent of another tag which is
7892 # a descendent of $anc). Similarly, $anc isn't a good choice to
7893 # display as a ancestor tag of $desc.
7895 proc is_certain
{desc anc
} {
7896 global arcnos arcout arcstart arcend growing problems
7899 if {[llength
$arcnos($anc)] == 1} {
7900 # tags on the same arc are certain
7901 if {$arcnos($desc) eq
$arcnos($anc)} {
7904 if {![info exists arcout
($anc)]} {
7905 # if $anc is partway along an arc, use the start of the arc instead
7906 set a
[lindex
$arcnos($anc) 0]
7907 set anc
$arcstart($a)
7910 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7913 set a
[lindex
$arcnos($desc) 0]
7919 set anclist
[list
$x]
7923 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7924 set x
[lindex
$anclist $i]
7929 foreach a
$arcout($x) {
7930 if {[info exists growing
($a)]} {
7931 if {![info exists growanc
($x)] && $dl($x)} {
7937 if {[info exists dl
($y)]} {
7941 if {![info exists
done($y)]} {
7944 if {[info exists growanc
($x)]} {
7948 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7949 set z
[lindex
$xl $k]
7950 foreach c
$arcout($z) {
7951 if {[info exists arcend
($c)]} {
7953 if {[info exists dl
($v)] && $dl($v)} {
7955 if {![info exists
done($v)]} {
7958 if {[info exists growanc
($v)]} {
7968 } elseif
{$y eq
$anc ||
!$dl($x)} {
7979 foreach x
[array names growanc
] {
7988 proc validate_arctags
{a
} {
7989 global arctags idtags
7993 foreach id
$arctags($a) {
7995 if {![info exists idtags
($id)]} {
7996 set na
[lreplace
$na $i $i]
8003 proc validate_archeads
{a
} {
8004 global archeads idheads
8007 set na
$archeads($a)
8008 foreach id
$archeads($a) {
8010 if {![info exists idheads
($id)]} {
8011 set na
[lreplace
$na $i $i]
8015 set archeads
($a) $na
8018 # Return the list of IDs that have tags that are descendents of id,
8019 # ignoring IDs that are descendents of IDs already reported.
8020 proc desctags
{id
} {
8021 global arcnos arcstart arcids arctags idtags allparents
8022 global growing cached_dtags
8024 if {![info exists allparents
($id)]} {
8027 set t1
[clock clicks
-milliseconds]
8029 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8030 # part-way along an arc; check that arc first
8031 set a
[lindex
$arcnos($id) 0]
8032 if {$arctags($a) ne
{}} {
8034 set i
[lsearch
-exact $arcids($a) $id]
8036 foreach t
$arctags($a) {
8037 set j
[lsearch
-exact $arcids($a) $t]
8045 set id
$arcstart($a)
8046 if {[info exists idtags
($id)]} {
8050 if {[info exists cached_dtags
($id)]} {
8051 return $cached_dtags($id)
8058 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8059 set id
[lindex
$todo $i]
8061 set ta
[info exists hastaggedancestor
($id)]
8065 # ignore tags on starting node
8066 if {!$ta && $i > 0} {
8067 if {[info exists idtags
($id)]} {
8070 } elseif
{[info exists cached_dtags
($id)]} {
8071 set tagloc
($id) $cached_dtags($id)
8075 foreach a
$arcnos($id) {
8077 if {!$ta && $arctags($a) ne
{}} {
8079 if {$arctags($a) ne
{}} {
8080 lappend tagloc
($id) [lindex
$arctags($a) end
]
8083 if {$ta ||
$arctags($a) ne
{}} {
8084 set tomark
[list
$d]
8085 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8086 set dd [lindex
$tomark $j]
8087 if {![info exists hastaggedancestor
($dd)]} {
8088 if {[info exists
done($dd)]} {
8089 foreach b
$arcnos($dd) {
8090 lappend tomark
$arcstart($b)
8092 if {[info exists tagloc
($dd)]} {
8095 } elseif
{[info exists queued
($dd)]} {
8098 set hastaggedancestor
($dd) 1
8102 if {![info exists queued
($d)]} {
8105 if {![info exists hastaggedancestor
($d)]} {
8112 foreach id
[array names tagloc
] {
8113 if {![info exists hastaggedancestor
($id)]} {
8114 foreach t
$tagloc($id) {
8115 if {[lsearch
-exact $tags $t] < 0} {
8121 set t2
[clock clicks
-milliseconds]
8124 # remove tags that are descendents of other tags
8125 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8126 set a
[lindex
$tags $i]
8127 for {set j
0} {$j < $i} {incr j
} {
8128 set b
[lindex
$tags $j]
8129 set r
[anc_or_desc
$a $b]
8131 set tags
[lreplace
$tags $j $j]
8134 } elseif
{$r == -1} {
8135 set tags
[lreplace
$tags $i $i]
8142 if {[array names growing
] ne
{}} {
8143 # graph isn't finished, need to check if any tag could get
8144 # eclipsed by another tag coming later. Simply ignore any
8145 # tags that could later get eclipsed.
8148 if {[is_certain
$t $origid]} {
8152 if {$tags eq
$ctags} {
8153 set cached_dtags
($origid) $tags
8158 set cached_dtags
($origid) $tags
8160 set t3
[clock clicks
-milliseconds]
8161 if {0 && $t3 - $t1 >= 100} {
8162 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
8163 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8169 global arcnos arcids arcout arcend arctags idtags allparents
8170 global growing cached_atags
8172 if {![info exists allparents
($id)]} {
8175 set t1
[clock clicks
-milliseconds]
8177 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8178 # part-way along an arc; check that arc first
8179 set a
[lindex
$arcnos($id) 0]
8180 if {$arctags($a) ne
{}} {
8182 set i
[lsearch
-exact $arcids($a) $id]
8183 foreach t
$arctags($a) {
8184 set j
[lsearch
-exact $arcids($a) $t]
8190 if {![info exists arcend
($a)]} {
8194 if {[info exists idtags
($id)]} {
8198 if {[info exists cached_atags
($id)]} {
8199 return $cached_atags($id)
8207 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8208 set id
[lindex
$todo $i]
8210 set td
[info exists hastaggeddescendent
($id)]
8214 # ignore tags on starting node
8215 if {!$td && $i > 0} {
8216 if {[info exists idtags
($id)]} {
8219 } elseif
{[info exists cached_atags
($id)]} {
8220 set tagloc
($id) $cached_atags($id)
8224 foreach a
$arcout($id) {
8225 if {!$td && $arctags($a) ne
{}} {
8227 if {$arctags($a) ne
{}} {
8228 lappend tagloc
($id) [lindex
$arctags($a) 0]
8231 if {![info exists arcend
($a)]} continue
8233 if {$td ||
$arctags($a) ne
{}} {
8234 set tomark
[list
$d]
8235 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8236 set dd [lindex
$tomark $j]
8237 if {![info exists hastaggeddescendent
($dd)]} {
8238 if {[info exists
done($dd)]} {
8239 foreach b
$arcout($dd) {
8240 if {[info exists arcend
($b)]} {
8241 lappend tomark
$arcend($b)
8244 if {[info exists tagloc
($dd)]} {
8247 } elseif
{[info exists queued
($dd)]} {
8250 set hastaggeddescendent
($dd) 1
8254 if {![info exists queued
($d)]} {
8257 if {![info exists hastaggeddescendent
($d)]} {
8263 set t2
[clock clicks
-milliseconds]
8266 foreach id
[array names tagloc
] {
8267 if {![info exists hastaggeddescendent
($id)]} {
8268 foreach t
$tagloc($id) {
8269 if {[lsearch
-exact $tags $t] < 0} {
8276 # remove tags that are ancestors of other tags
8277 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8278 set a
[lindex
$tags $i]
8279 for {set j
0} {$j < $i} {incr j
} {
8280 set b
[lindex
$tags $j]
8281 set r
[anc_or_desc
$a $b]
8283 set tags
[lreplace
$tags $j $j]
8286 } elseif
{$r == 1} {
8287 set tags
[lreplace
$tags $i $i]
8294 if {[array names growing
] ne
{}} {
8295 # graph isn't finished, need to check if any tag could get
8296 # eclipsed by another tag coming later. Simply ignore any
8297 # tags that could later get eclipsed.
8300 if {[is_certain
$origid $t]} {
8304 if {$tags eq
$ctags} {
8305 set cached_atags
($origid) $tags
8310 set cached_atags
($origid) $tags
8312 set t3
[clock clicks
-milliseconds]
8313 if {0 && $t3 - $t1 >= 100} {
8314 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
8315 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8320 # Return the list of IDs that have heads that are descendents of id,
8321 # including id itself if it has a head.
8322 proc descheads
{id
} {
8323 global arcnos arcstart arcids archeads idheads cached_dheads
8326 if {![info exists allparents
($id)]} {
8330 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8331 # part-way along an arc; check it first
8332 set a
[lindex
$arcnos($id) 0]
8333 if {$archeads($a) ne
{}} {
8334 validate_archeads
$a
8335 set i
[lsearch
-exact $arcids($a) $id]
8336 foreach t
$archeads($a) {
8337 set j
[lsearch
-exact $arcids($a) $t]
8342 set id
$arcstart($a)
8348 for {set i
0} {$i < [llength
$todo]} {incr i
} {
8349 set id
[lindex
$todo $i]
8350 if {[info exists cached_dheads
($id)]} {
8351 set ret
[concat
$ret $cached_dheads($id)]
8353 if {[info exists idheads
($id)]} {
8356 foreach a
$arcnos($id) {
8357 if {$archeads($a) ne
{}} {
8358 validate_archeads
$a
8359 if {$archeads($a) ne
{}} {
8360 set ret
[concat
$ret $archeads($a)]
8364 if {![info exists seen
($d)]} {
8371 set ret
[lsort
-unique $ret]
8372 set cached_dheads
($origid) $ret
8373 return [concat
$ret $aret]
8376 proc addedtag
{id
} {
8377 global arcnos arcout cached_dtags cached_atags
8379 if {![info exists arcnos
($id)]} return
8380 if {![info exists arcout
($id)]} {
8381 recalcarc
[lindex
$arcnos($id) 0]
8383 catch
{unset cached_dtags
}
8384 catch
{unset cached_atags
}
8387 proc addedhead
{hid
head} {
8388 global arcnos arcout cached_dheads
8390 if {![info exists arcnos
($hid)]} return
8391 if {![info exists arcout
($hid)]} {
8392 recalcarc
[lindex
$arcnos($hid) 0]
8394 catch
{unset cached_dheads
}
8397 proc removedhead
{hid
head} {
8398 global cached_dheads
8400 catch
{unset cached_dheads
}
8403 proc movedhead
{hid
head} {
8404 global arcnos arcout cached_dheads
8406 if {![info exists arcnos
($hid)]} return
8407 if {![info exists arcout
($hid)]} {
8408 recalcarc
[lindex
$arcnos($hid) 0]
8410 catch
{unset cached_dheads
}
8413 proc changedrefs
{} {
8414 global cached_dheads cached_dtags cached_atags
8415 global arctags archeads arcnos arcout idheads idtags
8417 foreach id
[concat
[array names idheads
] [array names idtags
]] {
8418 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
8419 set a
[lindex
$arcnos($id) 0]
8420 if {![info exists donearc
($a)]} {
8426 catch
{unset cached_dtags
}
8427 catch
{unset cached_atags
}
8428 catch
{unset cached_dheads
}
8431 proc rereadrefs
{} {
8432 global idtags idheads idotherrefs mainheadid
8434 set refids
[concat
[array names idtags
] \
8435 [array names idheads
] [array names idotherrefs
]]
8436 foreach id
$refids {
8437 if {![info exists ref
($id)]} {
8438 set ref
($id) [listrefs
$id]
8441 set oldmainhead
$mainheadid
8444 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
8445 [array names idheads
] [array names idotherrefs
]]]
8446 foreach id
$refids {
8447 set v
[listrefs
$id]
8448 if {![info exists ref
($id)] ||
$ref($id) != $v ||
8449 ($id eq
$oldmainhead && $id ne
$mainheadid) ||
8450 ($id eq
$mainheadid && $id ne
$oldmainhead)} {
8457 proc listrefs
{id
} {
8458 global idtags idheads idotherrefs
8461 if {[info exists idtags
($id)]} {
8465 if {[info exists idheads
($id)]} {
8469 if {[info exists idotherrefs
($id)]} {
8470 set z
$idotherrefs($id)
8472 return [list
$x $y $z]
8475 proc showtag
{tag isnew
} {
8476 global ctext tagcontents tagids linknum tagobjid
8479 addtohistory
[list showtag
$tag 0]
8481 $ctext conf
-state normal
8485 if {![info exists tagcontents
($tag)]} {
8487 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
8490 if {[info exists tagcontents
($tag)]} {
8491 set text
$tagcontents($tag)
8493 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
8495 appendwithlinks
$text {}
8496 $ctext conf
-state disabled
8507 proc mkfontdisp
{font top
which} {
8508 global fontattr fontpref
$font
8510 set fontpref
($font) [set $font]
8511 button
$top.
${font}but
-text $which -font optionfont \
8512 -command [list choosefont
$font $which]
8513 label
$top.
$font -relief flat
-font $font \
8514 -text $fontattr($font,family
) -justify left
8515 grid x
$top.
${font}but
$top.
$font -sticky w
8518 proc choosefont
{font
which} {
8519 global fontparam fontlist fonttop fontattr
8521 set fontparam
(which) $which
8522 set fontparam
(font
) $font
8523 set fontparam
(family
) [font actual
$font -family]
8524 set fontparam
(size
) $fontattr($font,size
)
8525 set fontparam
(weight
) $fontattr($font,weight
)
8526 set fontparam
(slant
) $fontattr($font,slant
)
8529 if {![winfo exists
$top]} {
8531 eval font config sample
[font actual
$font]
8533 wm title
$top [mc
"Gitk font chooser"]
8534 label
$top.l
-textvariable fontparam
(which)
8535 pack
$top.l
-side top
8536 set fontlist
[lsort
[font families
]]
8538 listbox
$top.f.fam
-listvariable fontlist \
8539 -yscrollcommand [list
$top.f.sb
set]
8540 bind $top.f.fam
<<ListboxSelect>> selfontfam
8541 scrollbar $top.f.sb -command [list $top.f.fam yview]
8542 pack $top.f.sb -side right -fill y
8543 pack $top.f.fam -side left -fill both -expand 1
8544 pack $top.f -side top -fill both -expand 1
8546 spinbox $top.g.size -from 4 -to 40 -width 4 \
8547 -textvariable fontparam(size) \
8548 -validatecommand {string is integer -strict %s}
8549 checkbutton $top.g.bold -padx 5 \
8550 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8551 -variable fontparam(weight) -onvalue bold -offvalue normal
8552 checkbutton $top.g.ital -padx 5 \
8553 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8554 -variable fontparam(slant) -onvalue italic -offvalue roman
8555 pack $top.g.size $top.g.bold $top.g.ital -side left
8556 pack $top.g -side top
8557 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8559 $top.c create text 100 25 -anchor center -text $which -font sample \
8560 -fill black -tags text
8561 bind $top.c <Configure> [list centertext $top.c]
8562 pack $top.c -side top -fill x
8564 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8565 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8566 grid $top.buts.ok $top.buts.can
8567 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8568 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8569 pack $top.buts -side bottom -fill x
8570 trace add variable fontparam write chg_fontparam
8573 $top.c itemconf text -text $which
8575 set i [lsearch -exact $fontlist $fontparam(family)]
8577 $top.f.fam selection set $i
8582 proc centertext {w} {
8583 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8587 global fontparam fontpref prefstop
8589 set f $fontparam(font)
8590 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8591 if {$fontparam(weight) eq "bold"} {
8592 lappend fontpref($f) "bold"
8594 if {$fontparam(slant) eq "italic"} {
8595 lappend fontpref($f) "italic"
8598 $w conf -text $fontparam(family) -font $fontpref($f)
8604 global fonttop fontparam
8606 if {[info exists fonttop]} {
8607 catch {destroy $fonttop}
8608 catch {font delete sample}
8614 proc selfontfam {} {
8615 global fonttop fontparam
8617 set i [$fonttop.f.fam curselection]
8619 set fontparam(family) [$fonttop.f.fam get $i]
8623 proc chg_fontparam {v sub op} {
8626 font config sample -$sub $fontparam($sub)
8630 global maxwidth maxgraphpct
8631 global oldprefs prefstop showneartags showlocalchanges
8632 global bgcolor fgcolor ctext diffcolors selectbgcolor
8633 global tabstop limitdiffs
8637 if {[winfo exists $top]} {
8641 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8642 limitdiffs tabstop} {
8643 set oldprefs($v) [set $v]
8646 wm title $top [mc "Gitk preferences"]
8647 label $top.ldisp -text [mc "Commit list display options"]
8648 grid $top.ldisp - -sticky w -pady 10
8649 label $top.spacer -text " "
8650 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8652 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8653 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8654 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8656 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8657 grid x $top.maxpctl $top.maxpct -sticky w
8658 frame $top.showlocal
8659 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8660 checkbutton $top.showlocal.b -variable showlocalchanges
8661 pack $top.showlocal.b $top.showlocal.l -side left
8662 grid x $top.showlocal -sticky w
8664 label $top.ddisp -text [mc "Diff display options"]
8665 grid $top.ddisp - -sticky w -pady 10
8666 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8667 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8668 grid x $top.tabstopl $top.tabstop -sticky w
8670 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8671 checkbutton $top.ntag.b -variable showneartags
8672 pack $top.ntag.b $top.ntag.l -side left
8673 grid x $top.ntag -sticky w
8675 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8676 checkbutton $top.ldiff.b -variable limitdiffs
8677 pack $top.ldiff.b $top.ldiff.l -side left
8678 grid x $top.ldiff -sticky w
8680 label $top.cdisp -text [mc "Colors: press to choose"]
8681 grid $top.cdisp - -sticky w -pady 10
8682 label $top.bg -padx 40 -relief sunk -background $bgcolor
8683 button $top.bgbut -text [mc "Background"] -font optionfont \
8684 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8685 grid x $top.bgbut $top.bg -sticky w
8686 label $top.fg -padx 40 -relief sunk -background $fgcolor
8687 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8688 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8689 grid x $top.fgbut $top.fg -sticky w
8690 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8691 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8692 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8693 [list $ctext tag conf d0 -foreground]]
8694 grid x $top.diffoldbut $top.diffold -sticky w
8695 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8696 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8697 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8698 [list $ctext tag conf d1 -foreground]]
8699 grid x $top.diffnewbut $top.diffnew -sticky w
8700 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8701 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8702 -command [list choosecolor diffcolors 2 $top.hunksep \
8703 "diff hunk header" \
8704 [list $ctext tag conf hunksep -foreground]]
8705 grid x $top.hunksepbut $top.hunksep -sticky w
8706 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8707 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8708 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8709 grid x $top.selbgbut $top.selbgsep -sticky w
8711 label $top.cfont -text [mc "Fonts: press to choose"]
8712 grid $top.cfont - -sticky w -pady 10
8713 mkfontdisp mainfont $top [mc "Main font"]
8714 mkfontdisp textfont $top [mc "Diff display font"]
8715 mkfontdisp uifont $top [mc "User interface font"]
8718 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8719 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8720 grid $top.buts.ok $top.buts.can
8721 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8722 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8723 grid $top.buts - - -pady 10 -sticky ew
8724 bind $top <Visibility> "focus $top.buts.ok"
8727 proc choosecolor {v vi w x cmd} {
8730 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8731 -title [mc "Gitk: choose color for %s" $x]]
8732 if {$c eq {}} return
8733 $w conf -background $c
8739 global bglist cflist
8741 $w configure -selectbackground $c
8743 $cflist tag configure highlight \
8744 -background [$cflist cget -selectbackground]
8745 allcanvs itemconf secsel -fill $c
8752 $w conf -background $c
8760 $w conf -foreground $c
8762 allcanvs itemconf text -fill $c
8763 $canv itemconf circle -outline $c
8767 global oldprefs prefstop
8769 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8770 limitdiffs tabstop} {
8772 set $v $oldprefs($v)
8774 catch {destroy $prefstop}
8780 global maxwidth maxgraphpct
8781 global oldprefs prefstop showneartags showlocalchanges
8782 global fontpref mainfont textfont uifont
8783 global limitdiffs treediffs
8785 catch {destroy $prefstop}
8789 if {$mainfont ne $fontpref(mainfont)} {
8790 set mainfont $fontpref(mainfont)
8791 parsefont mainfont $mainfont
8792 eval font configure mainfont [fontflags mainfont]
8793 eval font configure mainfontbold [fontflags mainfont 1]
8797 if {$textfont ne $fontpref(textfont)} {
8798 set textfont $fontpref(textfont)
8799 parsefont textfont $textfont
8800 eval font configure textfont [fontflags textfont]
8801 eval font configure textfontbold [fontflags textfont 1]
8803 if {$uifont ne $fontpref(uifont)} {
8804 set uifont $fontpref(uifont)
8805 parsefont uifont $uifont
8806 eval font configure uifont [fontflags uifont]
8809 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8810 if {$showlocalchanges} {
8816 if {$limitdiffs != $oldprefs(limitdiffs)} {
8817 # treediffs elements are limited by path
8818 catch {unset treediffs}
8820 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8821 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8823 } elseif {$showneartags != $oldprefs(showneartags) ||
8824 $limitdiffs != $oldprefs(limitdiffs)} {
8829 proc formatdate {d} {
8830 global datetimeformat
8832 set d [clock format $d -format $datetimeformat]
8837 # This list of encoding names and aliases is distilled from
8838 # http://www.iana.org/assignments/character-sets.
8839 # Not all of them are supported by Tcl.
8840 set encoding_aliases {
8841 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8842 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8843 { ISO-10646-UTF-1 csISO10646UTF1 }
8844 { ISO_646.basic:1983 ref csISO646basic1983 }
8845 { INVARIANT csINVARIANT }
8846 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8847 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8848 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8849 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8850 { NATS-DANO iso-ir-9-1 csNATSDANO }
8851 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8852 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8853 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8854 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8855 { ISO-2022-KR csISO2022KR }
8857 { ISO-2022-JP csISO2022JP }
8858 { ISO-2022-JP-2 csISO2022JP2 }
8859 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8861 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8862 { IT iso-ir-15 ISO646-IT csISO15Italian }
8863 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8864 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8865 { greek7-old iso-ir-18 csISO18Greek7Old }
8866 { latin-greek iso-ir-19 csISO19LatinGreek }
8867 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8868 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8869 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8870 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8871 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8872 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8873 { INIS iso-ir-49 csISO49INIS }
8874 { INIS-8 iso-ir-50 csISO50INIS8 }
8875 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8876 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8877 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8878 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8879 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8880 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8882 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8883 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8884 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8885 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8886 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8887 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8888 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8889 { greek7 iso-ir-88 csISO88Greek7 }
8890 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8891 { iso-ir-90 csISO90 }
8892 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8893 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8894 csISO92JISC62991984b }
8895 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8896 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8897 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8898 csISO95JIS62291984handadd }
8899 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8900 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8901 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8902 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8904 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8905 { T.61-7bit iso-ir-102 csISO102T617bit }
8906 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8907 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8908 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8909 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8910 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8911 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8912 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8913 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8914 arabic csISOLatinArabic }
8915 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8916 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8917 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8918 greek greek8 csISOLatinGreek }
8919 { T.101-G2 iso-ir-128 csISO128T101G2 }
8920 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8922 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8923 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8924 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8925 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8926 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8927 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8928 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8929 csISOLatinCyrillic }
8930 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8931 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8932 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8933 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8934 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8935 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8936 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8937 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8938 { ISO_10367-box iso-ir-155 csISO10367Box }
8939 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8940 { latin-lap lap iso-ir-158 csISO158Lap }
8941 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8942 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8945 { JIS_X0201 X0201 csHalfWidthKatakana }
8946 { KSC5636 ISO646-KR csKSC5636 }
8947 { ISO-10646-UCS-2 csUnicode }
8948 { ISO-10646-UCS-4 csUCS4 }
8949 { DEC-MCS dec csDECMCS }
8950 { hp-roman8 roman8 r8 csHPRoman8 }
8951 { macintosh mac csMacintosh }
8952 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8954 { IBM038 EBCDIC-INT cp038 csIBM038 }
8955 { IBM273 CP273 csIBM273 }
8956 { IBM274 EBCDIC-BE CP274 csIBM274 }
8957 { IBM275 EBCDIC-BR cp275 csIBM275 }
8958 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8959 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8960 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8961 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8962 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8963 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8964 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8965 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8966 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8967 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8968 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8969 { IBM437 cp437 437 csPC8CodePage437 }
8970 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8971 { IBM775 cp775 csPC775Baltic }
8972 { IBM850 cp850 850 csPC850Multilingual }
8973 { IBM851 cp851 851 csIBM851 }
8974 { IBM852 cp852 852 csPCp852 }
8975 { IBM855 cp855 855 csIBM855 }
8976 { IBM857 cp857 857 csIBM857 }
8977 { IBM860 cp860 860 csIBM860 }
8978 { IBM861 cp861 861 cp-is csIBM861 }
8979 { IBM862 cp862 862 csPC862LatinHebrew }
8980 { IBM863 cp863 863 csIBM863 }
8981 { IBM864 cp864 csIBM864 }
8982 { IBM865 cp865 865 csIBM865 }
8983 { IBM866 cp866 866 csIBM866 }
8984 { IBM868 CP868 cp-ar csIBM868 }
8985 { IBM869 cp869 869 cp-gr csIBM869 }
8986 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8987 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8988 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8989 { IBM891 cp891 csIBM891 }
8990 { IBM903 cp903 csIBM903 }
8991 { IBM904 cp904 904 csIBBM904 }
8992 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8993 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8994 { IBM1026 CP1026 csIBM1026 }
8995 { EBCDIC-AT-DE csIBMEBCDICATDE }
8996 { EBCDIC-AT-DE-A csEBCDICATDEA }
8997 { EBCDIC-CA-FR csEBCDICCAFR }
8998 { EBCDIC-DK-NO csEBCDICDKNO }
8999 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9000 { EBCDIC-FI-SE csEBCDICFISE }
9001 { EBCDIC-FI-SE-A csEBCDICFISEA }
9002 { EBCDIC-FR csEBCDICFR }
9003 { EBCDIC-IT csEBCDICIT }
9004 { EBCDIC-PT csEBCDICPT }
9005 { EBCDIC-ES csEBCDICES }
9006 { EBCDIC-ES-A csEBCDICESA }
9007 { EBCDIC-ES-S csEBCDICESS }
9008 { EBCDIC-UK csEBCDICUK }
9009 { EBCDIC-US csEBCDICUS }
9010 { UNKNOWN-8BIT csUnknown8BiT }
9011 { MNEMONIC csMnemonic }
9016 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9017 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9018 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9019 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9020 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9021 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9022 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9023 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9024 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9025 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9026 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9027 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9028 { IBM1047 IBM-1047 }
9029 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9030 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9031 { UNICODE-1-1 csUnicode11 }
9034 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9035 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9037 { ISO-8859-15 ISO_8859-15 Latin-9 }
9038 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9039 { GBK CP936 MS936 windows-936 }
9040 { JIS_Encoding csJISEncoding }
9041 { Shift_JIS MS_Kanji csShiftJIS }
9042 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9044 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9045 { ISO-10646-UCS-Basic csUnicodeASCII }
9046 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9047 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9048 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9049 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9050 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9051 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9052 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9053 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9054 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9055 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9056 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9057 { Ventura-US csVenturaUS }
9058 { Ventura-International csVenturaInternational }
9059 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9060 { PC8-Turkish csPC8Turkish }
9061 { IBM-Symbols csIBMSymbols }
9062 { IBM-Thai csIBMThai }
9063 { HP-Legal csHPLegal }
9064 { HP-Pi-font csHPPiFont }
9065 { HP-Math8 csHPMath8 }
9066 { Adobe-Symbol-Encoding csHPPSMath }
9067 { HP-DeskTop csHPDesktop }
9068 { Ventura-Math csVenturaMath }
9069 { Microsoft-Publishing csMicrosoftPublishing }
9070 { Windows-31J csWindows31J }
9075 proc tcl_encoding {enc} {
9076 global encoding_aliases
9077 set names [encoding names]
9078 set lcnames [string tolower $names]
9079 set enc [string tolower $enc]
9080 set i [lsearch -exact $lcnames $enc]
9082 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9083 if {[regsub {^iso[-_]} $enc iso encx]} {
9084 set i [lsearch -exact $lcnames $encx]
9088 foreach l $encoding_aliases {
9089 set ll [string tolower $l]
9090 if {[lsearch -exact $ll $enc] < 0} continue
9091 # look through the aliases for one that tcl knows about
9093 set i [lsearch -exact $lcnames $e]
9095 if {[regsub {^iso[-_]} $e iso ex]} {
9096 set i [lsearch -exact $lcnames $ex]
9105 return [lindex $names $i]
9110 # First check that Tcl/Tk is recent enough
9111 if {[catch {package require Tk 8.4} err]} {
9112 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9113 Gitk requires at least Tcl/Tk 8.4."]
9119 set wrcomcmd "git diff-tree --stdin -p --pretty"
9123 set gitencoding [exec git config --get i18n.commitencoding]
9125 if {$gitencoding == ""} {
9126 set gitencoding "utf-8"
9128 set tclencoding [tcl_encoding $gitencoding]
9129 if {$tclencoding == {}} {
9130 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9133 set mainfont {Helvetica 9}
9134 set textfont {Courier 9}
9135 set uifont {Helvetica 9 bold}
9137 set findmergefiles 0
9145 set cmitmode "patch"
9146 set wrapcomment "none"
9150 set showlocalchanges 1
9152 set datetimeformat "%Y-%m-%d %H:%M:%S"
9154 set colors {green red blue magenta darkgrey brown orange}
9157 set diffcolors {red "#00a000" blue}
9159 set selectbgcolor gray85
9161 ## For msgcat loading, first locate the installation location.
9162 if { [info exists ::env(GITK_MSGSDIR)] } {
9163 ## Msgsdir was manually set in the environment.
9164 set gitk_msgsdir $::env(GITK_MSGSDIR)
9166 ## Let's guess the prefix from argv0.
9167 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9168 set gitk_libdir [file join $gitk_prefix share gitk lib]
9169 set gitk_msgsdir [file join $gitk_libdir msgs]
9173 ## Internationalization (i18n) through msgcat and gettext. See
9174 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9175 package require msgcat
9176 namespace import ::msgcat::mc
9177 ## And eventually load the actual message catalog
9178 ::msgcat::mcload $gitk_msgsdir
9180 catch {source ~/.gitk}
9182 font create optionfont -family sans-serif -size -12
9184 parsefont mainfont $mainfont
9185 eval font create mainfont [fontflags mainfont]
9186 eval font create mainfontbold [fontflags mainfont 1]
9188 parsefont textfont $textfont
9189 eval font create textfont [fontflags textfont]
9190 eval font create textfontbold [fontflags textfont 1]
9192 parsefont uifont $uifont
9193 eval font create uifont [fontflags uifont]
9197 # check that we can find a .git directory somewhere...
9198 if {[catch {set gitdir [gitdir]}]} {
9199 show_error {} . [mc "Cannot find a git repository here."]
9202 if {![file isdirectory $gitdir]} {
9203 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9209 set cmdline_files {}
9214 "-d" { set datemode 1 }
9217 lappend revtreeargs $arg
9220 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9224 lappend revtreeargs $arg
9230 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9231 # no -- on command line, but some arguments (other than -d)
9233 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9234 set cmdline_files [split $f "\n"]
9235 set n [llength $cmdline_files]
9236 set revtreeargs [lrange $revtreeargs 0 end-$n]
9237 # Unfortunately git rev-parse doesn't produce an error when
9238 # something is both a revision and a filename. To be consistent
9239 # with git log and git rev-list, check revtreeargs for filenames.
9240 foreach arg $revtreeargs {
9241 if {[file exists $arg]} {
9242 show_error {} . [mc "Ambiguous argument '%s': both revision\
9248 # unfortunately we get both stdout and stderr in $err,
9249 # so look for "fatal:".
9250 set i [string first "fatal:" $err]
9252 set err [string range $err [expr {$i + 6}] end]
9254 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9260 # find the list of unmerged files
9264 set fd [open "| git ls-files -u" r]
9266 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9269 while {[gets $fd line] >= 0} {
9270 set i [string first "\t" $line]
9271 if {$i < 0} continue
9272 set fname [string range $line [expr {$i+1}] end]
9273 if {[lsearch -exact $mlist $fname] >= 0} continue
9275 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9276 lappend mlist $fname
9281 if {$nr_unmerged == 0} {
9282 show_error {} . [mc "No files selected: --merge specified but\
9283 no files are unmerged."]
9285 show_error {} . [mc "No files selected: --merge specified but\
9286 no unmerged files are within file limit."]
9290 set cmdline_files $mlist
9293 set nullid "0000000000000000000000000000000000000000"
9294 set nullid2 "0000000000000000000000000000000000000001"
9296 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9303 set highlight_paths {}
9305 set searchdirn -forwards
9309 set markingmatches 0
9310 set linkentercount 0
9311 set need_redisplay 0
9318 set selectedhlview [mc "None"]
9319 set highlight_related [mc "None"]
9320 set highlight_files {}
9333 # wait for the window to become visible
9335 wm title . "[file tail $argv0]: [file tail [pwd]]"
9338 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9339 # create a view for the files/dirs specified on the command line
9343 set viewname(1) [mc "Command line"]
9344 set viewfiles(1) $cmdline_files
9345 set viewargs(1) $revtreeargs
9348 .bar.view entryconf [mc "Edit view..."] -state normal
9349 .bar.view entryconf [mc "Delete view"] -state normal
9352 if {[info exists permviews]} {
9353 foreach v $permviews {
9356 set viewname($n) [lindex $v 0]
9357 set viewfiles($n) [lindex $v 1]
9358 set viewargs($n) [lindex $v 2]