2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
12 if {[info exists env
(GIT_DIR
)]} {
15 return [exec git rev-parse
--git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
28 if {[info exists isonrunq
($script)]} return
32 lappend runq
[list
{} $script]
33 set isonrunq
($script) 1
36 proc filerun
{fd
script} {
37 fileevent
$fd readable
[list filereadable
$fd $script]
40 proc filereadable
{fd
script} {
43 fileevent
$fd readable
{}
47 lappend runq
[list
$fd $script]
53 for {set i
0} {$i < [llength
$runq]} {} {
54 if {[lindex
$runq $i 0] eq
$fd} {
55 set runq
[lreplace
$runq $i $i]
65 set tstart
[clock clicks
-milliseconds]
67 while {[llength
$runq] > 0} {
68 set fd
[lindex
$runq 0 0]
69 set script [lindex
$runq 0 1]
70 set repeat
[eval $script]
71 set t1
[clock clicks
-milliseconds]
72 set t
[expr {$t1 - $t0}]
73 set runq
[lrange
$runq 1 end
]
74 if {$repeat ne
{} && $repeat} {
75 if {$fd eq
{} ||
$repeat == 2} {
76 # script returns 1 if it wants to be readded
77 # file readers return 2 if they could do more straight away
78 lappend runq
[list
$fd $script]
80 fileevent
$fd readable
[list filereadable
$fd $script]
82 } elseif
{$fd eq
{}} {
83 unset isonrunq
($script)
86 if {$t1 - $tstart >= 80} break
93 # Start off a git rev-list process and arrange to read its output
94 proc start_rev_list
{view
} {
96 global commfd leftover tclencoding datemode
97 global viewargs viewfiles commitidx viewcomplete vnextroot
98 global showlocalchanges commitinterest mainheadid
99 global progressdirn progresscoords proglastnc curview
100 global viewincl viewactive loginstance viewinstances
101 global pending_select mainheadid
103 set startmsecs
[clock clicks
-milliseconds]
104 set commitidx
($view) 0
105 set viewcomplete
($view) 0
106 set viewactive
($view) 1
107 set vnextroot
($view) 0
110 set commits
[eval exec git rev-parse
--default HEAD
--revs-only \
112 set viewincl
($view) {}
114 if {[regexp
{^
[0-9a-fA-F]{40}$
} $c]} {
115 lappend viewincl
($view) $c
119 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
120 --boundary $commits "--" $viewfiles($view)] r
]
122 error_popup
"[mc "Error executing git log
:"] $err"
125 set i
[incr loginstance
]
126 set viewinstances
($view) [list
$i]
129 if {$showlocalchanges} {
130 lappend commitinterest
($mainheadid) {dodiffindex
}
132 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
133 if {$tclencoding != {}} {
134 fconfigure
$fd -encoding $tclencoding
136 filerun
$fd [list getcommitlines
$fd $i $view]
137 nowbusy
$view [mc
"Reading"]
138 if {$view == $curview} {
140 set progresscoords
{0 0}
142 set pending_select
$mainheadid
146 proc stop_rev_list
{view
} {
147 global commfd viewinstances leftover
149 foreach inst
$viewinstances($view) {
150 set fd
$commfd($inst)
158 unset leftover
($inst)
160 set viewinstances
($view) {}
167 start_rev_list
$curview
168 show_status
[mc
"Reading commits..."]
171 proc updatecommits
{} {
172 global curview viewargs viewfiles viewincl viewinstances
173 global viewactive viewcomplete loginstance tclencoding mainheadid
174 global varcid startmsecs commfd showneartags showlocalchanges leftover
175 global mainheadid pending_select
177 set oldmainid
$mainheadid
179 if {$showlocalchanges} {
180 if {$mainheadid ne
$oldmainid} {
183 if {[commitinview
$mainheadid $curview]} {
188 set commits
[exec git rev-parse
--default HEAD
--revs-only \
194 if {[string match
"^*" $c]} {
196 } elseif
{[regexp
{^
[0-9a-fA-F]{40}$
} $c]} {
197 if {!([info exists varcid
($view,$c)] ||
198 [lsearch
-exact $viewincl($view) $c] >= 0)} {
208 foreach id
$viewincl($view) {
211 set viewincl
($view) [concat
$viewincl($view) $pos]
213 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
214 --boundary $pos $neg $flags "--" $viewfiles($view)] r
]
216 error_popup
"Error executing git log: $err"
219 if {$viewactive($view) == 0} {
220 set startmsecs
[clock clicks
-milliseconds]
222 set i
[incr loginstance
]
223 lappend viewinstances
($view) $i
226 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
227 if {$tclencoding != {}} {
228 fconfigure
$fd -encoding $tclencoding
230 filerun
$fd [list getcommitlines
$fd $i $view]
231 incr viewactive
($view)
232 set viewcomplete
($view) 0
233 set pending_select
$mainheadid
234 nowbusy
$view "Reading"
240 proc reloadcommits
{} {
241 global curview viewcomplete selectedline currentid thickerline
242 global showneartags treediffs commitinterest cached_commitrow
243 global progresscoords targetid
245 if {!$viewcomplete($curview)} {
246 stop_rev_list
$curview
247 set progresscoords
{0 0}
251 catch
{unset selectedline
}
252 catch
{unset currentid
}
253 catch
{unset thickerline
}
254 catch
{unset treediffs
}
261 catch
{unset commitinterest
}
262 catch
{unset cached_commitrow
}
263 catch
{unset targetid
}
269 # This makes a string representation of a positive integer which
270 # sorts as a string in numerical order
273 return [format
"%x" $n]
274 } elseif
{$n < 256} {
275 return [format
"x%.2x" $n]
276 } elseif
{$n < 65536} {
277 return [format
"y%.4x" $n]
279 return [format
"z%.8x" $n]
282 # Procedures used in reordering commits from git log (without
283 # --topo-order) into the order for display.
285 proc varcinit
{view
} {
286 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
287 global vtokmod varcmod vrowmod varcix vlastins
289 set varcstart
($view) {{}}
290 set vupptr
($view) {0}
291 set vdownptr
($view) {0}
292 set vleftptr
($view) {0}
293 set vbackptr
($view) {0}
294 set varctok
($view) {{}}
295 set varcrow
($view) {{}}
296 set vtokmod
($view) {}
299 set varcix
($view) {{}}
300 set vlastins
($view) {0}
303 proc resetvarcs
{view
} {
304 global varcid varccommits parents children vseedcount ordertok
306 foreach vid
[array names varcid
$view,*] {
311 # some commits might have children but haven't been seen yet
312 foreach vid
[array names children
$view,*] {
315 foreach va
[array names varccommits
$view,*] {
316 unset varccommits
($va)
318 foreach vd
[array names vseedcount
$view,*] {
319 unset vseedcount
($vd)
321 catch
{unset ordertok
}
324 proc newvarc
{view id
} {
325 global varcid varctok parents children datemode
326 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
327 global commitdata commitinfo vseedcount varccommits vlastins
329 set a
[llength
$varctok($view)]
331 if {[llength
$children($vid)] == 0 ||
$datemode} {
332 if {![info exists commitinfo
($id)]} {
333 parsecommit
$id $commitdata($id) 1
335 set cdate
[lindex
$commitinfo($id) 4]
336 if {![string is integer
-strict $cdate]} {
339 if {![info exists vseedcount
($view,$cdate)]} {
340 set vseedcount
($view,$cdate) -1
342 set c
[incr vseedcount
($view,$cdate)]
343 set cdate
[expr {$cdate ^
0xffffffff}]
344 set tok
"s[strrep $cdate][strrep $c]"
349 if {[llength
$children($vid)] > 0} {
350 set kid
[lindex
$children($vid) end
]
351 set k
$varcid($view,$kid)
352 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
355 set tok
[lindex
$varctok($view) $k]
359 set i
[lsearch
-exact $parents($view,$ki) $id]
360 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
361 append tok
[strrep
$j]
363 set c
[lindex
$vlastins($view) $ka]
364 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
366 set b
[lindex
$vdownptr($view) $ka]
368 set b
[lindex
$vleftptr($view) $c]
370 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
372 set b
[lindex
$vleftptr($view) $c]
375 lset vdownptr
($view) $ka $a
376 lappend vbackptr
($view) 0
378 lset vleftptr
($view) $c $a
379 lappend vbackptr
($view) $c
381 lset vlastins
($view) $ka $a
382 lappend vupptr
($view) $ka
383 lappend vleftptr
($view) $b
385 lset vbackptr
($view) $b $a
387 lappend varctok
($view) $tok
388 lappend varcstart
($view) $id
389 lappend vdownptr
($view) 0
390 lappend varcrow
($view) {}
391 lappend varcix
($view) {}
392 set varccommits
($view,$a) {}
393 lappend vlastins
($view) 0
397 proc splitvarc
{p v
} {
398 global varcid varcstart varccommits varctok
399 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
401 set oa
$varcid($v,$p)
402 set ac
$varccommits($v,$oa)
403 set i
[lsearch
-exact $varccommits($v,$oa) $p]
405 set na
[llength
$varctok($v)]
406 # "%" sorts before "0"...
407 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
408 lappend varctok
($v) $tok
409 lappend varcrow
($v) {}
410 lappend varcix
($v) {}
411 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
412 set varccommits
($v,$na) [lrange
$ac $i end
]
413 lappend varcstart
($v) $p
414 foreach id
$varccommits($v,$na) {
415 set varcid
($v,$id) $na
417 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
418 lset vdownptr
($v) $oa $na
419 lappend vupptr
($v) $oa
420 lappend vleftptr
($v) 0
421 lappend vbackptr
($v) 0
422 lappend vlastins
($v) 0
423 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
424 lset vupptr
($v) $b $na
428 proc renumbervarc
{a v
} {
429 global parents children varctok varcstart varccommits
430 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
432 set t1
[clock clicks
-milliseconds]
438 if {[info exists isrelated
($a)]} {
440 set id
[lindex
$varccommits($v,$a) end
]
441 foreach p
$parents($v,$id) {
442 if {[info exists varcid
($v,$p)]} {
443 set isrelated
($varcid($v,$p)) 1
448 set b
[lindex
$vdownptr($v) $a]
451 set b
[lindex
$vleftptr($v) $a]
453 set a
[lindex
$vupptr($v) $a]
459 if {![info exists kidchanged
($a)]} continue
460 set id
[lindex
$varcstart($v) $a]
461 if {[llength
$children($v,$id)] > 1} {
462 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
465 set oldtok
[lindex
$varctok($v) $a]
472 set kid
[last_real_child
$v,$id]
474 set k
$varcid($v,$kid)
475 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
478 set tok
[lindex
$varctok($v) $k]
482 set i
[lsearch
-exact $parents($v,$ki) $id]
483 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
484 append tok
[strrep
$j]
486 if {$tok eq
$oldtok} {
489 set id
[lindex
$varccommits($v,$a) end
]
490 foreach p
$parents($v,$id) {
491 if {[info exists varcid
($v,$p)]} {
492 set kidchanged
($varcid($v,$p)) 1
497 lset varctok
($v) $a $tok
498 set b
[lindex
$vupptr($v) $a]
500 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
503 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
506 set c
[lindex
$vbackptr($v) $a]
507 set d
[lindex
$vleftptr($v) $a]
509 lset vdownptr
($v) $b $d
511 lset vleftptr
($v) $c $d
514 lset vbackptr
($v) $d $c
516 lset vupptr
($v) $a $ka
517 set c
[lindex
$vlastins($v) $ka]
519 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
521 set b
[lindex
$vdownptr($v) $ka]
523 set b
[lindex
$vleftptr($v) $c]
526 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
528 set b
[lindex
$vleftptr($v) $c]
531 lset vdownptr
($v) $ka $a
532 lset vbackptr
($v) $a 0
534 lset vleftptr
($v) $c $a
535 lset vbackptr
($v) $a $c
537 lset vleftptr
($v) $a $b
539 lset vbackptr
($v) $b $a
541 lset vlastins
($v) $ka $a
544 foreach id
[array names sortkids
] {
545 if {[llength
$children($v,$id)] > 1} {
546 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
550 set t2
[clock clicks
-milliseconds]
551 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
554 proc fix_reversal
{p a v
} {
555 global varcid varcstart varctok vupptr
557 set pa
$varcid($v,$p)
558 if {$p ne
[lindex
$varcstart($v) $pa]} {
560 set pa
$varcid($v,$p)
562 # seeds always need to be renumbered
563 if {[lindex
$vupptr($v) $pa] == 0 ||
564 [string compare
[lindex
$varctok($v) $a] \
565 [lindex
$varctok($v) $pa]] > 0} {
570 proc insertrow
{id p v
} {
571 global varcid varccommits parents children cmitlisted
572 global commitidx varctok vtokmod targetid targetrow
575 set i
[lsearch
-exact $varccommits($v,$a) $p]
577 puts
"oops: insertrow can't find [shortids $p] on arc $a"
580 set children
($v,$id) {}
581 set parents
($v,$id) [list
$p]
582 set varcid
($v,$id) $a
583 lappend children
($v,$p) $id
584 set cmitlisted
($v,$id) 1
586 # note we deliberately don't update varcstart($v) even if $i == 0
587 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
588 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
591 if {[info exists targetid
]} {
592 if {![comes_before
$targetid $p]} {
599 proc removerow
{id v
} {
600 global varcid varccommits parents children commitidx
601 global varctok vtokmod cmitlisted currentid selectedline
604 if {[llength
$parents($v,$id)] != 1} {
605 puts
"oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
608 set p
[lindex
$parents($v,$id) 0]
609 set a
$varcid($v,$id)
610 set i
[lsearch
-exact $varccommits($v,$a) $id]
612 puts
"oops: removerow can't find [shortids $id] on arc $a"
616 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
617 unset parents
($v,$id)
618 unset children
($v,$id)
619 unset cmitlisted
($v,$id)
620 incr commitidx
($v) -1
621 set j
[lsearch
-exact $children($v,$p) $id]
623 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
625 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
628 if {[info exist currentid
] && $id eq
$currentid} {
632 if {[info exists targetid
] && $targetid eq
$id} {
638 proc first_real_child
{vp
} {
639 global children nullid nullid2
641 foreach id
$children($vp) {
642 if {$id ne
$nullid && $id ne
$nullid2} {
649 proc last_real_child
{vp
} {
650 global children nullid nullid2
652 set kids
$children($vp)
653 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
654 set id
[lindex
$kids $i]
655 if {$id ne
$nullid && $id ne
$nullid2} {
662 proc vtokcmp
{v a b
} {
663 global varctok varcid
665 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
666 [lindex
$varctok($v) $varcid($v,$b)]]
669 proc modify_arc
{v a
{lim
{}}} {
670 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
672 set vtokmod
($v) [lindex
$varctok($v) $a]
674 if {$v == $curview} {
675 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
676 set a
[lindex
$vupptr($v) $a]
682 set lim
[llength
$varccommits($v,$a)]
684 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
691 proc update_arcrows
{v
} {
692 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
693 global varcid vrownum varcorder varcix varccommits
694 global vupptr vdownptr vleftptr varctok
695 global displayorder parentlist curview cached_commitrow
697 set narctot
[expr {[llength
$varctok($v)] - 1}]
699 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
700 # go up the tree until we find something that has a row number,
701 # or we get to a seed
702 set a
[lindex
$vupptr($v) $a]
705 set a
[lindex
$vdownptr($v) 0]
708 set varcorder
($v) [list
$a]
710 lset varcrow
($v) $a 0
714 set arcn
[lindex
$varcix($v) $a]
715 # see if a is the last arc; if so, nothing to do
716 if {$arcn == $narctot - 1} {
719 if {[llength
$vrownum($v)] > $arcn + 1} {
720 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
721 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
723 set row
[lindex
$varcrow($v) $a]
725 if {$v == $curview} {
726 if {[llength
$displayorder] > $vrowmod($v)} {
727 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
728 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
730 catch
{unset cached_commitrow
}
734 incr row
[llength
$varccommits($v,$a)]
735 # go down if possible
736 set b
[lindex
$vdownptr($v) $a]
738 # if not, go left, or go up until we can go left
740 set b
[lindex
$vleftptr($v) $a]
742 set a
[lindex
$vupptr($v) $a]
748 lappend vrownum
($v) $row
749 lappend varcorder
($v) $a
750 lset varcix
($v) $a $arcn
751 lset varcrow
($v) $a $row
753 set vtokmod
($v) [lindex
$varctok($v) $p]
756 if {[info exists currentid
]} {
757 set selectedline
[rowofcommit
$currentid]
761 # Test whether view $v contains commit $id
762 proc commitinview
{id v
} {
765 return [info exists varcid
($v,$id)]
768 # Return the row number for commit $id in the current view
769 proc rowofcommit
{id
} {
770 global varcid varccommits varcrow curview cached_commitrow
771 global varctok vtokmod
774 if {![info exists varcid
($v,$id)]} {
775 puts
"oops rowofcommit no arc for [shortids $id]"
778 set a
$varcid($v,$id)
779 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
782 if {[info exists cached_commitrow
($id)]} {
783 return $cached_commitrow($id)
785 set i
[lsearch
-exact $varccommits($v,$a) $id]
787 puts
"oops didn't find commit [shortids $id] in arc $a"
790 incr i
[lindex
$varcrow($v) $a]
791 set cached_commitrow
($id) $i
795 # Returns 1 if a is on an earlier row than b, otherwise 0
796 proc comes_before
{a b
} {
797 global varcid varctok curview
800 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
801 ![info exists varcid
($v,$b)]} {
804 if {$varcid($v,$a) != $varcid($v,$b)} {
805 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
806 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
808 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
811 proc bsearch
{l elt
} {
812 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
817 while {$hi - $lo > 1} {
818 set mid
[expr {int
(($lo + $hi) / 2)}]
819 set t
[lindex
$l $mid]
822 } elseif
{$elt > $t} {
831 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
832 proc make_disporder
{start end
} {
833 global vrownum curview commitidx displayorder parentlist
834 global varccommits varcorder parents vrowmod varcrow
835 global d_valid_start d_valid_end
837 if {$end > $vrowmod($curview)} {
838 update_arcrows
$curview
840 set ai
[bsearch
$vrownum($curview) $start]
841 set start
[lindex
$vrownum($curview) $ai]
842 set narc
[llength
$vrownum($curview)]
843 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
844 set a
[lindex
$varcorder($curview) $ai]
845 set l
[llength
$displayorder]
846 set al
[llength
$varccommits($curview,$a)]
849 set pad
[ntimes
[expr {$r - $l}] {}]
850 set displayorder
[concat
$displayorder $pad]
851 set parentlist
[concat
$parentlist $pad]
853 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
854 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
856 foreach id
$varccommits($curview,$a) {
857 lappend displayorder
$id
858 lappend parentlist
$parents($curview,$id)
860 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
862 foreach id
$varccommits($curview,$a) {
863 lset displayorder
$i $id
864 lset parentlist
$i $parents($curview,$id)
872 proc commitonrow
{row
} {
875 set id
[lindex
$displayorder $row]
877 make_disporder
$row [expr {$row + 1}]
878 set id
[lindex
$displayorder $row]
883 proc closevarcs
{v
} {
884 global varctok varccommits varcid parents children
885 global cmitlisted commitidx commitinterest vtokmod
887 set missing_parents
0
889 set narcs
[llength
$varctok($v)]
890 for {set a
1} {$a < $narcs} {incr a
} {
891 set id
[lindex
$varccommits($v,$a) end
]
892 foreach p
$parents($v,$id) {
893 if {[info exists varcid
($v,$p)]} continue
894 # add p as a new commit
896 set cmitlisted
($v,$p) 0
897 set parents
($v,$p) {}
898 if {[llength
$children($v,$p)] == 1 &&
899 [llength
$parents($v,$id)] == 1} {
902 set b
[newvarc
$v $p]
905 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
908 lappend varccommits
($v,$b) $p
910 if {[info exists commitinterest
($p)]} {
911 foreach
script $commitinterest($p) {
912 lappend scripts
[string map
[list
"%I" $p] $script]
914 unset commitinterest
($id)
918 if {$missing_parents > 0} {
925 proc getcommitlines
{fd inst view
} {
926 global cmitlisted commitinterest leftover
927 global commitidx commitdata datemode
928 global parents children curview hlview
929 global vnextroot idpending ordertok
930 global varccommits varcid varctok vtokmod
932 set stuff
[read $fd 500000]
933 # git log doesn't terminate the last commit with a null...
934 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
941 global commfd viewcomplete viewactive viewname progresscoords
944 set i
[lsearch
-exact $viewinstances($view) $inst]
946 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
948 # set it blocking so we wait for the process to terminate
949 fconfigure
$fd -blocking 1
950 if {[catch
{close
$fd} err
]} {
952 if {$view != $curview} {
953 set fv
" for the \"$viewname($view)\" view"
955 if {[string range
$err 0 4] == "usage"} {
956 set err
"Gitk: error reading commits$fv:\
957 bad arguments to git rev-list."
958 if {$viewname($view) eq
"Command line"} {
960 " (Note: arguments to gitk are passed to git rev-list\
961 to allow selection of commits to be displayed.)"
964 set err
"Error reading commits$fv: $err"
968 if {[incr viewactive
($view) -1] <= 0} {
969 set viewcomplete
($view) 1
970 # Check if we have seen any ids listed as parents that haven't
971 # appeared in the list
974 set progresscoords
{0 0}
977 if {$view == $curview} {
978 run chewcommits
$view
986 set i
[string first
"\0" $stuff $start]
988 append leftover
($inst) [string range
$stuff $start end
]
992 set cmit
$leftover($inst)
993 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
994 set leftover
($inst) {}
996 set cmit
[string range
$stuff $start [expr {$i - 1}]]
998 set start
[expr {$i + 1}]
999 set j
[string first
"\n" $cmit]
1002 if {$j >= 0 && [string match
"commit *" $cmit]} {
1003 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1004 if {[string match
{[-<>]*} $ids]} {
1005 switch
-- [string index
$ids 0] {
1010 set ids
[string range
$ids 1 end
]
1014 if {[string length
$id] != 40} {
1022 if {[string length
$shortcmit] > 80} {
1023 set shortcmit
"[string range $shortcmit 0 80]..."
1025 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1028 set id [lindex $ids 0]
1030 if {!$listed && [info exists parents($vid)]} continue
1032 set olds [lrange $ids 1 end]
1036 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1037 set cmitlisted($vid) $listed
1038 set parents($vid) $olds
1040 if {![info exists children($vid)]} {
1041 set children($vid) {}
1042 } elseif {[llength $children($vid)] == 1} {
1043 set k [lindex $children($vid) 0]
1044 if {[llength $parents($view,$k)] == 1 &&
1046 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1047 set a $varcid($view,$k)
1052 set a [newvarc $view $id]
1055 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1058 lappend varccommits($view,$a) $id
1062 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1064 if {[llength [lappend children($vp) $id]] > 1 &&
1065 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1066 set children($vp) [lsort -command [list vtokcmp $view] \
1068 catch {unset ordertok}
1070 if {[info exists varcid($view,$p)]} {
1071 fix_reversal $p $a $view
1077 incr commitidx($view)
1078 if {[info exists commitinterest($id)]} {
1079 foreach script $commitinterest($id) {
1080 lappend scripts [string map [list "%I" $id] $script]
1082 unset commitinterest($id)
1087 run chewcommits $view
1088 foreach s $scripts {
1091 if {$view == $curview} {
1092 # update progress bar
1093 global progressdirn progresscoords proglastnc
1094 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1095 set proglastnc $commitidx($view)
1096 set l [lindex $progresscoords 0]
1097 set r [lindex $progresscoords 1]
1098 if {$progressdirn} {
1099 set r [expr {$r + $inc}]
1105 set l [expr {$r - 0.2}]
1108 set l [expr {$l - $inc}]
1113 set r [expr {$l + 0.2}]
1115 set progresscoords [list $l $r]
1122 proc chewcommits {view} {
1123 global curview hlview viewcomplete
1124 global pending_select
1126 if {$view == $curview} {
1128 if {$viewcomplete($view)} {
1129 global commitidx varctok
1130 global numcommits startmsecs
1131 global mainheadid commitinfo nullid
1133 if {[info exists pending_select]} {
1134 set row [first_real_row]
1137 if {$commitidx($curview) > 0} {
1138 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1139 #puts "overall $ms ms for $numcommits commits"
1140 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1142 show_status [mc "No commits selected"]
1147 if {[info exists hlview] && $view == $hlview} {
1153 proc readcommit {id} {
1154 if {[catch {set contents [exec git cat-file commit $id]}]} return
1155 parsecommit $id $contents 0
1158 proc parsecommit {id contents listed} {
1159 global commitinfo cdate
1168 set hdrend [string first "\n\n" $contents]
1170 # should never happen...
1171 set hdrend [string length $contents]
1173 set header [string range $contents 0 [expr {$hdrend - 1}]]
1174 set comment [string range $contents [expr {$hdrend + 2}] end]
1175 foreach line [split $header "\n"] {
1176 set tag [lindex $line 0]
1177 if {$tag == "author"} {
1178 set audate [lindex $line end-1]
1179 set auname [lrange $line 1 end-2]
1180 } elseif {$tag == "committer"} {
1181 set comdate [lindex $line end-1]
1182 set comname [lrange $line 1 end-2]
1186 # take the first non-blank line of the comment as the headline
1187 set headline [string trimleft $comment]
1188 set i [string first "\n" $headline]
1190 set headline [string range $headline 0 $i]
1192 set headline [string trimright $headline]
1193 set i [string first "\r" $headline]
1195 set headline [string trimright [string range $headline 0 $i]]
1198 # git rev-list indents the comment by 4 spaces;
1199 # if we got this via git cat-file, add the indentation
1201 foreach line [split $comment "\n"] {
1202 append newcomment " "
1203 append newcomment $line
1204 append newcomment "\n"
1206 set comment $newcomment
1208 if {$comdate != {}} {
1209 set cdate($id) $comdate
1211 set commitinfo($id) [list $headline $auname $audate \
1212 $comname $comdate $comment]
1215 proc getcommit {id} {
1216 global commitdata commitinfo
1218 if {[info exists commitdata($id)]} {
1219 parsecommit $id $commitdata($id) 1
1222 if {![info exists commitinfo($id)]} {
1223 set commitinfo($id) [list [mc "No commit information available"]]
1230 global tagids idtags headids idheads tagobjid
1231 global otherrefids idotherrefs mainhead mainheadid
1233 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1236 set refd [open [list | git show-ref -d] r]
1237 while {[gets $refd line] >= 0} {
1238 if {[string index $line 40] ne " "} continue
1239 set id [string range $line 0 39]
1240 set ref [string range $line 41 end]
1241 if {![string match "refs/*" $ref]} continue
1242 set name [string range $ref 5 end]
1243 if {[string match "remotes/*" $name]} {
1244 if {![string match "*/HEAD" $name]} {
1245 set headids($name) $id
1246 lappend idheads($id) $name
1248 } elseif {[string match "heads/*" $name]} {
1249 set name [string range $name 6 end]
1250 set headids($name) $id
1251 lappend idheads($id) $name
1252 } elseif {[string match "tags/*" $name]} {
1253 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1254 # which is what we want since the former is the commit ID
1255 set name [string range $name 5 end]
1256 if {[string match "*^{}" $name]} {
1257 set name [string range $name 0 end-3]
1259 set tagobjid($name) $id
1261 set tagids($name) $id
1262 lappend idtags($id) $name
1264 set otherrefids($name) $id
1265 lappend idotherrefs($id) $name
1272 set thehead [exec git symbolic-ref HEAD]
1273 if {[string match "refs/heads/*" $thehead]} {
1274 set mainhead [string range $thehead 11 end]
1275 if {[info exists headids($mainhead)]} {
1276 set mainheadid $headids($mainhead)
1282 # skip over fake commits
1283 proc first_real_row {} {
1284 global nullid nullid2 numcommits
1286 for {set row 0} {$row < $numcommits} {incr row} {
1287 set id [commitonrow $row]
1288 if {$id ne $nullid && $id ne $nullid2} {
1295 # update things for a head moved to a child of its previous location
1296 proc movehead {id name} {
1297 global headids idheads
1299 removehead $headids($name) $name
1300 set headids($name) $id
1301 lappend idheads($id) $name
1304 # update things when a head has been removed
1305 proc removehead {id name} {
1306 global headids idheads
1308 if {$idheads($id) eq $name} {
1311 set i [lsearch -exact $idheads($id) $name]
1313 set idheads($id) [lreplace $idheads($id) $i $i]
1316 unset headids($name)
1319 proc show_error {w top msg} {
1320 message $w.m -text $msg -justify center -aspect 400
1321 pack $w.m -side top -fill x -padx 20 -pady 20
1322 button $w.ok -text [mc OK] -command "destroy $top"
1323 pack $w.ok -side bottom -fill x
1324 bind $top <Visibility> "grab $top; focus $top"
1325 bind $top <Key-Return> "destroy $top"
1329 proc error_popup msg {
1333 show_error $w $w $msg
1336 proc confirm_popup msg {
1342 message $w.m -text $msg -justify center -aspect 400
1343 pack $w.m -side top -fill x -padx 20 -pady 20
1344 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1345 pack $w.ok -side left -fill x
1346 button $w.cancel -text [mc Cancel] -command "destroy $w"
1347 pack $w.cancel -side right -fill x
1348 bind $w <Visibility> "grab $w; focus $w"
1353 proc setoptions {} {
1354 option add *Panedwindow.showHandle 1 startupFile
1355 option add *Panedwindow.sashRelief raised startupFile
1356 option add *Button.font uifont startupFile
1357 option add *Checkbutton.font uifont startupFile
1358 option add *Radiobutton.font uifont startupFile
1359 option add *Menu.font uifont startupFile
1360 option add *Menubutton.font uifont startupFile
1361 option add *Label.font uifont startupFile
1362 option add *Message.font uifont startupFile
1363 option add *Entry.font uifont startupFile
1366 proc makewindow {} {
1367 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1369 global findtype findtypemenu findloc findstring fstring geometry
1370 global entries sha1entry sha1string sha1but
1371 global diffcontextstring diffcontext
1372 global maincursor textcursor curtextcursor
1373 global rowctxmenu fakerowmenu mergemax wrapcomment
1374 global highlight_files gdttype
1375 global searchstring sstring
1376 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1377 global headctxmenu progresscanv progressitem progresscoords statusw
1378 global fprogitem fprogcoord lastprogupdate progupdatepending
1379 global rprogitem rprogcoord
1383 .bar add cascade -label [mc "File"] -menu .bar.file
1385 .bar.file add command -label [mc "Update"] -command updatecommits
1386 .bar.file add command -label [mc "Reload"] -command reloadcommits
1387 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1388 .bar.file add command -label [mc "List references"] -command showrefs
1389 .bar.file add command -label [mc "Quit"] -command doquit
1391 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1392 .bar.edit add command -label [mc "Preferences"] -command doprefs
1395 .bar add cascade -label [mc "View"] -menu .bar.view
1396 .bar.view add command -label [mc "New view..."] -command {newview 0}
1397 .bar.view add command -label [mc "Edit view..."] -command editview \
1399 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1400 .bar.view add separator
1401 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1402 -variable selectedview -value 0
1405 .bar add cascade -label [mc "Help"] -menu .bar.help
1406 .bar.help add command -label [mc "About gitk"] -command about
1407 .bar.help add command -label [mc "Key bindings"] -command keys
1409 . configure -menu .bar
1411 # the gui has upper and lower half, parts of a paned window.
1412 panedwindow .ctop -orient vertical
1414 # possibly use assumed geometry
1415 if {![info exists geometry(pwsash0)]} {
1416 set geometry(topheight) [expr {15 * $linespc}]
1417 set geometry(topwidth) [expr {80 * $charspc}]
1418 set geometry(botheight) [expr {15 * $linespc}]
1419 set geometry(botwidth) [expr {50 * $charspc}]
1420 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1421 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1424 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1425 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1427 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1429 # create three canvases
1430 set cscroll .tf.histframe.csb
1431 set canv .tf.histframe.pwclist.canv
1433 -selectbackground $selectbgcolor \
1434 -background $bgcolor -bd 0 \
1435 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1436 .tf.histframe.pwclist add $canv
1437 set canv2 .tf.histframe.pwclist.canv2
1439 -selectbackground $selectbgcolor \
1440 -background $bgcolor -bd 0 -yscrollincr $linespc
1441 .tf.histframe.pwclist add $canv2
1442 set canv3 .tf.histframe.pwclist.canv3
1444 -selectbackground $selectbgcolor \
1445 -background $bgcolor -bd 0 -yscrollincr $linespc
1446 .tf.histframe.pwclist add $canv3
1447 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1448 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1450 # a scroll bar to rule them
1451 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1452 pack $cscroll -side right -fill y
1453 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1454 lappend bglist $canv $canv2 $canv3
1455 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1457 # we have two button bars at bottom of top frame. Bar 1
1459 frame .tf.lbar -height 15
1461 set sha1entry .tf.bar.sha1
1462 set entries $sha1entry
1463 set sha1but .tf.bar.sha1label
1464 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1465 -command gotocommit -width 8
1466 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1467 pack .tf.bar.sha1label -side left
1468 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1469 trace add variable sha1string write sha1change
1470 pack $sha1entry -side left -pady 2
1472 image create bitmap bm-left -data {
1473 #define left_width 16
1474 #define left_height 16
1475 static unsigned char left_bits[] = {
1476 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1477 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1478 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1480 image create bitmap bm-right -data {
1481 #define right_width 16
1482 #define right_height 16
1483 static unsigned char right_bits[] = {
1484 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1485 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1486 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1488 button .tf.bar.leftbut -image bm-left -command goback \
1489 -state disabled -width 26
1490 pack .tf.bar.leftbut -side left -fill y
1491 button .tf.bar.rightbut -image bm-right -command goforw \
1492 -state disabled -width 26
1493 pack .tf.bar.rightbut -side left -fill y
1495 # Status label and progress bar
1496 set statusw .tf.bar.status
1497 label $statusw -width 15 -relief sunken
1498 pack $statusw -side left -padx 5
1499 set h [expr {[font metrics uifont -linespace] + 2}]
1500 set progresscanv .tf.bar.progress
1501 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1502 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1503 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1504 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1505 pack $progresscanv -side right -expand 1 -fill x
1506 set progresscoords {0 0}
1509 bind $progresscanv <Configure> adjustprogress
1510 set lastprogupdate [clock clicks -milliseconds]
1511 set progupdatepending 0
1513 # build up the bottom bar of upper window
1514 label .tf.lbar.flabel -text "[mc "Find"] "
1515 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1516 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1517 label .tf.lbar.flab2 -text " [mc "commit"] "
1518 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1520 set gdttype [mc "containing:"]
1521 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1522 [mc "containing:"] \
1523 [mc "touching paths:"] \
1524 [mc "adding/removing string:"]]
1525 trace add variable gdttype write gdttype_change
1526 pack .tf.lbar.gdttype -side left -fill y
1529 set fstring .tf.lbar.findstring
1530 lappend entries $fstring
1531 entry $fstring -width 30 -font textfont -textvariable findstring
1532 trace add variable findstring write find_change
1533 set findtype [mc "Exact"]
1534 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1535 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1536 trace add variable findtype write findcom_change
1537 set findloc [mc "All fields"]
1538 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1539 [mc "Comments"] [mc "Author"] [mc "Committer"]
1540 trace add variable findloc write find_change
1541 pack .tf.lbar.findloc -side right
1542 pack .tf.lbar.findtype -side right
1543 pack $fstring -side left -expand 1 -fill x
1545 # Finish putting the upper half of the viewer together
1546 pack .tf.lbar -in .tf -side bottom -fill x
1547 pack .tf.bar -in .tf -side bottom -fill x
1548 pack .tf.histframe -fill both -side top -expand 1
1550 .ctop paneconfigure .tf -height $geometry(topheight)
1551 .ctop paneconfigure .tf -width $geometry(topwidth)
1553 # now build up the bottom
1554 panedwindow .pwbottom -orient horizontal
1556 # lower left, a text box over search bar, scroll bar to the right
1557 # if we know window height, then that will set the lower text height, otherwise
1558 # we set lower text height which will drive window height
1559 if {[info exists geometry(main)]} {
1560 frame .bleft -width $geometry(botwidth)
1562 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1567 button .bleft.top.search -text [mc "Search"] -command dosearch
1568 pack .bleft.top.search -side left -padx 5
1569 set sstring .bleft.top.sstring
1570 entry $sstring -width 20 -font textfont -textvariable searchstring
1571 lappend entries $sstring
1572 trace add variable searchstring write incrsearch
1573 pack $sstring -side left -expand 1 -fill x
1574 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1575 -command changediffdisp -variable diffelide -value {0 0}
1576 radiobutton .bleft.mid.old -text [mc "Old version"] \
1577 -command changediffdisp -variable diffelide -value {0 1}
1578 radiobutton .bleft.mid.new -text [mc "New version"] \
1579 -command changediffdisp -variable diffelide -value {1 0}
1580 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1581 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1582 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1583 -from 1 -increment 1 -to 10000000 \
1584 -validate all -validatecommand "diffcontextvalidate %P" \
1585 -textvariable diffcontextstring
1586 .bleft.mid.diffcontext set $diffcontext
1587 trace add variable diffcontextstring write diffcontextchange
1588 lappend entries .bleft.mid.diffcontext
1589 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1590 set ctext .bleft.ctext
1591 text $ctext -background $bgcolor -foreground $fgcolor \
1592 -state disabled -font textfont \
1593 -yscrollcommand scrolltext -wrap none
1595 $ctext conf -tabstyle wordprocessor
1597 scrollbar .bleft.sb -command "$ctext yview"
1598 pack .bleft.top -side top -fill x
1599 pack .bleft.mid -side top -fill x
1600 pack .bleft.sb -side right -fill y
1601 pack $ctext -side left -fill both -expand 1
1602 lappend bglist $ctext
1603 lappend fglist $ctext
1605 $ctext tag conf comment -wrap $wrapcomment
1606 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1607 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1608 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1609 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1610 $ctext tag conf m0 -fore red
1611 $ctext tag conf m1 -fore blue
1612 $ctext tag conf m2 -fore green
1613 $ctext tag conf m3 -fore purple
1614 $ctext tag conf m4 -fore brown
1615 $ctext tag conf m5 -fore "#009090"
1616 $ctext tag conf m6 -fore magenta
1617 $ctext tag conf m7 -fore "#808000"
1618 $ctext tag conf m8 -fore "#009000"
1619 $ctext tag conf m9 -fore "#ff0080"
1620 $ctext tag conf m10 -fore cyan
1621 $ctext tag conf m11 -fore "#b07070"
1622 $ctext tag conf m12 -fore "#70b0f0"
1623 $ctext tag conf m13 -fore "#70f0b0"
1624 $ctext tag conf m14 -fore "#f0b070"
1625 $ctext tag conf m15 -fore "#ff70b0"
1626 $ctext tag conf mmax -fore darkgrey
1628 $ctext tag conf mresult -font textfontbold
1629 $ctext tag conf msep -font textfontbold
1630 $ctext tag conf found -back yellow
1632 .pwbottom add .bleft
1633 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1638 radiobutton .bright.mode.patch -text [mc "Patch"] \
1639 -command reselectline -variable cmitmode -value "patch"
1640 radiobutton .bright.mode.tree -text [mc "Tree"] \
1641 -command reselectline -variable cmitmode -value "tree"
1642 grid .bright.mode.patch .bright.mode.tree -sticky ew
1643 pack .bright.mode -side top -fill x
1644 set cflist .bright.cfiles
1645 set indent [font measure mainfont "nn"]
1647 -selectbackground $selectbgcolor \
1648 -background $bgcolor -foreground $fgcolor \
1650 -tabs [list $indent [expr {2 * $indent}]] \
1651 -yscrollcommand ".bright.sb set" \
1652 -cursor [. cget -cursor] \
1653 -spacing1 1 -spacing3 1
1654 lappend bglist $cflist
1655 lappend fglist $cflist
1656 scrollbar .bright.sb -command "$cflist yview"
1657 pack .bright.sb -side right -fill y
1658 pack $cflist -side left -fill both -expand 1
1659 $cflist tag configure highlight \
1660 -background [$cflist cget -selectbackground]
1661 $cflist tag configure bold -font mainfontbold
1663 .pwbottom add .bright
1666 # restore window position if known
1667 if {[info exists geometry(main)]} {
1668 wm geometry . "$geometry(main)"
1671 if {[tk windowingsystem] eq {aqua}} {
1677 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1678 pack .ctop -fill both -expand 1
1679 bindall <1> {selcanvline %W %x %y}
1680 #bindall <B1-Motion> {selcanvline %W %x %y}
1681 if {[tk windowingsystem] == "win32"} {
1682 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1683 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1685 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1686 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1687 if {[tk windowingsystem] eq "aqua"} {
1688 bindall <MouseWheel> {
1689 set delta [expr {- (%D)}]
1690 allcanvs yview scroll $delta units
1694 bindall <2> "canvscan mark %W %x %y"
1695 bindall <B2-Motion> "canvscan dragto %W %x %y"
1696 bindkey <Home> selfirstline
1697 bindkey <End> sellastline
1698 bind . <Key-Up> "selnextline -1"
1699 bind . <Key-Down> "selnextline 1"
1700 bind . <Shift-Key-Up> "dofind -1 0"
1701 bind . <Shift-Key-Down> "dofind 1 0"
1702 bindkey <Key-Right> "goforw"
1703 bindkey <Key-Left> "goback"
1704 bind . <Key-Prior> "selnextpage -1"
1705 bind . <Key-Next> "selnextpage 1"
1706 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1707 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1708 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1709 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1710 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1711 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1712 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1713 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1714 bindkey <Key-space> "$ctext yview scroll 1 pages"
1715 bindkey p "selnextline -1"
1716 bindkey n "selnextline 1"
1719 bindkey i "selnextline -1"
1720 bindkey k "selnextline 1"
1723 bindkey b "$ctext yview scroll -1 pages"
1724 bindkey d "$ctext yview scroll 18 units"
1725 bindkey u "$ctext yview scroll -18 units"
1726 bindkey / {dofind 1 1}
1727 bindkey <Key-Return> {dofind 1 1}
1728 bindkey ? {dofind -1 1}
1730 bindkey <F5> updatecommits
1731 bind . <$M1B-q> doquit
1732 bind . <$M1B-f> {dofind 1 1}
1733 bind . <$M1B-g> {dofind 1 0}
1734 bind . <$M1B-r> dosearchback
1735 bind . <$M1B-s> dosearch
1736 bind . <$M1B-equal> {incrfont 1}
1737 bind . <$M1B-KP_Add> {incrfont 1}
1738 bind . <$M1B-minus> {incrfont -1}
1739 bind . <$M1B-KP_Subtract> {incrfont -1}
1740 wm protocol . WM_DELETE_WINDOW doquit
1741 bind . <Button-1> "click %W"
1742 bind $fstring <Key-Return> {dofind 1 1}
1743 bind $sha1entry <Key-Return> gotocommit
1744 bind $sha1entry <<PasteSelection>> clearsha1
1745 bind $cflist <1> {sel_flist %W %x %y; break}
1746 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1747 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1748 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1750 set maincursor [. cget -cursor]
1751 set textcursor [$ctext cget -cursor]
1752 set curtextcursor $textcursor
1754 set rowctxmenu .rowctxmenu
1755 menu $rowctxmenu -tearoff 0
1756 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1757 -command {diffvssel 0}
1758 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1759 -command {diffvssel 1}
1760 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1761 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1762 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1763 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1764 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1766 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1769 set fakerowmenu .fakerowmenu
1770 menu $fakerowmenu -tearoff 0
1771 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1772 -command {diffvssel 0}
1773 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1774 -command {diffvssel 1}
1775 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1776 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1777 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1778 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1780 set headctxmenu .headctxmenu
1781 menu $headctxmenu -tearoff 0
1782 $headctxmenu add command -label [mc "Check out this branch"] \
1784 $headctxmenu add command -label [mc "Remove this branch"] \
1788 set flist_menu .flistctxmenu
1789 menu $flist_menu -tearoff 0
1790 $flist_menu add command -label [mc "Highlight this too"] \
1791 -command {flist_hl 0}
1792 $flist_menu add command -label [mc "Highlight this only"] \
1793 -command {flist_hl 1}
1796 # Windows sends all mouse wheel events to the current focused window, not
1797 # the one where the mouse hovers, so bind those events here and redirect
1798 # to the correct window
1799 proc windows_mousewheel_redirector {W X Y D} {
1800 global canv canv2 canv3
1801 set w [winfo containing -displayof $W $X $Y]
1803 set u [expr {$D < 0 ? 5 : -5}]
1804 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1805 allcanvs yview scroll $u units
1808 $w yview scroll $u units
1814 # mouse-2 makes all windows scan vertically, but only the one
1815 # the cursor is in scans horizontally
1816 proc canvscan {op w x y} {
1817 global canv canv2 canv3
1818 foreach c [list $canv $canv2 $canv3] {
1827 proc scrollcanv {cscroll f0 f1} {
1828 $cscroll set $f0 $f1
1833 # when we make a key binding for the toplevel, make sure
1834 # it doesn't get triggered when that key is pressed
in the
1835 # find string entry widget.
1836 proc bindkey
{ev
script} {
1839 set escript
[bind Entry
$ev]
1840 if {$escript == {}} {
1841 set escript
[bind Entry
<Key
>]
1843 foreach e
$entries {
1844 bind $e $ev "$escript; break"
1848 # set the focus back to the toplevel for any click outside
1851 global ctext entries
1852 foreach e
[concat
$entries $ctext] {
1853 if {$w == $e} return
1858 # Adjust the progress bar for a change in requested extent or canvas size
1859 proc adjustprogress
{} {
1860 global progresscanv progressitem progresscoords
1861 global fprogitem fprogcoord lastprogupdate progupdatepending
1862 global rprogitem rprogcoord
1864 set w
[expr {[winfo width
$progresscanv] - 4}]
1865 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1866 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1867 set h
[winfo height
$progresscanv]
1868 $progresscanv coords
$progressitem $x0 0 $x1 $h
1869 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1870 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1871 set now
[clock clicks
-milliseconds]
1872 if {$now >= $lastprogupdate + 100} {
1873 set progupdatepending
0
1875 } elseif
{!$progupdatepending} {
1876 set progupdatepending
1
1877 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1881 proc doprogupdate
{} {
1882 global lastprogupdate progupdatepending
1884 if {$progupdatepending} {
1885 set progupdatepending
0
1886 set lastprogupdate
[clock clicks
-milliseconds]
1891 proc savestuff
{w
} {
1892 global canv canv2 canv3 mainfont textfont uifont tabstop
1893 global stuffsaved findmergefiles maxgraphpct
1894 global maxwidth showneartags showlocalchanges
1895 global viewname viewfiles viewargs viewperm nextviewnum
1896 global cmitmode wrapcomment datetimeformat limitdiffs
1897 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1899 if {$stuffsaved} return
1900 if {![winfo viewable .
]} return
1902 set f
[open
"~/.gitk-new" w
]
1903 puts
$f [list
set mainfont
$mainfont]
1904 puts
$f [list
set textfont
$textfont]
1905 puts
$f [list
set uifont
$uifont]
1906 puts
$f [list
set tabstop
$tabstop]
1907 puts
$f [list
set findmergefiles
$findmergefiles]
1908 puts
$f [list
set maxgraphpct
$maxgraphpct]
1909 puts
$f [list
set maxwidth
$maxwidth]
1910 puts
$f [list
set cmitmode
$cmitmode]
1911 puts
$f [list
set wrapcomment
$wrapcomment]
1912 puts
$f [list
set showneartags
$showneartags]
1913 puts
$f [list
set showlocalchanges
$showlocalchanges]
1914 puts
$f [list
set datetimeformat
$datetimeformat]
1915 puts
$f [list
set limitdiffs
$limitdiffs]
1916 puts
$f [list
set bgcolor
$bgcolor]
1917 puts
$f [list
set fgcolor
$fgcolor]
1918 puts
$f [list
set colors
$colors]
1919 puts
$f [list
set diffcolors
$diffcolors]
1920 puts
$f [list
set diffcontext
$diffcontext]
1921 puts
$f [list
set selectbgcolor
$selectbgcolor]
1923 puts
$f "set geometry(main) [wm geometry .]"
1924 puts
$f "set geometry(topwidth) [winfo width .tf]"
1925 puts
$f "set geometry(topheight) [winfo height .tf]"
1926 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1927 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1928 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1929 puts
$f "set geometry(botheight) [winfo height .bleft]"
1931 puts
-nonewline $f "set permviews {"
1932 for {set v
0} {$v < $nextviewnum} {incr v
} {
1933 if {$viewperm($v)} {
1934 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1939 file rename
-force "~/.gitk-new" "~/.gitk"
1944 proc resizeclistpanes
{win w
} {
1946 if {[info exists oldwidth
($win)]} {
1947 set s0
[$win sash coord
0]
1948 set s1
[$win sash coord
1]
1950 set sash0
[expr {int
($w/2 - 2)}]
1951 set sash1
[expr {int
($w*5/6 - 2)}]
1953 set factor [expr {1.0 * $w / $oldwidth($win)}]
1954 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1955 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1959 if {$sash1 < $sash0 + 20} {
1960 set sash1
[expr {$sash0 + 20}]
1962 if {$sash1 > $w - 10} {
1963 set sash1
[expr {$w - 10}]
1964 if {$sash0 > $sash1 - 20} {
1965 set sash0
[expr {$sash1 - 20}]
1969 $win sash place
0 $sash0 [lindex
$s0 1]
1970 $win sash place
1 $sash1 [lindex
$s1 1]
1972 set oldwidth
($win) $w
1975 proc resizecdetpanes
{win w
} {
1977 if {[info exists oldwidth
($win)]} {
1978 set s0
[$win sash coord
0]
1980 set sash0
[expr {int
($w*3/4 - 2)}]
1982 set factor [expr {1.0 * $w / $oldwidth($win)}]
1983 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1987 if {$sash0 > $w - 15} {
1988 set sash0
[expr {$w - 15}]
1991 $win sash place
0 $sash0 [lindex
$s0 1]
1993 set oldwidth
($win) $w
1996 proc allcanvs args
{
1997 global canv canv2 canv3
2003 proc bindall
{event action
} {
2004 global canv canv2 canv3
2005 bind $canv $event $action
2006 bind $canv2 $event $action
2007 bind $canv3 $event $action
2013 if {[winfo exists
$w]} {
2018 wm title
$w [mc
"About gitk"]
2019 message
$w.m
-text [mc
"
2020 Gitk - a commit viewer for git
2022 Copyright © 2005-2006 Paul Mackerras
2024 Use and redistribute under the terms of the GNU General Public License"] \
2025 -justify center
-aspect 400 -border 2 -bg white
-relief groove
2026 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
2027 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2028 pack
$w.ok
-side bottom
2029 bind $w <Visibility
> "focus $w.ok"
2030 bind $w <Key-Escape
> "destroy $w"
2031 bind $w <Key-Return
> "destroy $w"
2036 if {[winfo exists
$w]} {
2040 if {[tk windowingsystem
] eq
{aqua
}} {
2046 wm title
$w [mc
"Gitk key bindings"]
2047 message
$w.m
-text [mc
"
2051 <Home> Move to first commit
2052 <End> Move to last commit
2053 <Up>, p, i Move up one commit
2054 <Down>, n, k Move down one commit
2055 <Left>, z, j Go back in history list
2056 <Right>, x, l Go forward in history list
2057 <PageUp> Move up one page in commit list
2058 <PageDown> Move down one page in commit list
2059 <$M1T-Home> Scroll to top of commit list
2060 <$M1T-End> Scroll to bottom of commit list
2061 <$M1T-Up> Scroll commit list up one line
2062 <$M1T-Down> Scroll commit list down one line
2063 <$M1T-PageUp> Scroll commit list up one page
2064 <$M1T-PageDown> Scroll commit list down one page
2065 <Shift-Up> Find backwards (upwards, later commits)
2066 <Shift-Down> Find forwards (downwards, earlier commits)
2067 <Delete>, b Scroll diff view up one page
2068 <Backspace> Scroll diff view up one page
2069 <Space> Scroll diff view down one page
2070 u Scroll diff view up 18 lines
2071 d Scroll diff view down 18 lines
2073 <$M1T-G> Move to next find hit
2074 <Return> Move to next find hit
2075 / Move to next find hit, or redo find
2076 ? Move to previous find hit
2077 f Scroll diff view to next file
2078 <$M1T-S> Search for next hit in diff view
2079 <$M1T-R> Search for previous hit in diff view
2080 <$M1T-KP+> Increase font size
2081 <$M1T-plus> Increase font size
2082 <$M1T-KP-> Decrease font size
2083 <$M1T-minus> Decrease font size
2086 -justify left
-bg white
-border 2 -relief groove
2087 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
2088 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2089 pack
$w.ok
-side bottom
2090 bind $w <Visibility
> "focus $w.ok"
2091 bind $w <Key-Escape
> "destroy $w"
2092 bind $w <Key-Return
> "destroy $w"
2095 # Procedures for manipulating the file list window at the
2096 # bottom right of the overall window.
2098 proc treeview
{w l openlevs
} {
2099 global treecontents treediropen treeheight treeparent treeindex
2109 set treecontents
() {}
2110 $w conf
-state normal
2112 while {[string range
$f 0 $prefixend] ne
$prefix} {
2113 if {$lev <= $openlevs} {
2114 $w mark
set e
:$treeindex($prefix) "end -1c"
2115 $w mark gravity e
:$treeindex($prefix) left
2117 set treeheight
($prefix) $ht
2118 incr ht
[lindex
$htstack end
]
2119 set htstack
[lreplace
$htstack end end
]
2120 set prefixend
[lindex
$prefendstack end
]
2121 set prefendstack
[lreplace
$prefendstack end end
]
2122 set prefix
[string range
$prefix 0 $prefixend]
2125 set tail [string range
$f [expr {$prefixend+1}] end
]
2126 while {[set slash
[string first
"/" $tail]] >= 0} {
2129 lappend prefendstack
$prefixend
2130 incr prefixend
[expr {$slash + 1}]
2131 set d
[string range
$tail 0 $slash]
2132 lappend treecontents
($prefix) $d
2133 set oldprefix
$prefix
2135 set treecontents
($prefix) {}
2136 set treeindex
($prefix) [incr ix
]
2137 set treeparent
($prefix) $oldprefix
2138 set tail [string range
$tail [expr {$slash+1}] end
]
2139 if {$lev <= $openlevs} {
2141 set treediropen
($prefix) [expr {$lev < $openlevs}]
2142 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
2143 $w mark
set d
:$ix "end -1c"
2144 $w mark gravity d
:$ix left
2146 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2148 $w image create end
-align center
-image $bm -padx 1 \
2150 $w insert end
$d [highlight_tag
$prefix]
2151 $w mark
set s
:$ix "end -1c"
2152 $w mark gravity s
:$ix left
2157 if {$lev <= $openlevs} {
2160 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2162 $w insert end
$tail [highlight_tag
$f]
2164 lappend treecontents
($prefix) $tail
2167 while {$htstack ne
{}} {
2168 set treeheight
($prefix) $ht
2169 incr ht
[lindex
$htstack end
]
2170 set htstack
[lreplace
$htstack end end
]
2171 set prefixend
[lindex
$prefendstack end
]
2172 set prefendstack
[lreplace
$prefendstack end end
]
2173 set prefix
[string range
$prefix 0 $prefixend]
2175 $w conf
-state disabled
2178 proc linetoelt
{l
} {
2179 global treeheight treecontents
2184 foreach e
$treecontents($prefix) {
2189 if {[string index
$e end
] eq
"/"} {
2190 set n
$treeheight($prefix$e)
2202 proc highlight_tree
{y prefix
} {
2203 global treeheight treecontents cflist
2205 foreach e
$treecontents($prefix) {
2207 if {[highlight_tag
$path] ne
{}} {
2208 $cflist tag add bold
$y.0 "$y.0 lineend"
2211 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
2212 set y
[highlight_tree
$y $path]
2218 proc treeclosedir
{w dir
} {
2219 global treediropen treeheight treeparent treeindex
2221 set ix
$treeindex($dir)
2222 $w conf
-state normal
2223 $w delete s
:$ix e
:$ix
2224 set treediropen
($dir) 0
2225 $w image configure a
:$ix -image tri-rt
2226 $w conf
-state disabled
2227 set n
[expr {1 - $treeheight($dir)}]
2228 while {$dir ne
{}} {
2229 incr treeheight
($dir) $n
2230 set dir
$treeparent($dir)
2234 proc treeopendir
{w dir
} {
2235 global treediropen treeheight treeparent treecontents treeindex
2237 set ix
$treeindex($dir)
2238 $w conf
-state normal
2239 $w image configure a
:$ix -image tri-dn
2240 $w mark
set e
:$ix s
:$ix
2241 $w mark gravity e
:$ix right
2244 set n
[llength
$treecontents($dir)]
2245 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
2248 incr treeheight
($x) $n
2250 foreach e
$treecontents($dir) {
2252 if {[string index
$e end
] eq
"/"} {
2253 set iy
$treeindex($de)
2254 $w mark
set d
:$iy e
:$ix
2255 $w mark gravity d
:$iy left
2256 $w insert e
:$ix $str
2257 set treediropen
($de) 0
2258 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
2260 $w insert e
:$ix $e [highlight_tag
$de]
2261 $w mark
set s
:$iy e
:$ix
2262 $w mark gravity s
:$iy left
2263 set treeheight
($de) 1
2265 $w insert e
:$ix $str
2266 $w insert e
:$ix $e [highlight_tag
$de]
2269 $w mark gravity e
:$ix left
2270 $w conf
-state disabled
2271 set treediropen
($dir) 1
2272 set top
[lindex
[split [$w index @
0,0] .
] 0]
2273 set ht
[$w cget
-height]
2274 set l
[lindex
[split [$w index s
:$ix] .
] 0]
2277 } elseif
{$l + $n + 1 > $top + $ht} {
2278 set top
[expr {$l + $n + 2 - $ht}]
2286 proc treeclick
{w x y
} {
2287 global treediropen cmitmode ctext cflist cflist_top
2289 if {$cmitmode ne
"tree"} return
2290 if {![info exists cflist_top
]} return
2291 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2292 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2293 $cflist tag add highlight
$l.0 "$l.0 lineend"
2299 set e
[linetoelt
$l]
2300 if {[string index
$e end
] ne
"/"} {
2302 } elseif
{$treediropen($e)} {
2309 proc setfilelist
{id
} {
2310 global treefilelist cflist
2312 treeview
$cflist $treefilelist($id) 0
2315 image create bitmap tri-rt
-background black
-foreground blue
-data {
2316 #define tri-rt_width 13
2317 #define tri-rt_height 13
2318 static unsigned char tri-rt_bits
[] = {
2319 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2320 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2323 #define tri-rt-mask_width 13
2324 #define tri-rt-mask_height 13
2325 static unsigned char tri-rt-mask_bits
[] = {
2326 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2327 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2330 image create bitmap tri-dn
-background black
-foreground blue
-data {
2331 #define tri-dn_width 13
2332 #define tri-dn_height 13
2333 static unsigned char tri-dn_bits
[] = {
2334 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2335 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2338 #define tri-dn-mask_width 13
2339 #define tri-dn-mask_height 13
2340 static unsigned char tri-dn-mask_bits
[] = {
2341 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2342 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2346 image create bitmap reficon-T
-background black
-foreground yellow
-data {
2347 #define tagicon_width 13
2348 #define tagicon_height 9
2349 static unsigned char tagicon_bits
[] = {
2350 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2351 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2353 #define tagicon-mask_width 13
2354 #define tagicon-mask_height 9
2355 static unsigned char tagicon-mask_bits
[] = {
2356 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2357 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2360 #define headicon_width 13
2361 #define headicon_height 9
2362 static unsigned char headicon_bits
[] = {
2363 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2364 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2367 #define headicon-mask_width 13
2368 #define headicon-mask_height 9
2369 static unsigned char headicon-mask_bits
[] = {
2370 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2371 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2373 image create bitmap reficon-H
-background black
-foreground green \
2374 -data $rectdata -maskdata $rectmask
2375 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
2376 -data $rectdata -maskdata $rectmask
2378 proc init_flist
{first
} {
2379 global cflist cflist_top difffilestart
2381 $cflist conf
-state normal
2382 $cflist delete
0.0 end
2384 $cflist insert end
$first
2386 $cflist tag add highlight
1.0 "1.0 lineend"
2388 catch
{unset cflist_top
}
2390 $cflist conf
-state disabled
2391 set difffilestart
{}
2394 proc highlight_tag
{f
} {
2395 global highlight_paths
2397 foreach p
$highlight_paths {
2398 if {[string match
$p $f]} {
2405 proc highlight_filelist
{} {
2406 global cmitmode cflist
2408 $cflist conf
-state normal
2409 if {$cmitmode ne
"tree"} {
2410 set end
[lindex
[split [$cflist index end
] .
] 0]
2411 for {set l
2} {$l < $end} {incr l
} {
2412 set line
[$cflist get
$l.0 "$l.0 lineend"]
2413 if {[highlight_tag
$line] ne
{}} {
2414 $cflist tag add bold
$l.0 "$l.0 lineend"
2420 $cflist conf
-state disabled
2423 proc unhighlight_filelist
{} {
2426 $cflist conf
-state normal
2427 $cflist tag remove bold
1.0 end
2428 $cflist conf
-state disabled
2431 proc add_flist
{fl
} {
2434 $cflist conf
-state normal
2436 $cflist insert end
"\n"
2437 $cflist insert end
$f [highlight_tag
$f]
2439 $cflist conf
-state disabled
2442 proc sel_flist
{w x y
} {
2443 global ctext difffilestart cflist cflist_top cmitmode
2445 if {$cmitmode eq
"tree"} return
2446 if {![info exists cflist_top
]} return
2447 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2448 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2449 $cflist tag add highlight
$l.0 "$l.0 lineend"
2454 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
2458 proc pop_flist_menu
{w X Y x y
} {
2459 global ctext cflist cmitmode flist_menu flist_menu_file
2460 global treediffs diffids
2463 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2465 if {$cmitmode eq
"tree"} {
2466 set e
[linetoelt
$l]
2467 if {[string index
$e end
] eq
"/"} return
2469 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
2471 set flist_menu_file
$e
2472 tk_popup
$flist_menu $X $Y
2475 proc flist_hl
{only
} {
2476 global flist_menu_file findstring gdttype
2478 set x
[shellquote
$flist_menu_file]
2479 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
2482 append findstring
" " $x
2484 set gdttype
[mc
"touching paths:"]
2487 # Functions for adding and removing shell-type quoting
2489 proc shellquote
{str
} {
2490 if {![string match
"*\['\"\\ \t]*" $str]} {
2493 if {![string match
"*\['\"\\]*" $str]} {
2496 if {![string match
"*'*" $str]} {
2499 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2502 proc shellarglist
{l
} {
2508 append str
[shellquote
$a]
2513 proc shelldequote
{str
} {
2518 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
2519 append ret
[string range
$str $used end
]
2520 set used
[string length
$str]
2523 set first
[lindex
$first 0]
2524 set ch
[string index
$str $first]
2525 if {$first > $used} {
2526 append ret
[string range
$str $used [expr {$first - 1}]]
2529 if {$ch eq
" " ||
$ch eq
"\t"} break
2532 set first
[string first
"'" $str $used]
2534 error
"unmatched single-quote"
2536 append ret
[string range
$str $used [expr {$first - 1}]]
2541 if {$used >= [string length
$str]} {
2542 error
"trailing backslash"
2544 append ret
[string index
$str $used]
2549 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
2550 error
"unmatched double-quote"
2552 set first
[lindex
$first 0]
2553 set ch
[string index
$str $first]
2554 if {$first > $used} {
2555 append ret
[string range
$str $used [expr {$first - 1}]]
2558 if {$ch eq
"\""} break
2560 append ret
[string index
$str $used]
2564 return [list
$used $ret]
2567 proc shellsplit
{str
} {
2570 set str
[string trimleft
$str]
2571 if {$str eq
{}} break
2572 set dq
[shelldequote
$str]
2573 set n
[lindex
$dq 0]
2574 set word
[lindex
$dq 1]
2575 set str
[string range
$str $n end
]
2581 # Code to implement multiple views
2583 proc newview
{ishighlight
} {
2584 global nextviewnum newviewname newviewperm newishighlight
2585 global newviewargs revtreeargs
2587 set newishighlight
$ishighlight
2589 if {[winfo exists
$top]} {
2593 set newviewname
($nextviewnum) "View $nextviewnum"
2594 set newviewperm
($nextviewnum) 0
2595 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
2596 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
2601 global viewname viewperm newviewname newviewperm
2602 global viewargs newviewargs
2604 set top .gitkvedit-
$curview
2605 if {[winfo exists
$top]} {
2609 set newviewname
($curview) $viewname($curview)
2610 set newviewperm
($curview) $viewperm($curview)
2611 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
2612 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
2615 proc vieweditor
{top n title
} {
2616 global newviewname newviewperm viewfiles bgcolor
2619 wm title
$top $title
2620 label
$top.
nl -text [mc
"Name"]
2621 entry
$top.name
-width 20 -textvariable newviewname
($n)
2622 grid
$top.
nl $top.name
-sticky w
-pady 5
2623 checkbutton
$top.perm
-text [mc
"Remember this view"] \
2624 -variable newviewperm
($n)
2625 grid
$top.perm
- -pady 5 -sticky w
2626 message
$top.al
-aspect 1000 \
2627 -text [mc
"Commits to include (arguments to git rev-list):"]
2628 grid
$top.al
- -sticky w
-pady 5
2629 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
2630 -background $bgcolor
2631 grid
$top.args
- -sticky ew
-padx 5
2632 message
$top.l
-aspect 1000 \
2633 -text [mc
"Enter files and directories to include, one per line:"]
2634 grid
$top.l
- -sticky w
2635 text
$top.t
-width 40 -height 10 -background $bgcolor -font uifont
2636 if {[info exists viewfiles
($n)]} {
2637 foreach f
$viewfiles($n) {
2638 $top.t insert end
$f
2639 $top.t insert end
"\n"
2641 $top.t delete
{end
- 1c
} end
2642 $top.t mark
set insert
0.0
2644 grid
$top.t
- -sticky ew
-padx 5
2646 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n]
2647 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top]
2648 grid
$top.buts.ok
$top.buts.can
2649 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
2650 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
2651 grid
$top.buts
- -pady 10 -sticky ew
2655 proc doviewmenu
{m first cmd op argv
} {
2656 set nmenu
[$m index end
]
2657 for {set i
$first} {$i <= $nmenu} {incr i
} {
2658 if {[$m entrycget
$i -command] eq
$cmd} {
2659 eval $m $op $i $argv
2665 proc allviewmenus
{n op args
} {
2668 doviewmenu .bar.view
5 [list showview
$n] $op $args
2669 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2672 proc newviewok
{top n
} {
2673 global nextviewnum newviewperm newviewname newishighlight
2674 global viewname viewfiles viewperm selectedview curview
2675 global viewargs newviewargs viewhlmenu
2678 set newargs
[shellsplit
$newviewargs($n)]
2680 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
2686 foreach f
[split [$top.t get
0.0 end
] "\n"] {
2687 set ft
[string trim
$f]
2692 if {![info exists viewfiles
($n)]} {
2693 # creating a new view
2695 set viewname
($n) $newviewname($n)
2696 set viewperm
($n) $newviewperm($n)
2697 set viewfiles
($n) $files
2698 set viewargs
($n) $newargs
2700 if {!$newishighlight} {
2703 run addvhighlight
$n
2706 # editing an existing view
2707 set viewperm
($n) $newviewperm($n)
2708 if {$newviewname($n) ne
$viewname($n)} {
2709 set viewname
($n) $newviewname($n)
2710 doviewmenu .bar.view
5 [list showview
$n] \
2711 entryconf
[list
-label $viewname($n)]
2712 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2713 # entryconf [list -label $viewname($n) -value $viewname($n)]
2715 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n)} {
2716 set viewfiles
($n) $files
2717 set viewargs
($n) $newargs
2718 if {$curview == $n} {
2723 catch
{destroy
$top}
2727 global curview viewperm hlview selectedhlview
2729 if {$curview == 0} return
2730 if {[info exists hlview
] && $hlview == $curview} {
2731 set selectedhlview
[mc
"None"]
2734 allviewmenus
$curview delete
2735 set viewperm
($curview) 0
2739 proc addviewmenu
{n
} {
2740 global viewname viewhlmenu
2742 .bar.view add radiobutton
-label $viewname($n) \
2743 -command [list showview
$n] -variable selectedview
-value $n
2744 #$viewhlmenu add radiobutton -label $viewname($n) \
2745 # -command [list addvhighlight $n] -variable selectedhlview
2749 global curview viewfiles cached_commitrow ordertok
2750 global displayorder parentlist rowidlist rowisopt rowfinal
2751 global colormap rowtextx nextcolor canvxmax
2752 global numcommits viewcomplete
2753 global selectedline currentid canv canvy0
2755 global pending_select mainheadid
2758 global hlview selectedhlview commitinterest
2760 if {$n == $curview} return
2762 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2763 set span
[$canv yview
]
2764 set ytop
[expr {[lindex
$span 0] * $ymax}]
2765 set ybot
[expr {[lindex
$span 1] * $ymax}]
2766 set yscreen
[expr {($ybot - $ytop) / 2}]
2767 if {[info exists selectedline
]} {
2768 set selid
$currentid
2769 set y
[yc
$selectedline]
2770 if {$ytop < $y && $y < $ybot} {
2771 set yscreen
[expr {$y - $ytop}]
2773 } elseif
{[info exists pending_select
]} {
2774 set selid
$pending_select
2775 unset pending_select
2779 catch
{unset treediffs
}
2781 if {[info exists hlview
] && $hlview == $n} {
2783 set selectedhlview
[mc
"None"]
2785 catch
{unset commitinterest
}
2786 catch
{unset cached_commitrow
}
2787 catch
{unset ordertok
}
2791 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2792 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2795 if {![info exists viewcomplete
($n)]} {
2797 set pending_select
$selid
2808 set numcommits
$commitidx($n)
2810 catch
{unset colormap
}
2811 catch
{unset rowtextx
}
2813 set canvxmax
[$canv cget
-width]
2819 if {$selid ne
{} && [commitinview
$selid $n]} {
2820 set row
[rowofcommit
$selid]
2821 # try to get the selected row in the same position on the screen
2822 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2823 set ytop
[expr {[yc
$row] - $yscreen}]
2827 set yf
[expr {$ytop * 1.0 / $ymax}]
2829 allcanvs yview moveto
$yf
2833 } elseif
{$mainheadid ne
{} && [commitinview
$mainheadid $curview]} {
2834 selectline
[rowofcommit
$mainheadid] 1
2835 } elseif
{!$viewcomplete($n)} {
2837 set pending_select
$selid
2839 set pending_select
$mainheadid
2842 set row
[first_real_row
]
2843 if {$row < $numcommits} {
2847 if {!$viewcomplete($n)} {
2848 if {$numcommits == 0} {
2849 show_status
[mc
"Reading commits..."]
2851 } elseif
{$numcommits == 0} {
2852 show_status
[mc
"No commits selected"]
2856 # Stuff relating to the highlighting facility
2858 proc ishighlighted
{id
} {
2859 global vhighlights fhighlights nhighlights rhighlights
2861 if {[info exists nhighlights
($id)] && $nhighlights($id) > 0} {
2862 return $nhighlights($id)
2864 if {[info exists vhighlights
($id)] && $vhighlights($id) > 0} {
2865 return $vhighlights($id)
2867 if {[info exists fhighlights
($id)] && $fhighlights($id) > 0} {
2868 return $fhighlights($id)
2870 if {[info exists rhighlights
($id)] && $rhighlights($id) > 0} {
2871 return $rhighlights($id)
2876 proc bolden
{row font
} {
2877 global canv linehtag selectedline boldrows
2879 lappend boldrows
$row
2880 $canv itemconf
$linehtag($row) -font $font
2881 if {[info exists selectedline
] && $row == $selectedline} {
2883 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2884 -outline {{}} -tags secsel \
2885 -fill [$canv cget
-selectbackground]]
2890 proc bolden_name
{row font
} {
2891 global canv2 linentag selectedline boldnamerows
2893 lappend boldnamerows
$row
2894 $canv2 itemconf
$linentag($row) -font $font
2895 if {[info exists selectedline
] && $row == $selectedline} {
2896 $canv2 delete secsel
2897 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2898 -outline {{}} -tags secsel \
2899 -fill [$canv2 cget
-selectbackground]]
2908 foreach row
$boldrows {
2909 if {![ishighlighted
[commitonrow
$row]]} {
2910 bolden
$row mainfont
2912 lappend stillbold
$row
2915 set boldrows
$stillbold
2918 proc addvhighlight
{n
} {
2919 global hlview viewcomplete curview vhl_done commitidx
2921 if {[info exists hlview
]} {
2925 if {$n != $curview && ![info exists viewcomplete
($n)]} {
2928 set vhl_done
$commitidx($hlview)
2929 if {$vhl_done > 0} {
2934 proc delvhighlight
{} {
2935 global hlview vhighlights
2937 if {![info exists hlview
]} return
2939 catch
{unset vhighlights
}
2943 proc vhighlightmore
{} {
2944 global hlview vhl_done commitidx vhighlights curview
2946 set max
$commitidx($hlview)
2947 set vr
[visiblerows
]
2948 set r0
[lindex
$vr 0]
2949 set r1
[lindex
$vr 1]
2950 for {set i
$vhl_done} {$i < $max} {incr i
} {
2951 set id
[commitonrow
$i $hlview]
2952 if {[commitinview
$id $curview]} {
2953 set row
[rowofcommit
$id]
2954 if {$r0 <= $row && $row <= $r1} {
2955 if {![highlighted
$row]} {
2956 bolden
$row mainfontbold
2958 set vhighlights
($id) 1
2965 proc askvhighlight
{row id
} {
2966 global hlview vhighlights iddrawn
2968 if {[commitinview
$id $hlview]} {
2969 if {[info exists iddrawn
($id)] && ![ishighlighted
$id]} {
2970 bolden
$row mainfontbold
2972 set vhighlights
($id) 1
2974 set vhighlights
($id) 0
2978 proc hfiles_change
{} {
2979 global highlight_files filehighlight fhighlights fh_serial
2980 global highlight_paths gdttype
2982 if {[info exists filehighlight
]} {
2983 # delete previous highlights
2984 catch
{close
$filehighlight}
2986 catch
{unset fhighlights
}
2988 unhighlight_filelist
2990 set highlight_paths
{}
2991 after cancel do_file_hl
$fh_serial
2993 if {$highlight_files ne
{}} {
2994 after
300 do_file_hl
$fh_serial
2998 proc gdttype_change
{name ix op
} {
2999 global gdttype highlight_files findstring findpattern
3002 if {$findstring ne
{}} {
3003 if {$gdttype eq
[mc
"containing:"]} {
3004 if {$highlight_files ne
{}} {
3005 set highlight_files
{}
3010 if {$findpattern ne
{}} {
3014 set highlight_files
$findstring
3019 # enable/disable findtype/findloc menus too
3022 proc find_change
{name ix op
} {
3023 global gdttype findstring highlight_files
3026 if {$gdttype eq
[mc
"containing:"]} {
3029 if {$highlight_files ne
$findstring} {
3030 set highlight_files
$findstring
3037 proc findcom_change args
{
3038 global nhighlights boldnamerows
3039 global findpattern findtype findstring gdttype
3042 # delete previous highlights, if any
3043 foreach row
$boldnamerows {
3044 bolden_name
$row mainfont
3047 catch
{unset nhighlights
}
3050 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
3052 } elseif
{$findtype eq
[mc
"Regexp"]} {
3053 set findpattern
$findstring
3055 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3057 set findpattern
"*$e*"
3061 proc makepatterns
{l
} {
3064 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3065 if {[string index
$ee end
] eq
"/"} {
3075 proc do_file_hl
{serial
} {
3076 global highlight_files filehighlight highlight_paths gdttype fhl_list
3078 if {$gdttype eq
[mc
"touching paths:"]} {
3079 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
3080 set highlight_paths
[makepatterns
$paths]
3082 set gdtargs
[concat
-- $paths]
3083 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
3084 set gdtargs
[list
"-S$highlight_files"]
3086 # must be "containing:", i.e. we're searching commit info
3089 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
3090 set filehighlight
[open
$cmd r
+]
3091 fconfigure
$filehighlight -blocking 0
3092 filerun
$filehighlight readfhighlight
3098 proc flushhighlights
{} {
3099 global filehighlight fhl_list
3101 if {[info exists filehighlight
]} {
3103 puts
$filehighlight ""
3104 flush
$filehighlight
3108 proc askfilehighlight
{row id
} {
3109 global filehighlight fhighlights fhl_list
3111 lappend fhl_list
$id
3112 set fhighlights
($id) -1
3113 puts
$filehighlight $id
3116 proc readfhighlight
{} {
3117 global filehighlight fhighlights curview iddrawn
3118 global fhl_list find_dirn
3120 if {![info exists filehighlight
]} {
3124 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
3125 set line
[string trim
$line]
3126 set i
[lsearch
-exact $fhl_list $line]
3127 if {$i < 0} continue
3128 for {set j
0} {$j < $i} {incr j
} {
3129 set id
[lindex
$fhl_list $j]
3130 set fhighlights
($id) 0
3132 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
3133 if {$line eq
{}} continue
3134 if {![commitinview
$line $curview]} continue
3135 set row
[rowofcommit
$line]
3136 if {[info exists iddrawn
($line)] && ![ishighlighted
$line]} {
3137 bolden
$row mainfontbold
3139 set fhighlights
($line) 1
3141 if {[eof
$filehighlight]} {
3143 puts
"oops, git diff-tree died"
3144 catch
{close
$filehighlight}
3148 if {[info exists find_dirn
]} {
3154 proc doesmatch
{f
} {
3155 global findtype findpattern
3157 if {$findtype eq
[mc
"Regexp"]} {
3158 return [regexp
$findpattern $f]
3159 } elseif
{$findtype eq
[mc
"IgnCase"]} {
3160 return [string match
-nocase $findpattern $f]
3162 return [string match
$findpattern $f]
3166 proc askfindhighlight
{row id
} {
3167 global nhighlights commitinfo iddrawn
3169 global markingmatches
3171 if {![info exists commitinfo
($id)]} {
3174 set info
$commitinfo($id)
3176 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
3177 foreach f
$info ty
$fldtypes {
3178 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
3180 if {$ty eq
[mc
"Author"]} {
3187 if {$isbold && [info exists iddrawn
($id)]} {
3188 if {![ishighlighted
$id]} {
3189 bolden
$row mainfontbold
3191 bolden_name
$row mainfontbold
3194 if {$markingmatches} {
3195 markrowmatches
$row $id
3198 set nhighlights
($id) $isbold
3201 proc markrowmatches
{row id
} {
3202 global canv canv2 linehtag linentag commitinfo findloc
3204 set headline
[lindex
$commitinfo($id) 0]
3205 set author
[lindex
$commitinfo($id) 1]
3206 $canv delete match
$row
3207 $canv2 delete match
$row
3208 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
3209 set m
[findmatches
$headline]
3211 markmatches
$canv $row $headline $linehtag($row) $m \
3212 [$canv itemcget
$linehtag($row) -font] $row
3215 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
3216 set m
[findmatches
$author]
3218 markmatches
$canv2 $row $author $linentag($row) $m \
3219 [$canv2 itemcget
$linentag($row) -font] $row
3224 proc vrel_change
{name ix op
} {
3225 global highlight_related
3228 if {$highlight_related ne
[mc
"None"]} {
3233 # prepare for testing whether commits are descendents or ancestors of a
3234 proc rhighlight_sel
{a
} {
3235 global descendent desc_todo ancestor anc_todo
3236 global highlight_related
3238 catch
{unset descendent
}
3239 set desc_todo
[list
$a]
3240 catch
{unset ancestor
}
3241 set anc_todo
[list
$a]
3242 if {$highlight_related ne
[mc
"None"]} {
3248 proc rhighlight_none
{} {
3251 catch
{unset rhighlights
}
3255 proc is_descendent
{a
} {
3256 global curview children descendent desc_todo
3259 set la
[rowofcommit
$a]
3263 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3264 set do [lindex
$todo $i]
3265 if {[rowofcommit
$do] < $la} {
3266 lappend leftover
$do
3269 foreach nk
$children($v,$do) {
3270 if {![info exists descendent
($nk)]} {
3271 set descendent
($nk) 1
3279 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3283 set descendent
($a) 0
3284 set desc_todo
$leftover
3287 proc is_ancestor
{a
} {
3288 global curview parents ancestor anc_todo
3291 set la
[rowofcommit
$a]
3295 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3296 set do [lindex
$todo $i]
3297 if {![commitinview
$do $v] ||
[rowofcommit
$do] > $la} {
3298 lappend leftover
$do
3301 foreach np
$parents($v,$do) {
3302 if {![info exists ancestor
($np)]} {
3311 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3316 set anc_todo
$leftover
3319 proc askrelhighlight
{row id
} {
3320 global descendent highlight_related iddrawn rhighlights
3321 global selectedline ancestor
3323 if {![info exists selectedline
]} return
3325 if {$highlight_related eq
[mc
"Descendent"] ||
3326 $highlight_related eq
[mc
"Not descendent"]} {
3327 if {![info exists descendent
($id)]} {
3330 if {$descendent($id) == ($highlight_related eq
[mc
"Descendent"])} {
3333 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
3334 $highlight_related eq
[mc
"Not ancestor"]} {
3335 if {![info exists ancestor
($id)]} {
3338 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
3342 if {[info exists iddrawn
($id)]} {
3343 if {$isbold && ![ishighlighted
$id]} {
3344 bolden
$row mainfontbold
3347 set rhighlights
($id) $isbold
3350 # Graph layout functions
3352 proc shortids
{ids
} {
3355 if {[llength
$id] > 1} {
3356 lappend res
[shortids
$id]
3357 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
3358 lappend res
[string range
$id 0 7]
3369 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
3370 if {($n & $mask) != 0} {
3371 set ret
[concat
$ret $o]
3373 set o
[concat
$o $o]
3378 proc ordertoken
{id
} {
3379 global ordertok curview varcid varcstart varctok curview parents children
3380 global nullid nullid2
3382 if {[info exists ordertok
($id)]} {
3383 return $ordertok($id)
3388 if {[info exists varcid
($curview,$id)]} {
3389 set a
$varcid($curview,$id)
3390 set p
[lindex
$varcstart($curview) $a]
3392 set p
[lindex
$children($curview,$id) 0]
3394 if {[info exists ordertok
($p)]} {
3395 set tok
$ordertok($p)
3398 set id
[first_real_child
$curview,$p]
3401 set tok
[lindex
$varctok($curview) $varcid($curview,$p)]
3404 if {[llength
$parents($curview,$id)] == 1} {
3405 lappend todo
[list
$p {}]
3407 set j
[lsearch
-exact $parents($curview,$id) $p]
3409 puts
"oops didn't find [shortids $p] in parents of [shortids $id]"
3411 lappend todo
[list
$p [strrep
$j]]
3414 for {set i
[llength
$todo]} {[incr i
-1] >= 0} {} {
3415 set p
[lindex
$todo $i 0]
3416 append tok
[lindex
$todo $i 1]
3417 set ordertok
($p) $tok
3419 set ordertok
($origid) $tok
3423 # Work out where id should go in idlist so that order-token
3424 # values increase from left to right
3425 proc idcol
{idlist id
{i
0}} {
3426 set t
[ordertoken
$id]
3430 if {$i >= [llength
$idlist] ||
$t < [ordertoken
[lindex
$idlist $i]]} {
3431 if {$i > [llength
$idlist]} {
3432 set i
[llength
$idlist]
3434 while {[incr i
-1] >= 0 && $t < [ordertoken
[lindex
$idlist $i]]} {}
3437 if {$t > [ordertoken
[lindex
$idlist $i]]} {
3438 while {[incr i
] < [llength
$idlist] &&
3439 $t >= [ordertoken
[lindex
$idlist $i]]} {}
3445 proc initlayout
{} {
3446 global rowidlist rowisopt rowfinal displayorder parentlist
3447 global numcommits canvxmax canv
3449 global colormap rowtextx
3458 set canvxmax
[$canv cget
-width]
3459 catch
{unset colormap
}
3460 catch
{unset rowtextx
}
3463 proc setcanvscroll
{} {
3464 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3466 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3467 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
3468 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
3469 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
3472 proc visiblerows
{} {
3473 global canv numcommits linespc
3475 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3476 if {$ymax eq
{} ||
$ymax == 0} return
3478 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
3479 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
3483 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
3484 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
3485 if {$r1 >= $numcommits} {
3486 set r1
[expr {$numcommits - 1}]
3488 return [list
$r0 $r1]
3491 proc layoutmore
{} {
3492 global commitidx viewcomplete curview
3493 global numcommits pending_select selectedline curview
3494 global lastscrollset commitinterest
3496 set canshow
$commitidx($curview)
3497 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3498 if {$numcommits == 0} {
3502 set prev
$numcommits
3503 set numcommits
$canshow
3504 set t
[clock clicks
-milliseconds]
3505 if {$prev < 100 ||
$viewcomplete($curview) ||
$t - $lastscrollset > 500} {
3506 set lastscrollset
$t
3509 set rows
[visiblerows
]
3510 set r1
[lindex
$rows 1]
3511 if {$r1 >= $canshow} {
3512 set r1
[expr {$canshow - 1}]
3517 if {[info exists pending_select
] &&
3518 [commitinview
$pending_select $curview]} {
3519 selectline
[rowofcommit
$pending_select] 1
3523 proc doshowlocalchanges
{} {
3524 global curview mainheadid
3526 if {[commitinview
$mainheadid $curview]} {
3529 lappend commitinterest
($mainheadid) {dodiffindex
}
3533 proc dohidelocalchanges
{} {
3534 global nullid nullid2 lserial curview
3536 if {[commitinview
$nullid $curview]} {
3537 removerow
$nullid $curview
3539 if {[commitinview
$nullid2 $curview]} {
3540 removerow
$nullid2 $curview
3545 # spawn off a process to do git diff-index --cached HEAD
3546 proc dodiffindex
{} {
3547 global lserial showlocalchanges
3549 if {!$showlocalchanges} return
3551 set fd
[open
"|git diff-index --cached HEAD" r
]
3552 fconfigure
$fd -blocking 0
3553 filerun
$fd [list readdiffindex
$fd $lserial]
3556 proc readdiffindex
{fd serial
} {
3557 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3560 if {[gets
$fd line
] < 0} {
3566 # we only need to see one line and we don't really care what it says...
3569 if {$serial != $lserial} {
3573 # now see if there are any local changes not checked in to the index
3574 set fd
[open
"|git diff-files" r
]
3575 fconfigure
$fd -blocking 0
3576 filerun
$fd [list readdifffiles
$fd $serial]
3578 if {$isdiff && ![commitinview
$nullid2 $curview]} {
3579 # add the line for the changes in the index to the graph
3580 set hl
[mc
"Local changes checked in to index but not committed"]
3581 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
3582 set commitdata
($nullid2) "\n $hl\n"
3583 if {[commitinview
$nullid $curview]} {
3584 removerow
$nullid $curview
3586 insertrow
$nullid2 $mainheadid $curview
3587 } elseif
{!$isdiff && [commitinview
$nullid2 $curview]} {
3588 removerow
$nullid2 $curview
3593 proc readdifffiles
{fd serial
} {
3594 global mainheadid nullid nullid2 curview
3595 global commitinfo commitdata lserial
3598 if {[gets
$fd line
] < 0} {
3604 # we only need to see one line and we don't really care what it says...
3607 if {$serial != $lserial} {
3611 if {$isdiff && ![commitinview
$nullid $curview]} {
3612 # add the line for the local diff to the graph
3613 set hl
[mc
"Local uncommitted changes, not checked in to index"]
3614 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
3615 set commitdata
($nullid) "\n $hl\n"
3616 if {[commitinview
$nullid2 $curview]} {
3621 insertrow
$nullid $p $curview
3622 } elseif
{!$isdiff && [commitinview
$nullid $curview]} {
3623 removerow
$nullid $curview
3628 proc nextuse
{id row
} {
3629 global curview children
3631 if {[info exists children
($curview,$id)]} {
3632 foreach kid
$children($curview,$id) {
3633 if {![commitinview
$kid $curview]} {
3636 if {[rowofcommit
$kid] > $row} {
3637 return [rowofcommit
$kid]
3641 if {[commitinview
$id $curview]} {
3642 return [rowofcommit
$id]
3647 proc prevuse
{id row
} {
3648 global curview children
3651 if {[info exists children
($curview,$id)]} {
3652 foreach kid
$children($curview,$id) {
3653 if {![commitinview
$kid $curview]} break
3654 if {[rowofcommit
$kid] < $row} {
3655 set ret
[rowofcommit
$kid]
3662 proc make_idlist
{row
} {
3663 global displayorder parentlist uparrowlen downarrowlen mingaplen
3664 global commitidx curview children
3666 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
3670 set ra
[expr {$row - $downarrowlen}]
3674 set rb
[expr {$row + $uparrowlen}]
3675 if {$rb > $commitidx($curview)} {
3676 set rb
$commitidx($curview)
3678 make_disporder
$r [expr {$rb + 1}]
3680 for {} {$r < $ra} {incr r
} {
3681 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3682 foreach p
[lindex
$parentlist $r] {
3683 if {$p eq
$nextid} continue
3684 set rn
[nextuse
$p $r]
3686 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3687 lappend ids
[list
[ordertoken
$p] $p]
3691 for {} {$r < $row} {incr r
} {
3692 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3693 foreach p
[lindex
$parentlist $r] {
3694 if {$p eq
$nextid} continue
3695 set rn
[nextuse
$p $r]
3696 if {$rn < 0 ||
$rn >= $row} {
3697 lappend ids
[list
[ordertoken
$p] $p]
3701 set id
[lindex
$displayorder $row]
3702 lappend ids
[list
[ordertoken
$id] $id]
3704 foreach p
[lindex
$parentlist $r] {
3705 set firstkid
[lindex
$children($curview,$p) 0]
3706 if {[rowofcommit
$firstkid] < $row} {
3707 lappend ids
[list
[ordertoken
$p] $p]
3711 set id
[lindex
$displayorder $r]
3713 set firstkid
[lindex
$children($curview,$id) 0]
3714 if {$firstkid ne
{} && [rowofcommit
$firstkid] < $row} {
3715 lappend ids
[list
[ordertoken
$id] $id]
3720 foreach idx
[lsort
-unique $ids] {
3721 lappend idlist
[lindex
$idx 1]
3726 proc rowsequal
{a b
} {
3727 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3728 set a
[lreplace
$a $i $i]
3730 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3731 set b
[lreplace
$b $i $i]
3733 return [expr {$a eq
$b}]
3736 proc makeupline
{id row rend
col} {
3737 global rowidlist uparrowlen downarrowlen mingaplen
3739 for {set r
$rend} {1} {set r
$rstart} {
3740 set rstart
[prevuse
$id $r]
3741 if {$rstart < 0} return
3742 if {$rstart < $row} break
3744 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3745 set rstart
[expr {$rend - $uparrowlen - 1}]
3747 for {set r
$rstart} {[incr r
] <= $row} {} {
3748 set idlist
[lindex
$rowidlist $r]
3749 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3750 set col [idcol
$idlist $id $col]
3751 lset rowidlist
$r [linsert
$idlist $col $id]
3757 proc layoutrows
{row endrow
} {
3758 global rowidlist rowisopt rowfinal displayorder
3759 global uparrowlen downarrowlen maxwidth mingaplen
3760 global children parentlist
3761 global commitidx viewcomplete curview
3763 make_disporder
[expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3766 set rm1
[expr {$row - 1}]
3767 foreach id
[lindex
$rowidlist $rm1] {
3772 set final
[lindex
$rowfinal $rm1]
3774 for {} {$row < $endrow} {incr row
} {
3775 set rm1
[expr {$row - 1}]
3776 if {$rm1 < 0 ||
$idlist eq
{}} {
3777 set idlist
[make_idlist
$row]
3780 set id
[lindex
$displayorder $rm1]
3781 set col [lsearch
-exact $idlist $id]
3782 set idlist
[lreplace
$idlist $col $col]
3783 foreach p
[lindex
$parentlist $rm1] {
3784 if {[lsearch
-exact $idlist $p] < 0} {
3785 set col [idcol
$idlist $p $col]
3786 set idlist
[linsert
$idlist $col $p]
3787 # if not the first child, we have to insert a line going up
3788 if {$id ne
[lindex
$children($curview,$p) 0]} {
3789 makeupline
$p $rm1 $row $col
3793 set id
[lindex
$displayorder $row]
3794 if {$row > $downarrowlen} {
3795 set termrow
[expr {$row - $downarrowlen - 1}]
3796 foreach p
[lindex
$parentlist $termrow] {
3797 set i
[lsearch
-exact $idlist $p]
3798 if {$i < 0} continue
3799 set nr
[nextuse
$p $termrow]
3800 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3801 set idlist
[lreplace
$idlist $i $i]
3805 set col [lsearch
-exact $idlist $id]
3807 set col [idcol
$idlist $id]
3808 set idlist
[linsert
$idlist $col $id]
3809 if {$children($curview,$id) ne
{}} {
3810 makeupline
$id $rm1 $row $col
3813 set r
[expr {$row + $uparrowlen - 1}]
3814 if {$r < $commitidx($curview)} {
3816 foreach p
[lindex
$parentlist $r] {
3817 if {[lsearch
-exact $idlist $p] >= 0} continue
3818 set fk
[lindex
$children($curview,$p) 0]
3819 if {[rowofcommit
$fk] < $row} {
3820 set x
[idcol
$idlist $p $x]
3821 set idlist
[linsert
$idlist $x $p]
3824 if {[incr r
] < $commitidx($curview)} {
3825 set p
[lindex
$displayorder $r]
3826 if {[lsearch
-exact $idlist $p] < 0} {
3827 set fk
[lindex
$children($curview,$p) 0]
3828 if {$fk ne
{} && [rowofcommit
$fk] < $row} {
3829 set x
[idcol
$idlist $p $x]
3830 set idlist
[linsert
$idlist $x $p]
3836 if {$final && !$viewcomplete($curview) &&
3837 $row + $uparrowlen + $mingaplen + $downarrowlen
3838 >= $commitidx($curview)} {
3841 set l
[llength
$rowidlist]
3843 lappend rowidlist
$idlist
3845 lappend rowfinal
$final
3846 } elseif
{$row < $l} {
3847 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3848 lset rowidlist
$row $idlist
3851 lset rowfinal
$row $final
3853 set pad
[ntimes
[expr {$row - $l}] {}]
3854 set rowidlist
[concat
$rowidlist $pad]
3855 lappend rowidlist
$idlist
3856 set rowfinal
[concat
$rowfinal $pad]
3857 lappend rowfinal
$final
3858 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3864 proc changedrow
{row
} {
3865 global displayorder iddrawn rowisopt need_redisplay
3867 set l
[llength
$rowisopt]
3869 lset rowisopt
$row 0
3870 if {$row + 1 < $l} {
3871 lset rowisopt
[expr {$row + 1}] 0
3872 if {$row + 2 < $l} {
3873 lset rowisopt
[expr {$row + 2}] 0
3877 set id
[lindex
$displayorder $row]
3878 if {[info exists iddrawn
($id)]} {
3879 set need_redisplay
1
3883 proc insert_pad
{row
col npad
} {
3886 set pad
[ntimes
$npad {}]
3887 set idlist
[lindex
$rowidlist $row]
3888 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3889 set aft
[lrange
$idlist $col end
]
3890 set i
[lsearch
-exact $aft {}]
3892 set aft
[lreplace
$aft $i $i]
3894 lset rowidlist
$row [concat
$bef $pad $aft]
3898 proc optimize_rows
{row
col endrow
} {
3899 global rowidlist rowisopt displayorder curview children
3904 for {} {$row < $endrow} {incr row
; set col 0} {
3905 if {[lindex
$rowisopt $row]} continue
3907 set y0
[expr {$row - 1}]
3908 set ym
[expr {$row - 2}]
3909 set idlist
[lindex
$rowidlist $row]
3910 set previdlist
[lindex
$rowidlist $y0]
3911 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3913 set pprevidlist
[lindex
$rowidlist $ym]
3914 if {$pprevidlist eq
{}} continue
3920 for {} {$col < [llength
$idlist]} {incr
col} {
3921 set id
[lindex
$idlist $col]
3922 if {[lindex
$previdlist $col] eq
$id} continue
3927 set x0
[lsearch
-exact $previdlist $id]
3928 if {$x0 < 0} continue
3929 set z
[expr {$x0 - $col}]
3933 set xm
[lsearch
-exact $pprevidlist $id]
3935 set z0
[expr {$xm - $x0}]
3939 # if row y0 is the first child of $id then it's not an arrow
3940 if {[lindex
$children($curview,$id) 0] ne
3941 [lindex
$displayorder $y0]} {
3945 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3946 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3949 # Looking at lines from this row to the previous row,
3950 # make them go straight up if they end in an arrow on
3951 # the previous row; otherwise make them go straight up
3953 if {$z < -1 ||
($z < 0 && $isarrow)} {
3954 # Line currently goes left too much;
3955 # insert pads in the previous row, then optimize it
3956 set npad
[expr {-1 - $z + $isarrow}]
3957 insert_pad
$y0 $x0 $npad
3959 optimize_rows
$y0 $x0 $row
3961 set previdlist
[lindex
$rowidlist $y0]
3962 set x0
[lsearch
-exact $previdlist $id]
3963 set z
[expr {$x0 - $col}]
3965 set pprevidlist
[lindex
$rowidlist $ym]
3966 set xm
[lsearch
-exact $pprevidlist $id]
3967 set z0
[expr {$xm - $x0}]
3969 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3970 # Line currently goes right too much;
3971 # insert pads in this line
3972 set npad
[expr {$z - 1 + $isarrow}]
3973 insert_pad
$row $col $npad
3974 set idlist
[lindex
$rowidlist $row]
3976 set z
[expr {$x0 - $col}]
3979 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3980 # this line links to its first child on row $row-2
3981 set id
[lindex
$displayorder $ym]
3982 set xc
[lsearch
-exact $pprevidlist $id]
3984 set z0
[expr {$xc - $x0}]
3987 # avoid lines jigging left then immediately right
3988 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3989 insert_pad
$y0 $x0 1
3991 optimize_rows
$y0 $x0 $row
3992 set previdlist
[lindex
$rowidlist $y0]
3996 # Find the first column that doesn't have a line going right
3997 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
3998 set id
[lindex
$idlist $col]
3999 if {$id eq
{}} break
4000 set x0
[lsearch
-exact $previdlist $id]
4002 # check if this is the link to the first child
4003 set kid
[lindex
$displayorder $y0]
4004 if {[lindex
$children($curview,$id) 0] eq
$kid} {
4005 # it is, work out offset to child
4006 set x0
[lsearch
-exact $previdlist $kid]
4009 if {$x0 <= $col} break
4011 # Insert a pad at that column as long as it has a line and
4012 # isn't the last column
4013 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
4014 set idlist
[linsert
$idlist $col {}]
4015 lset rowidlist
$row $idlist
4023 global canvx0 linespc
4024 return [expr {$canvx0 + $col * $linespc}]
4028 global canvy0 linespc
4029 return [expr {$canvy0 + $row * $linespc}]
4032 proc linewidth
{id
} {
4033 global thickerline lthickness
4036 if {[info exists thickerline
] && $id eq
$thickerline} {
4037 set wid
[expr {2 * $lthickness}]
4042 proc rowranges
{id
} {
4043 global curview children uparrowlen downarrowlen
4046 set kids
$children($curview,$id)
4052 foreach child
$kids {
4053 if {![commitinview
$child $curview]} break
4054 set row
[rowofcommit
$child]
4055 if {![info exists prev
]} {
4056 lappend ret
[expr {$row + 1}]
4058 if {$row <= $prevrow} {
4059 puts
"oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4061 # see if the line extends the whole way from prevrow to row
4062 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4063 [lsearch
-exact [lindex
$rowidlist \
4064 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
4065 # it doesn't, see where it ends
4066 set r
[expr {$prevrow + $downarrowlen}]
4067 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4068 while {[incr r
-1] > $prevrow &&
4069 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4071 while {[incr r
] <= $row &&
4072 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4076 # see where it starts up again
4077 set r
[expr {$row - $uparrowlen}]
4078 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4079 while {[incr r
] < $row &&
4080 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4082 while {[incr r
-1] >= $prevrow &&
4083 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4089 if {$child eq
$id} {
4098 proc drawlineseg
{id row endrow arrowlow
} {
4099 global rowidlist displayorder iddrawn linesegs
4100 global canv colormap linespc curview maxlinelen parentlist
4102 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
4103 set le
[expr {$row + 1}]
4106 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
4112 set x
[lindex
$displayorder $le]
4117 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
4118 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
4134 if {[info exists linesegs
($id)]} {
4135 set lines
$linesegs($id)
4137 set r0
[lindex
$li 0]
4139 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
4149 set li
[lindex
$lines [expr {$i-1}]]
4150 set r1
[lindex
$li 1]
4151 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
4156 set x
[lindex
$cols [expr {$le - $row}]]
4157 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
4158 set dir
[expr {$xp - $x}]
4160 set ith
[lindex
$lines $i 2]
4161 set coords
[$canv coords
$ith]
4162 set ah
[$canv itemcget
$ith -arrow]
4163 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
4164 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
4165 if {$x2 ne
{} && $x - $x2 == $dir} {
4166 set coords
[lrange
$coords 0 end-2
]
4169 set coords
[list
[xc
$le $x] [yc
$le]]
4172 set itl
[lindex
$lines [expr {$i-1}] 2]
4173 set al
[$canv itemcget
$itl -arrow]
4174 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
4175 } elseif
{$arrowlow} {
4176 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
4177 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
4181 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
4182 for {set y
$le} {[incr y
-1] > $row} {} {
4184 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
4185 set ndir
[expr {$xp - $x}]
4186 if {$dir != $ndir ||
$xp < 0} {
4187 lappend coords
[xc
$y $x] [yc
$y]
4193 # join parent line to first child
4194 set ch
[lindex
$displayorder $row]
4195 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
4197 puts
"oops: drawlineseg: child $ch not on row $row"
4198 } elseif
{$xc != $x} {
4199 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
4200 set d
[expr {int
(0.5 * $linespc)}]
4203 set x2
[expr {$x1 - $d}]
4205 set x2
[expr {$x1 + $d}]
4208 set y1
[expr {$y2 + $d}]
4209 lappend coords
$x1 $y1 $x2 $y2
4210 } elseif
{$xc < $x - 1} {
4211 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
4212 } elseif
{$xc > $x + 1} {
4213 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
4217 lappend coords
[xc
$row $x] [yc
$row]
4219 set xn
[xc
$row $xp]
4221 lappend coords
$xn $yn
4225 set t
[$canv create line
$coords -width [linewidth
$id] \
4226 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
4229 set lines
[linsert
$lines $i [list
$row $le $t]]
4231 $canv coords
$ith $coords
4232 if {$arrow ne
$ah} {
4233 $canv itemconf
$ith -arrow $arrow
4235 lset lines
$i 0 $row
4238 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
4239 set ndir
[expr {$xo - $xp}]
4240 set clow
[$canv coords
$itl]
4241 if {$dir == $ndir} {
4242 set clow
[lrange
$clow 2 end
]
4244 set coords
[concat
$coords $clow]
4246 lset lines
[expr {$i-1}] 1 $le
4248 # coalesce two pieces
4250 set b
[lindex
$lines [expr {$i-1}] 0]
4251 set e
[lindex
$lines $i 1]
4252 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
4254 $canv coords
$itl $coords
4255 if {$arrow ne
$al} {
4256 $canv itemconf
$itl -arrow $arrow
4260 set linesegs
($id) $lines
4264 proc drawparentlinks
{id row
} {
4265 global rowidlist canv colormap curview parentlist
4266 global idpos linespc
4268 set rowids
[lindex
$rowidlist $row]
4269 set col [lsearch
-exact $rowids $id]
4270 if {$col < 0} return
4271 set olds
[lindex
$parentlist $row]
4272 set row2
[expr {$row + 1}]
4273 set x
[xc
$row $col]
4276 set d
[expr {int
(0.5 * $linespc)}]
4277 set ymid
[expr {$y + $d}]
4278 set ids
[lindex
$rowidlist $row2]
4279 # rmx = right-most X coord used
4282 set i
[lsearch
-exact $ids $p]
4284 puts
"oops, parent $p of $id not in list"
4287 set x2
[xc
$row2 $i]
4291 set j
[lsearch
-exact $rowids $p]
4293 # drawlineseg will do this one for us
4297 # should handle duplicated parents here...
4298 set coords
[list
$x $y]
4300 # if attaching to a vertical segment, draw a smaller
4301 # slant for visual distinctness
4304 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
4306 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
4308 } elseif
{$i < $col && $i < $j} {
4309 # segment slants towards us already
4310 lappend coords
[xc
$row $j] $y
4312 if {$i < $col - 1} {
4313 lappend coords
[expr {$x2 + $linespc}] $y
4314 } elseif
{$i > $col + 1} {
4315 lappend coords
[expr {$x2 - $linespc}] $y
4317 lappend coords
$x2 $y2
4320 lappend coords
$x2 $y2
4322 set t
[$canv create line
$coords -width [linewidth
$p] \
4323 -fill $colormap($p) -tags lines.
$p]
4327 if {$rmx > [lindex
$idpos($id) 1]} {
4328 lset idpos
($id) 1 $rmx
4333 proc drawlines
{id
} {
4336 $canv itemconf lines.
$id -width [linewidth
$id]
4339 proc drawcmittext
{id row
col} {
4340 global linespc canv canv2 canv3 fgcolor curview
4341 global cmitlisted commitinfo rowidlist parentlist
4342 global rowtextx idpos idtags idheads idotherrefs
4343 global linehtag linentag linedtag selectedline
4344 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4346 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4347 set listed
$cmitlisted($curview,$id)
4348 if {$id eq
$nullid} {
4350 } elseif
{$id eq
$nullid2} {
4353 set ofill
[expr {$listed != 0?
"blue": "white"}]
4355 set x
[xc
$row $col]
4357 set orad
[expr {$linespc / 3}]
4359 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
4360 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4361 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4362 } elseif
{$listed == 2} {
4363 # triangle pointing left for left-side commits
4364 set t
[$canv create polygon \
4365 [expr {$x - $orad}] $y \
4366 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4367 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4368 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4370 # triangle pointing right for right-side commits
4371 set t
[$canv create polygon \
4372 [expr {$x + $orad - 1}] $y \
4373 [expr {$x - $orad}] [expr {$y - $orad}] \
4374 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4375 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4378 $canv bind $t <1> {selcanvline
{} %x
%y
}
4379 set rmx
[llength
[lindex
$rowidlist $row]]
4380 set olds
[lindex
$parentlist $row]
4382 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
4384 set i
[lsearch
-exact $nextids $p]
4390 set xt
[xc
$row $rmx]
4391 set rowtextx
($row) $xt
4392 set idpos
($id) [list
$x $xt $y]
4393 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
4394 ||
[info exists idotherrefs
($id)]} {
4395 set xt
[drawtags
$id $x $xt $y]
4397 set headline
[lindex
$commitinfo($id) 0]
4398 set name
[lindex
$commitinfo($id) 1]
4399 set date [lindex
$commitinfo($id) 2]
4400 set date [formatdate
$date]
4403 set isbold
[ishighlighted
$id]
4405 lappend boldrows
$row
4406 set font mainfontbold
4408 lappend boldnamerows
$row
4409 set nfont mainfontbold
4412 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
4413 -text $headline -font $font -tags text
]
4414 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
4415 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
4416 -text $name -font $nfont -tags text
]
4417 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
4418 -text $date -font mainfont
-tags text
]
4419 if {[info exists selectedline
] && $selectedline == $row} {
4422 set xr
[expr {$xt + [font measure
$font $headline]}]
4423 if {$xr > $canvxmax} {
4429 proc drawcmitrow
{row
} {
4430 global displayorder rowidlist nrows_drawn
4431 global iddrawn markingmatches
4432 global commitinfo numcommits
4433 global filehighlight fhighlights findpattern nhighlights
4434 global hlview vhighlights
4435 global highlight_related rhighlights
4437 if {$row >= $numcommits} return
4439 set id
[lindex
$displayorder $row]
4440 if {[info exists hlview
] && ![info exists vhighlights
($id)]} {
4441 askvhighlight
$row $id
4443 if {[info exists filehighlight
] && ![info exists fhighlights
($id)]} {
4444 askfilehighlight
$row $id
4446 if {$findpattern ne
{} && ![info exists nhighlights
($id)]} {
4447 askfindhighlight
$row $id
4449 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($id)]} {
4450 askrelhighlight
$row $id
4452 if {![info exists iddrawn
($id)]} {
4453 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
4455 puts
"oops, row $row id $id not in list"
4458 if {![info exists commitinfo
($id)]} {
4462 drawcmittext
$id $row $col
4466 if {$markingmatches} {
4467 markrowmatches
$row $id
4471 proc drawcommits
{row
{endrow
{}}} {
4472 global numcommits iddrawn displayorder curview need_redisplay
4473 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4478 if {$endrow eq
{}} {
4481 if {$endrow >= $numcommits} {
4482 set endrow
[expr {$numcommits - 1}]
4485 set rl1
[expr {$row - $downarrowlen - 3}]
4489 set ro1
[expr {$row - 3}]
4493 set r2
[expr {$endrow + $uparrowlen + 3}]
4494 if {$r2 > $numcommits} {
4497 for {set r
$rl1} {$r < $r2} {incr r
} {
4498 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
4502 set rl1
[expr {$r + 1}]
4508 optimize_rows
$ro1 0 $r2
4509 if {$need_redisplay ||
$nrows_drawn > 2000} {
4514 # make the lines join to already-drawn rows either side
4515 set r
[expr {$row - 1}]
4516 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
4519 set er
[expr {$endrow + 1}]
4520 if {$er >= $numcommits ||
4521 ![info exists iddrawn
([lindex
$displayorder $er])]} {
4524 for {} {$r <= $er} {incr r
} {
4525 set id
[lindex
$displayorder $r]
4526 set wasdrawn
[info exists iddrawn
($id)]
4528 if {$r == $er} break
4529 set nextid
[lindex
$displayorder [expr {$r + 1}]]
4530 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
4531 drawparentlinks
$id $r
4533 set rowids
[lindex
$rowidlist $r]
4534 foreach lid
$rowids {
4535 if {$lid eq
{}} continue
4536 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
4538 # see if this is the first child of any of its parents
4539 foreach p
[lindex
$parentlist $r] {
4540 if {[lsearch
-exact $rowids $p] < 0} {
4541 # make this line extend up to the child
4542 set lineend
($p) [drawlineseg
$p $r $er 0]
4546 set lineend
($lid) [drawlineseg
$lid $r $er 1]
4552 proc undolayout
{row
} {
4553 global uparrowlen mingaplen downarrowlen
4554 global rowidlist rowisopt rowfinal need_redisplay
4556 set r
[expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4560 if {[llength
$rowidlist] > $r} {
4562 set rowidlist
[lrange
$rowidlist 0 $r]
4563 set rowfinal
[lrange
$rowfinal 0 $r]
4564 set rowisopt
[lrange
$rowisopt 0 $r]
4565 set need_redisplay
1
4570 proc drawvisible
{} {
4571 global canv linespc curview vrowmod selectedline targetrow targetid
4572 global need_redisplay cscroll numcommits
4574 set fs
[$canv yview
]
4575 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4576 if {$ymax eq
{} ||
$ymax == 0} return
4577 set f0
[lindex
$fs 0]
4578 set f1
[lindex
$fs 1]
4579 set y0
[expr {int
($f0 * $ymax)}]
4580 set y1
[expr {int
($f1 * $ymax)}]
4582 if {[info exists targetid
]} {
4583 if {[commitinview
$targetid $curview]} {
4584 set r
[rowofcommit
$targetid]
4585 if {$r != $targetrow} {
4586 # Fix up the scrollregion and change the scrolling position
4587 # now that our target row has moved.
4588 set diff [expr {($r - $targetrow) * $linespc}]
4591 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4594 set f0
[expr {$y0 / $ymax}]
4595 set f1
[expr {$y1 / $ymax}]
4596 allcanvs yview moveto
$f0
4597 $cscroll set $f0 $f1
4598 set need_redisplay
1
4605 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
4606 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
4607 if {$endrow >= $vrowmod($curview)} {
4608 update_arcrows
$curview
4610 if {[info exists selectedline
] &&
4611 $row <= $selectedline && $selectedline <= $endrow} {
4612 set targetrow
$selectedline
4614 set targetrow
[expr {int
(($row + $endrow) / 2)}]
4616 if {$targetrow >= $numcommits} {
4617 set targetrow
[expr {$numcommits - 1}]
4619 set targetid
[commitonrow
$targetrow]
4620 drawcommits
$row $endrow
4623 proc clear_display
{} {
4624 global iddrawn linesegs need_redisplay nrows_drawn
4625 global vhighlights fhighlights nhighlights rhighlights
4628 catch
{unset iddrawn
}
4629 catch
{unset linesegs
}
4630 catch
{unset vhighlights
}
4631 catch
{unset fhighlights
}
4632 catch
{unset nhighlights
}
4633 catch
{unset rhighlights
}
4634 set need_redisplay
0
4638 proc findcrossings
{id
} {
4639 global rowidlist parentlist numcommits displayorder
4643 foreach
{s e
} [rowranges
$id] {
4644 if {$e >= $numcommits} {
4645 set e
[expr {$numcommits - 1}]
4647 if {$e <= $s} continue
4648 for {set row
$e} {[incr row
-1] >= $s} {} {
4649 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
4651 set olds
[lindex
$parentlist $row]
4652 set kid
[lindex
$displayorder $row]
4653 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
4654 if {$kidx < 0} continue
4655 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
4657 set px
[lsearch
-exact $nextrow $p]
4658 if {$px < 0} continue
4659 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
4660 if {[lsearch
-exact $ccross $p] >= 0} continue
4661 if {$x == $px + ($kidx < $px?
-1: 1)} {
4663 } elseif
{[lsearch
-exact $cross $p] < 0} {
4670 return [concat
$ccross {{}} $cross]
4673 proc assigncolor
{id
} {
4674 global colormap colors nextcolor
4675 global parents children children curview
4677 if {[info exists colormap
($id)]} return
4678 set ncolors
[llength
$colors]
4679 if {[info exists children
($curview,$id)]} {
4680 set kids
$children($curview,$id)
4684 if {[llength
$kids] == 1} {
4685 set child
[lindex
$kids 0]
4686 if {[info exists colormap
($child)]
4687 && [llength
$parents($curview,$child)] == 1} {
4688 set colormap
($id) $colormap($child)
4694 foreach x
[findcrossings
$id] {
4696 # delimiter between corner crossings and other crossings
4697 if {[llength
$badcolors] >= $ncolors - 1} break
4698 set origbad
$badcolors
4700 if {[info exists colormap
($x)]
4701 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
4702 lappend badcolors
$colormap($x)
4705 if {[llength
$badcolors] >= $ncolors} {
4706 set badcolors
$origbad
4708 set origbad
$badcolors
4709 if {[llength
$badcolors] < $ncolors - 1} {
4710 foreach child
$kids {
4711 if {[info exists colormap
($child)]
4712 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
4713 lappend badcolors
$colormap($child)
4715 foreach p
$parents($curview,$child) {
4716 if {[info exists colormap
($p)]
4717 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
4718 lappend badcolors
$colormap($p)
4722 if {[llength
$badcolors] >= $ncolors} {
4723 set badcolors
$origbad
4726 for {set i
0} {$i <= $ncolors} {incr i
} {
4727 set c
[lindex
$colors $nextcolor]
4728 if {[incr nextcolor
] >= $ncolors} {
4731 if {[lsearch
-exact $badcolors $c]} break
4733 set colormap
($id) $c
4736 proc bindline
{t id
} {
4739 $canv bind $t <Enter
> "lineenter %x %y $id"
4740 $canv bind $t <Motion
> "linemotion %x %y $id"
4741 $canv bind $t <Leave
> "lineleave $id"
4742 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4745 proc drawtags
{id x xt y1
} {
4746 global idtags idheads idotherrefs mainhead
4747 global linespc lthickness
4748 global canv rowtextx curview fgcolor bgcolor
4753 if {[info exists idtags
($id)]} {
4754 set marks
$idtags($id)
4755 set ntags
[llength
$marks]
4757 if {[info exists idheads
($id)]} {
4758 set marks
[concat
$marks $idheads($id)]
4759 set nheads
[llength
$idheads($id)]
4761 if {[info exists idotherrefs
($id)]} {
4762 set marks
[concat
$marks $idotherrefs($id)]
4768 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4769 set yt
[expr {$y1 - 0.5 * $linespc}]
4770 set yb
[expr {$yt + $linespc - 1}]
4774 foreach tag
$marks {
4776 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4777 set wid
[font measure mainfontbold
$tag]
4779 set wid
[font measure mainfont
$tag]
4783 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4785 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4786 -width $lthickness -fill black
-tags tag.
$id]
4788 foreach tag
$marks x
$xvals wid
$wvals {
4789 set xl
[expr {$x + $delta}]
4790 set xr
[expr {$x + $delta + $wid + $lthickness}]
4792 if {[incr ntags
-1] >= 0} {
4794 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4795 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4796 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4797 $canv bind $t <1> [list showtag
$tag 1]
4798 set rowtextx
([rowofcommit
$id]) [expr {$xr + $linespc}]
4800 # draw a head or other ref
4801 if {[incr nheads
-1] >= 0} {
4803 if {$tag eq
$mainhead} {
4804 set font mainfontbold
4809 set xl
[expr {$xl - $delta/2}]
4810 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4811 -width 1 -outline black
-fill $col -tags tag.
$id
4812 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4813 set rwid
[font measure mainfont
$remoteprefix]
4814 set xi
[expr {$x + 1}]
4815 set yti
[expr {$yt + 1}]
4816 set xri
[expr {$x + $rwid}]
4817 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4818 -width 0 -fill "#ffddaa" -tags tag.
$id
4821 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4822 -font $font -tags [list tag.
$id text
]]
4824 $canv bind $t <1> [list showtag
$tag 1]
4825 } elseif
{$nheads >= 0} {
4826 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4832 proc xcoord
{i level
ln} {
4833 global canvx0 xspc1 xspc2
4835 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4836 if {$i > 0 && $i == $level} {
4837 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4838 } elseif
{$i > $level} {
4839 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4844 proc show_status
{msg
} {
4848 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4849 -tags text
-fill $fgcolor
4852 # Don't change the text pane cursor if it is currently the hand cursor,
4853 # showing that we are over a sha1 ID link.
4854 proc settextcursor
{c
} {
4855 global ctext curtextcursor
4857 if {[$ctext cget
-cursor] == $curtextcursor} {
4858 $ctext config
-cursor $c
4860 set curtextcursor
$c
4863 proc nowbusy
{what
{name
{}}} {
4864 global isbusy busyname statusw
4866 if {[array names isbusy
] eq
{}} {
4867 . config
-cursor watch
4871 set busyname
($what) $name
4873 $statusw conf
-text $name
4877 proc notbusy
{what
} {
4878 global isbusy maincursor textcursor busyname statusw
4882 if {$busyname($what) ne
{} &&
4883 [$statusw cget
-text] eq
$busyname($what)} {
4884 $statusw conf
-text {}
4887 if {[array names isbusy
] eq
{}} {
4888 . config
-cursor $maincursor
4889 settextcursor
$textcursor
4893 proc findmatches
{f
} {
4894 global findtype findstring
4895 if {$findtype == [mc
"Regexp"]} {
4896 set matches
[regexp
-indices -all -inline $findstring $f]
4899 if {$findtype == [mc
"IgnCase"]} {
4900 set f
[string tolower
$f]
4901 set fs
[string tolower
$fs]
4905 set l
[string length
$fs]
4906 while {[set j
[string first
$fs $f $i]] >= 0} {
4907 lappend matches
[list
$j [expr {$j+$l-1}]]
4908 set i
[expr {$j + $l}]
4914 proc dofind
{{dirn
1} {wrap
1}} {
4915 global findstring findstartline findcurline selectedline numcommits
4916 global gdttype filehighlight fh_serial find_dirn findallowwrap
4918 if {[info exists find_dirn
]} {
4919 if {$find_dirn == $dirn} return
4923 if {$findstring eq
{} ||
$numcommits == 0} return
4924 if {![info exists selectedline
]} {
4925 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4927 set findstartline
$selectedline
4929 set findcurline
$findstartline
4930 nowbusy finding
[mc
"Searching"]
4931 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4932 after cancel do_file_hl
$fh_serial
4933 do_file_hl
$fh_serial
4936 set findallowwrap
$wrap
4940 proc stopfinding
{} {
4941 global find_dirn findcurline fprogcoord
4943 if {[info exists find_dirn
]} {
4953 global commitdata commitinfo numcommits findpattern findloc
4954 global findstartline findcurline findallowwrap
4955 global find_dirn gdttype fhighlights fprogcoord
4956 global curview varcorder vrownum varccommits vrowmod
4958 if {![info exists find_dirn
]} {
4961 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4964 if {$find_dirn > 0} {
4966 if {$l >= $numcommits} {
4969 if {$l <= $findstartline} {
4970 set lim
[expr {$findstartline + 1}]
4973 set moretodo
$findallowwrap
4980 if {$l >= $findstartline} {
4981 set lim
[expr {$findstartline - 1}]
4984 set moretodo
$findallowwrap
4987 set n
[expr {($lim - $l) * $find_dirn}]
4992 if {$l + ($find_dirn > 0?
$n: 1) > $vrowmod($curview)} {
4993 update_arcrows
$curview
4997 set ai
[bsearch
$vrownum($curview) $l]
4998 set a
[lindex
$varcorder($curview) $ai]
4999 set arow
[lindex
$vrownum($curview) $ai]
5000 set ids
[lindex
$varccommits($curview,$a)]
5001 set arowend
[expr {$arow + [llength
$ids]}]
5002 if {$gdttype eq
[mc
"containing:"]} {
5003 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5004 if {$l < $arow ||
$l >= $arowend} {
5006 set a
[lindex
$varcorder($curview) $ai]
5007 set arow
[lindex
$vrownum($curview) $ai]
5008 set ids
[lindex
$varccommits($curview,$a)]
5009 set arowend
[expr {$arow + [llength
$ids]}]
5011 set id
[lindex
$ids [expr {$l - $arow}]]
5012 # shouldn't happen unless git log doesn't give all the commits...
5013 if {![info exists commitdata
($id)] ||
5014 ![doesmatch
$commitdata($id)]} {
5017 if {![info exists commitinfo
($id)]} {
5020 set info
$commitinfo($id)
5021 foreach f
$info ty
$fldtypes {
5022 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
5031 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5032 if {$l < $arow ||
$l >= $arowend} {
5034 set a
[lindex
$varcorder($curview) $ai]
5035 set arow
[lindex
$vrownum($curview) $ai]
5036 set ids
[lindex
$varccommits($curview,$a)]
5037 set arowend
[expr {$arow + [llength
$ids]}]
5039 set id
[lindex
$ids [expr {$l - $arow}]]
5040 if {![info exists fhighlights
($id)]} {
5041 # this sets fhighlights($id) to -1
5042 askfilehighlight
$l $id
5044 if {$fhighlights($id) > 0} {
5048 if {$fhighlights($id) < 0} {
5051 set findcurline
[expr {$l - $find_dirn}]
5056 if {$found ||
($domore && !$moretodo)} {
5072 set findcurline
[expr {$l - $find_dirn}]
5074 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
5078 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
5083 proc findselectline
{l
} {
5084 global findloc commentend ctext findcurline markingmatches gdttype
5086 set markingmatches
1
5089 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
5090 # highlight the matches in the comments
5091 set f
[$ctext get
1.0 $commentend]
5092 set matches
[findmatches
$f]
5093 foreach match
$matches {
5094 set start
[lindex
$match 0]
5095 set end
[expr {[lindex
$match 1] + 1}]
5096 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
5102 # mark the bits of a headline or author that match a find string
5103 proc markmatches
{canv l str tag matches font row
} {
5106 set bbox
[$canv bbox
$tag]
5107 set x0
[lindex
$bbox 0]
5108 set y0
[lindex
$bbox 1]
5109 set y1
[lindex
$bbox 3]
5110 foreach match
$matches {
5111 set start
[lindex
$match 0]
5112 set end
[lindex
$match 1]
5113 if {$start > $end} continue
5114 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
5115 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
5116 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
5117 [expr {$x0+$xlen+2}] $y1 \
5118 -outline {} -tags [list match
$l matches
] -fill yellow
]
5120 if {[info exists selectedline
] && $row == $selectedline} {
5121 $canv raise
$t secsel
5126 proc unmarkmatches
{} {
5127 global markingmatches
5129 allcanvs delete matches
5130 set markingmatches
0
5134 proc selcanvline
{w x y
} {
5135 global canv canvy0 ctext linespc
5137 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5138 if {$ymax == {}} return
5139 set yfrac
[lindex
[$canv yview
] 0]
5140 set y
[expr {$y + $yfrac * $ymax}]
5141 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
5146 set xmax
[lindex
[$canv cget
-scrollregion] 2]
5147 set xleft
[expr {[lindex
[$canv xview
] 0] * $xmax}]
5148 if {![info exists rowtextx
($l)] ||
$xleft + $x < $rowtextx($l)} return
5154 proc commit_descriptor
{p
} {
5156 if {![info exists commitinfo
($p)]} {
5160 if {[llength
$commitinfo($p)] > 1} {
5161 set l
[lindex
$commitinfo($p) 0]
5166 # append some text to the ctext widget, and make any SHA1 ID
5167 # that we know about be a clickable link.
5168 proc appendwithlinks
{text tags
} {
5169 global ctext linknum curview pendinglinks
5171 set start
[$ctext index
"end - 1c"]
5172 $ctext insert end
$text $tags
5173 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
5177 set linkid
[string range
$text $s $e]
5179 $ctext tag delete link
$linknum
5180 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
5181 setlink
$linkid link
$linknum
5186 proc setlink
{id lk
} {
5187 global curview ctext pendinglinks commitinterest
5189 if {[commitinview
$id $curview]} {
5190 $ctext tag conf
$lk -foreground blue
-underline 1
5191 $ctext tag
bind $lk <1> [list selectline
[rowofcommit
$id] 1]
5192 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
5193 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
5195 lappend pendinglinks
($id) $lk
5196 lappend commitinterest
($id) {makelink
%I
}
5200 proc makelink
{id
} {
5203 if {![info exists pendinglinks
($id)]} return
5204 foreach lk
$pendinglinks($id) {
5207 unset pendinglinks
($id)
5210 proc linkcursor
{w inc
} {
5211 global linkentercount curtextcursor
5213 if {[incr linkentercount
$inc] > 0} {
5214 $w configure
-cursor hand2
5216 $w configure
-cursor $curtextcursor
5217 if {$linkentercount < 0} {
5218 set linkentercount
0
5223 proc viewnextline
{dir
} {
5227 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5228 set wnow
[$canv yview
]
5229 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5230 set newtop
[expr {$wtop + $dir * $linespc}]
5233 } elseif
{$newtop > $ymax} {
5236 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5239 # add a list of tag or branch names at position pos
5240 # returns the number of names inserted
5241 proc appendrefs
{pos ids var
} {
5242 global ctext linknum curview
$var maxrefs
5244 if {[catch
{$ctext index
$pos}]} {
5247 $ctext conf
-state normal
5248 $ctext delete
$pos "$pos lineend"
5251 foreach tag
[set $var\
($id\
)] {
5252 lappend tags
[list
$tag $id]
5255 if {[llength
$tags] > $maxrefs} {
5256 $ctext insert
$pos "many ([llength $tags])"
5258 set tags
[lsort
-index 0 -decreasing $tags]
5261 set id
[lindex
$ti 1]
5264 $ctext tag delete
$lk
5265 $ctext insert
$pos $sep
5266 $ctext insert
$pos [lindex
$ti 0] $lk
5271 $ctext conf
-state disabled
5272 return [llength
$tags]
5275 # called when we have finished computing the nearby tags
5276 proc dispneartags
{delay
} {
5277 global selectedline currentid showneartags tagphase
5279 if {![info exists selectedline
] ||
!$showneartags} return
5280 after cancel dispnexttag
5282 after
200 dispnexttag
5285 after idle dispnexttag
5290 proc dispnexttag
{} {
5291 global selectedline currentid showneartags tagphase ctext
5293 if {![info exists selectedline
] ||
!$showneartags} return
5294 switch
-- $tagphase {
5296 set dtags
[desctags
$currentid]
5298 appendrefs precedes
$dtags idtags
5302 set atags
[anctags
$currentid]
5304 appendrefs follows
$atags idtags
5308 set dheads
[descheads
$currentid]
5309 if {$dheads ne
{}} {
5310 if {[appendrefs branch
$dheads idheads
] > 1
5311 && [$ctext get
"branch -3c"] eq
"h"} {
5312 # turn "Branch" into "Branches"
5313 $ctext conf
-state normal
5314 $ctext insert
"branch -2c" "es"
5315 $ctext conf
-state disabled
5320 if {[incr tagphase
] <= 2} {
5321 after idle dispnexttag
5325 proc make_secsel
{l
} {
5326 global linehtag linentag linedtag canv canv2 canv3
5328 if {![info exists linehtag
($l)]} return
5330 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
5331 -tags secsel
-fill [$canv cget
-selectbackground]]
5333 $canv2 delete secsel
5334 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
5335 -tags secsel
-fill [$canv2 cget
-selectbackground]]
5337 $canv3 delete secsel
5338 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
5339 -tags secsel
-fill [$canv3 cget
-selectbackground]]
5343 proc selectline
{l isnew
} {
5344 global canv ctext commitinfo selectedline
5345 global canvy0 linespc parents children curview
5346 global currentid sha1entry
5347 global commentend idtags linknum
5348 global mergemax numcommits pending_select
5349 global cmitmode showneartags allcommits
5351 catch
{unset pending_select
}
5356 if {$l < 0 ||
$l >= $numcommits} return
5357 set y
[expr {$canvy0 + $l * $linespc}]
5358 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5359 set ytop
[expr {$y - $linespc - 1}]
5360 set ybot
[expr {$y + $linespc + 1}]
5361 set wnow
[$canv yview
]
5362 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5363 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
5364 set wh
[expr {$wbot - $wtop}]
5366 if {$ytop < $wtop} {
5367 if {$ybot < $wtop} {
5368 set newtop
[expr {$y - $wh / 2.0}]
5371 if {$newtop > $wtop - $linespc} {
5372 set newtop
[expr {$wtop - $linespc}]
5375 } elseif
{$ybot > $wbot} {
5376 if {$ytop > $wbot} {
5377 set newtop
[expr {$y - $wh / 2.0}]
5379 set newtop
[expr {$ybot - $wh}]
5380 if {$newtop < $wtop + $linespc} {
5381 set newtop
[expr {$wtop + $linespc}]
5385 if {$newtop != $wtop} {
5389 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5395 set id
[commitonrow
$l]
5397 addtohistory
[list selbyid
$id]
5402 $sha1entry delete
0 end
5403 $sha1entry insert
0 $id
5404 $sha1entry selection from
0
5405 $sha1entry selection to end
5408 $ctext conf
-state normal
5411 set info
$commitinfo($id)
5412 set date [formatdate
[lindex
$info 2]]
5413 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
5414 set date [formatdate
[lindex
$info 4]]
5415 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
5416 if {[info exists idtags
($id)]} {
5417 $ctext insert end
[mc
"Tags:"]
5418 foreach tag
$idtags($id) {
5419 $ctext insert end
" $tag"
5421 $ctext insert end
"\n"
5425 set olds
$parents($curview,$id)
5426 if {[llength
$olds] > 1} {
5429 if {$np >= $mergemax} {
5434 $ctext insert end
"[mc "Parent
"]: " $tag
5435 appendwithlinks
[commit_descriptor
$p] {}
5440 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
5444 foreach c
$children($curview,$id) {
5445 append headers
"[mc "Child
"]: [commit_descriptor $c]"
5448 # make anything that looks like a SHA1 ID be a clickable link
5449 appendwithlinks
$headers {}
5450 if {$showneartags} {
5451 if {![info exists allcommits
]} {
5454 $ctext insert end
"[mc "Branch
"]: "
5455 $ctext mark
set branch
"end -1c"
5456 $ctext mark gravity branch left
5457 $ctext insert end
"\n[mc "Follows
"]: "
5458 $ctext mark
set follows
"end -1c"
5459 $ctext mark gravity follows left
5460 $ctext insert end
"\n[mc "Precedes
"]: "
5461 $ctext mark
set precedes
"end -1c"
5462 $ctext mark gravity precedes left
5463 $ctext insert end
"\n"
5466 $ctext insert end
"\n"
5467 set comment
[lindex
$info 5]
5468 if {[string first
"\r" $comment] >= 0} {
5469 set comment
[string map
{"\r" "\n "} $comment]
5471 appendwithlinks
$comment {comment
}
5473 $ctext tag remove found
1.0 end
5474 $ctext conf
-state disabled
5475 set commentend
[$ctext index
"end - 1c"]
5477 init_flist
[mc
"Comments"]
5478 if {$cmitmode eq
"tree"} {
5480 } elseif
{[llength
$olds] <= 1} {
5487 proc selfirstline
{} {
5492 proc sellastline
{} {
5495 set l
[expr {$numcommits - 1}]
5499 proc selnextline
{dir
} {
5502 if {![info exists selectedline
]} return
5503 set l
[expr {$selectedline + $dir}]
5508 proc selnextpage
{dir
} {
5509 global canv linespc selectedline numcommits
5511 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
5515 allcanvs yview scroll
[expr {$dir * $lpp}] units
5517 if {![info exists selectedline
]} return
5518 set l
[expr {$selectedline + $dir * $lpp}]
5521 } elseif
{$l >= $numcommits} {
5522 set l
[expr $numcommits - 1]
5528 proc unselectline
{} {
5529 global selectedline currentid
5531 catch
{unset selectedline
}
5532 catch
{unset currentid
}
5533 allcanvs delete secsel
5537 proc reselectline
{} {
5540 if {[info exists selectedline
]} {
5541 selectline
$selectedline 0
5545 proc addtohistory
{cmd
} {
5546 global
history historyindex curview
5548 set elt
[list
$curview $cmd]
5549 if {$historyindex > 0
5550 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
5554 if {$historyindex < [llength
$history]} {
5555 set history [lreplace
$history $historyindex end
$elt]
5557 lappend
history $elt
5560 if {$historyindex > 1} {
5561 .tf.bar.leftbut conf
-state normal
5563 .tf.bar.leftbut conf
-state disabled
5565 .tf.bar.rightbut conf
-state disabled
5571 set view
[lindex
$elt 0]
5572 set cmd
[lindex
$elt 1]
5573 if {$curview != $view} {
5580 global
history historyindex
5583 if {$historyindex > 1} {
5584 incr historyindex
-1
5585 godo
[lindex
$history [expr {$historyindex - 1}]]
5586 .tf.bar.rightbut conf
-state normal
5588 if {$historyindex <= 1} {
5589 .tf.bar.leftbut conf
-state disabled
5594 global
history historyindex
5597 if {$historyindex < [llength
$history]} {
5598 set cmd
[lindex
$history $historyindex]
5601 .tf.bar.leftbut conf
-state normal
5603 if {$historyindex >= [llength
$history]} {
5604 .tf.bar.rightbut conf
-state disabled
5609 global treefilelist treeidlist diffids diffmergeid treepending
5610 global nullid nullid2
5613 catch
{unset diffmergeid
}
5614 if {![info exists treefilelist
($id)]} {
5615 if {![info exists treepending
]} {
5616 if {$id eq
$nullid} {
5617 set cmd
[list | git ls-files
]
5618 } elseif
{$id eq
$nullid2} {
5619 set cmd
[list | git ls-files
--stage -t]
5621 set cmd
[list | git ls-tree
-r $id]
5623 if {[catch
{set gtf
[open
$cmd r
]}]} {
5627 set treefilelist
($id) {}
5628 set treeidlist
($id) {}
5629 fconfigure
$gtf -blocking 0
5630 filerun
$gtf [list gettreeline
$gtf $id]
5637 proc gettreeline
{gtf id
} {
5638 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5641 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
5642 if {$diffids eq
$nullid} {
5645 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
5646 set i
[string first
"\t" $line]
5647 if {$i < 0} continue
5648 set sha1
[lindex
$line 2]
5649 set fname
[string range
$line [expr {$i+1}] end
]
5650 if {[string index
$fname 0] eq
"\""} {
5651 set fname
[lindex
$fname 0]
5653 lappend treeidlist
($id) $sha1
5655 lappend treefilelist
($id) $fname
5658 return [expr {$nl >= 1000?
2: 1}]
5662 if {$cmitmode ne
"tree"} {
5663 if {![info exists diffmergeid
]} {
5664 gettreediffs
$diffids
5666 } elseif
{$id ne
$diffids} {
5675 global treefilelist treeidlist diffids nullid nullid2
5676 global ctext commentend
5678 set i
[lsearch
-exact $treefilelist($diffids) $f]
5680 puts
"oops, $f not in list for id $diffids"
5683 if {$diffids eq
$nullid} {
5684 if {[catch
{set bf
[open
$f r
]} err
]} {
5685 puts
"oops, can't read $f: $err"
5689 set blob
[lindex
$treeidlist($diffids) $i]
5690 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5691 puts
"oops, error reading blob $blob: $err"
5695 fconfigure
$bf -blocking 0
5696 filerun
$bf [list getblobline
$bf $diffids]
5697 $ctext config
-state normal
5698 clear_ctext
$commentend
5699 $ctext insert end
"\n"
5700 $ctext insert end
"$f\n" filesep
5701 $ctext config
-state disabled
5702 $ctext yview
$commentend
5706 proc getblobline
{bf id
} {
5707 global diffids cmitmode ctext
5709 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5713 $ctext config
-state normal
5715 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5716 $ctext insert end
"$line\n"
5719 # delete last newline
5720 $ctext delete
"end - 2c" "end - 1c"
5724 $ctext config
-state disabled
5725 return [expr {$nl >= 1000?
2: 1}]
5728 proc mergediff
{id
} {
5729 global diffmergeid mdifffd
5732 global limitdiffs viewfiles curview
5736 # this doesn't seem to actually affect anything...
5737 set cmd
[concat | git diff-tree
--no-commit-id --cc $id]
5738 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5739 set cmd
[concat
$cmd -- $viewfiles($curview)]
5741 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5742 error_popup
"[mc "Error getting merge diffs
:"] $err"
5745 fconfigure
$mdf -blocking 0
5746 set mdifffd
($id) $mdf
5747 set np
[llength
$parents($curview,$id)]
5749 filerun
$mdf [list getmergediffline
$mdf $id $np]
5752 proc getmergediffline
{mdf id np
} {
5753 global diffmergeid ctext cflist mergemax
5754 global difffilestart mdifffd
5756 $ctext conf
-state normal
5758 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5759 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5760 ||
$mdf != $mdifffd($id)} {
5764 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5765 # start of a new file
5766 $ctext insert end
"\n"
5767 set here
[$ctext index
"end - 1c"]
5768 lappend difffilestart
$here
5769 add_flist
[list
$fname]
5770 set l
[expr {(78 - [string length
$fname]) / 2}]
5771 set pad
[string range
"----------------------------------------" 1 $l]
5772 $ctext insert end
"$pad $fname $pad\n" filesep
5773 } elseif
{[regexp
{^@@
} $line]} {
5774 $ctext insert end
"$line\n" hunksep
5775 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5778 # parse the prefix - one ' ', '-' or '+' for each parent
5783 for {set j
0} {$j < $np} {incr j
} {
5784 set c
[string range
$line $j $j]
5787 } elseif
{$c == "-"} {
5789 } elseif
{$c == "+"} {
5798 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5799 # line doesn't appear in result, parents in $minuses have the line
5800 set num
[lindex
$minuses 0]
5801 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5802 # line appears in result, parents in $pluses don't have the line
5803 lappend tags mresult
5804 set num
[lindex
$spaces 0]
5807 if {$num >= $mergemax} {
5812 $ctext insert end
"$line\n" $tags
5815 $ctext conf
-state disabled
5820 return [expr {$nr >= 1000?
2: 1}]
5823 proc startdiff
{ids
} {
5824 global treediffs diffids treepending diffmergeid nullid nullid2
5828 catch
{unset diffmergeid
}
5829 if {![info exists treediffs
($ids)] ||
5830 [lsearch
-exact $ids $nullid] >= 0 ||
5831 [lsearch
-exact $ids $nullid2] >= 0} {
5832 if {![info exists treepending
]} {
5840 proc path_filter
{filter name
} {
5842 set l
[string length
$p]
5843 if {[string index
$p end
] eq
"/"} {
5844 if {[string compare
-length $l $p $name] == 0} {
5848 if {[string compare
-length $l $p $name] == 0 &&
5849 ([string length
$name] == $l ||
5850 [string index
$name $l] eq
"/")} {
5858 proc addtocflist
{ids
} {
5861 add_flist
$treediffs($ids)
5865 proc diffcmd
{ids flags
} {
5866 global nullid nullid2
5868 set i
[lsearch
-exact $ids $nullid]
5869 set j
[lsearch
-exact $ids $nullid2]
5871 if {[llength
$ids] > 1 && $j < 0} {
5872 # comparing working directory with some specific revision
5873 set cmd
[concat | git diff-index
$flags]
5875 lappend cmd
-R [lindex
$ids 1]
5877 lappend cmd
[lindex
$ids 0]
5880 # comparing working directory with index
5881 set cmd
[concat | git diff-files
$flags]
5886 } elseif
{$j >= 0} {
5887 set cmd
[concat | git diff-index
--cached $flags]
5888 if {[llength
$ids] > 1} {
5889 # comparing index with specific revision
5891 lappend cmd
-R [lindex
$ids 1]
5893 lappend cmd
[lindex
$ids 0]
5896 # comparing index with HEAD
5900 set cmd
[concat | git diff-tree
-r $flags $ids]
5905 proc gettreediffs
{ids
} {
5906 global treediff treepending
5908 set treepending
$ids
5910 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5911 fconfigure
$gdtf -blocking 0
5912 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5915 proc gettreediffline
{gdtf ids
} {
5916 global treediff treediffs treepending diffids diffmergeid
5917 global cmitmode viewfiles curview limitdiffs
5920 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5921 set i
[string first
"\t" $line]
5923 set file [string range
$line [expr {$i+1}] end
]
5924 if {[string index
$file 0] eq
"\""} {
5925 set file [lindex
$file 0]
5927 lappend treediff
$file
5931 return [expr {$nr >= 1000?
2: 1}]
5934 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5936 foreach f
$treediff {
5937 if {[path_filter
$viewfiles($curview) $f]} {
5941 set treediffs
($ids) $flist
5943 set treediffs
($ids) $treediff
5946 if {$cmitmode eq
"tree"} {
5948 } elseif
{$ids != $diffids} {
5949 if {![info exists diffmergeid
]} {
5950 gettreediffs
$diffids
5958 # empty string or positive integer
5959 proc diffcontextvalidate
{v
} {
5960 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5963 proc diffcontextchange
{n1 n2 op
} {
5964 global diffcontextstring diffcontext
5966 if {[string is integer
-strict $diffcontextstring]} {
5967 if {$diffcontextstring > 0} {
5968 set diffcontext
$diffcontextstring
5974 proc getblobdiffs
{ids
} {
5975 global blobdifffd diffids env
5976 global diffinhdr treediffs
5978 global limitdiffs viewfiles curview
5980 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5981 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5982 set cmd
[concat
$cmd -- $viewfiles($curview)]
5984 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5985 puts
"error getting diffs: $err"
5989 fconfigure
$bdf -blocking 0
5990 set blobdifffd
($ids) $bdf
5991 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5994 proc setinlist
{var i val
} {
5997 while {[llength
[set $var]] < $i} {
6000 if {[llength
[set $var]] == $i} {
6007 proc makediffhdr
{fname ids
} {
6008 global ctext curdiffstart treediffs
6010 set i
[lsearch
-exact $treediffs($ids) $fname]
6012 setinlist difffilestart
$i $curdiffstart
6014 set l
[expr {(78 - [string length
$fname]) / 2}]
6015 set pad
[string range
"----------------------------------------" 1 $l]
6016 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
6019 proc getblobdiffline
{bdf ids
} {
6020 global diffids blobdifffd ctext curdiffstart
6021 global diffnexthead diffnextnote difffilestart
6022 global diffinhdr treediffs
6025 $ctext conf
-state normal
6026 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
6027 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
6031 if {![string compare
-length 11 "diff --git " $line]} {
6032 # trim off "diff --git "
6033 set line
[string range
$line 11 end
]
6035 # start of a new file
6036 $ctext insert end
"\n"
6037 set curdiffstart
[$ctext index
"end - 1c"]
6038 $ctext insert end
"\n" filesep
6039 # If the name hasn't changed the length will be odd,
6040 # the middle char will be a space, and the two bits either
6041 # side will be a/name and b/name, or "a/name" and "b/name".
6042 # If the name has changed we'll get "rename from" and
6043 # "rename to" or "copy from" and "copy to" lines following this,
6044 # and we'll use them to get the filenames.
6045 # This complexity is necessary because spaces in the filename(s)
6046 # don't get escaped.
6047 set l
[string length
$line]
6048 set i
[expr {$l / 2}]
6049 if {!(($l & 1) && [string index
$line $i] eq
" " &&
6050 [string range
$line 2 [expr {$i - 1}]] eq \
6051 [string range
$line [expr {$i + 3}] end
])} {
6054 # unescape if quoted and chop off the a/ from the front
6055 if {[string index
$line 0] eq
"\""} {
6056 set fname
[string range
[lindex
$line 0] 2 end
]
6058 set fname
[string range
$line 2 [expr {$i - 1}]]
6060 makediffhdr
$fname $ids
6062 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
6063 $line match f1l f1c f2l f2c rest
]} {
6064 $ctext insert end
"$line\n" hunksep
6067 } elseif
{$diffinhdr} {
6068 if {![string compare
-length 12 "rename from " $line]} {
6069 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
6070 if {[string index
$fname 0] eq
"\""} {
6071 set fname
[lindex
$fname 0]
6073 set i
[lsearch
-exact $treediffs($ids) $fname]
6075 setinlist difffilestart
$i $curdiffstart
6077 } elseif
{![string compare
-length 10 $line "rename to "] ||
6078 ![string compare
-length 8 $line "copy to "]} {
6079 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
6080 if {[string index
$fname 0] eq
"\""} {
6081 set fname
[lindex
$fname 0]
6083 makediffhdr
$fname $ids
6084 } elseif
{[string compare
-length 3 $line "---"] == 0} {
6087 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
6091 $ctext insert end
"$line\n" filesep
6094 set x
[string range
$line 0 0]
6095 if {$x == "-" ||
$x == "+"} {
6096 set tag
[expr {$x == "+"}]
6097 $ctext insert end
"$line\n" d
$tag
6098 } elseif
{$x == " "} {
6099 $ctext insert end
"$line\n"
6101 # "\ No newline at end of file",
6102 # or something else we don't recognize
6103 $ctext insert end
"$line\n" hunksep
6107 $ctext conf
-state disabled
6112 return [expr {$nr >= 1000?
2: 1}]
6115 proc changediffdisp
{} {
6116 global ctext diffelide
6118 $ctext tag conf d0
-elide [lindex
$diffelide 0]
6119 $ctext tag conf d1
-elide [lindex
$diffelide 1]
6123 global difffilestart ctext
6124 set prev
[lindex
$difffilestart 0]
6125 set here
[$ctext index @
0,0]
6126 foreach loc
$difffilestart {
6127 if {[$ctext compare
$loc >= $here]} {
6137 global difffilestart ctext
6138 set here
[$ctext index @
0,0]
6139 foreach loc
$difffilestart {
6140 if {[$ctext compare
$loc > $here]} {
6147 proc clear_ctext
{{first
1.0}} {
6148 global ctext smarktop smarkbot
6151 set l
[lindex
[split $first .
] 0]
6152 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
6155 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
6158 $ctext delete
$first end
6159 if {$first eq
"1.0"} {
6160 catch
{unset pendinglinks
}
6164 proc settabs
{{firstab
{}}} {
6165 global firsttabstop tabstop ctext have_tk85
6167 if {$firstab ne
{} && $have_tk85} {
6168 set firsttabstop
$firstab
6170 set w
[font measure textfont
"0"]
6171 if {$firsttabstop != 0} {
6172 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
6173 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6174 } elseif
{$have_tk85 ||
$tabstop != 8} {
6175 $ctext conf
-tabs [expr {$tabstop * $w}]
6177 $ctext conf
-tabs {}
6181 proc incrsearch
{name ix op
} {
6182 global ctext searchstring searchdirn
6184 $ctext tag remove found
1.0 end
6185 if {[catch
{$ctext index anchor
}]} {
6186 # no anchor set, use start of selection, or of visible area
6187 set sel
[$ctext tag ranges sel
]
6189 $ctext mark
set anchor
[lindex
$sel 0]
6190 } elseif
{$searchdirn eq
"-forwards"} {
6191 $ctext mark
set anchor @
0,0
6193 $ctext mark
set anchor @
0,[winfo height
$ctext]
6196 if {$searchstring ne
{}} {
6197 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
6206 global sstring ctext searchstring searchdirn
6209 $sstring icursor end
6210 set searchdirn
-forwards
6211 if {$searchstring ne
{}} {
6212 set sel
[$ctext tag ranges sel
]
6214 set start
"[lindex $sel 0] + 1c"
6215 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6218 set match
[$ctext search
-count mlen
-- $searchstring $start]
6219 $ctext tag remove sel
1.0 end
6225 set mend
"$match + $mlen c"
6226 $ctext tag add sel
$match $mend
6227 $ctext mark
unset anchor
6231 proc dosearchback
{} {
6232 global sstring ctext searchstring searchdirn
6235 $sstring icursor end
6236 set searchdirn
-backwards
6237 if {$searchstring ne
{}} {
6238 set sel
[$ctext tag ranges sel
]
6240 set start
[lindex
$sel 0]
6241 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6242 set start @
0,[winfo height
$ctext]
6244 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
6245 $ctext tag remove sel
1.0 end
6251 set mend
"$match + $ml c"
6252 $ctext tag add sel
$match $mend
6253 $ctext mark
unset anchor
6257 proc searchmark
{first last
} {
6258 global ctext searchstring
6262 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
6263 if {$match eq
{}} break
6264 set mend
"$match + $mlen c"
6265 $ctext tag add found
$match $mend
6269 proc searchmarkvisible
{doall
} {
6270 global ctext smarktop smarkbot
6272 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
6273 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
6274 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
6275 # no overlap with previous
6276 searchmark
$topline $botline
6277 set smarktop
$topline
6278 set smarkbot
$botline
6280 if {$topline < $smarktop} {
6281 searchmark
$topline [expr {$smarktop-1}]
6282 set smarktop
$topline
6284 if {$botline > $smarkbot} {
6285 searchmark
[expr {$smarkbot+1}] $botline
6286 set smarkbot
$botline
6291 proc scrolltext
{f0 f1
} {
6294 .bleft.sb
set $f0 $f1
6295 if {$searchstring ne
{}} {
6301 global linespc charspc canvx0 canvy0
6302 global xspc1 xspc2 lthickness
6304 set linespc
[font metrics mainfont
-linespace]
6305 set charspc
[font measure mainfont
"m"]
6306 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
6307 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
6308 set lthickness
[expr {int
($linespc / 9) + 1}]
6309 set xspc1
(0) $linespc
6317 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6318 if {$ymax eq
{} ||
$ymax == 0} return
6319 set span
[$canv yview
]
6322 allcanvs yview moveto
[lindex
$span 0]
6324 if {[info exists selectedline
]} {
6325 selectline
$selectedline 0
6326 allcanvs yview moveto
[lindex
$span 0]
6330 proc parsefont
{f n
} {
6333 set fontattr
($f,family
) [lindex
$n 0]
6335 if {$s eq
{} ||
$s == 0} {
6338 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
6340 set fontattr
($f,size
) $s
6341 set fontattr
($f,weight
) normal
6342 set fontattr
($f,slant
) roman
6343 foreach style
[lrange
$n 2 end
] {
6346 "bold" {set fontattr
($f,weight
) $style}
6348 "italic" {set fontattr
($f,slant
) $style}
6353 proc fontflags
{f
{isbold
0}} {
6356 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
6357 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
6358 -slant $fontattr($f,slant
)]
6364 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
6365 if {$fontattr($f,weight
) eq
"bold"} {
6368 if {$fontattr($f,slant
) eq
"italic"} {
6374 proc incrfont
{inc
} {
6375 global mainfont textfont ctext canv cflist showrefstop
6376 global stopped entries fontattr
6379 set s
$fontattr(mainfont
,size
)
6384 set fontattr
(mainfont
,size
) $s
6385 font config mainfont
-size $s
6386 font config mainfontbold
-size $s
6387 set mainfont
[fontname mainfont
]
6388 set s
$fontattr(textfont
,size
)
6393 set fontattr
(textfont
,size
) $s
6394 font config textfont
-size $s
6395 font config textfontbold
-size $s
6396 set textfont
[fontname textfont
]
6403 global sha1entry sha1string
6404 if {[string length
$sha1string] == 40} {
6405 $sha1entry delete
0 end
6409 proc sha1change
{n1 n2 op
} {
6410 global sha1string currentid sha1but
6411 if {$sha1string == {}
6412 ||
([info exists currentid
] && $sha1string == $currentid)} {
6417 if {[$sha1but cget
-state] == $state} return
6418 if {$state == "normal"} {
6419 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
6421 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
6425 proc gotocommit
{} {
6426 global sha1string tagids headids curview varcid
6428 if {$sha1string == {}
6429 ||
([info exists currentid
] && $sha1string == $currentid)} return
6430 if {[info exists tagids
($sha1string)]} {
6431 set id
$tagids($sha1string)
6432 } elseif
{[info exists headids
($sha1string)]} {
6433 set id
$headids($sha1string)
6435 set id
[string tolower
$sha1string]
6436 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
6437 set matches
[array names varcid
"$curview,$id*"]
6438 if {$matches ne
{}} {
6439 if {[llength
$matches] > 1} {
6440 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
6443 set id
[lindex
[split [lindex
$matches 0] ","] 1]
6447 if {[commitinview
$id $curview]} {
6448 selectline
[rowofcommit
$id] 1
6451 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
6452 set msg
[mc
"SHA1 id %s is not known" $sha1string]
6454 set msg
[mc
"Tag/Head %s is not known" $sha1string]
6459 proc lineenter
{x y id
} {
6460 global hoverx hovery hoverid hovertimer
6461 global commitinfo canv
6463 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6467 if {[info exists hovertimer
]} {
6468 after cancel
$hovertimer
6470 set hovertimer
[after
500 linehover
]
6474 proc linemotion
{x y id
} {
6475 global hoverx hovery hoverid hovertimer
6477 if {[info exists hoverid
] && $id == $hoverid} {
6480 if {[info exists hovertimer
]} {
6481 after cancel
$hovertimer
6483 set hovertimer
[after
500 linehover
]
6487 proc lineleave
{id
} {
6488 global hoverid hovertimer canv
6490 if {[info exists hoverid
] && $id == $hoverid} {
6492 if {[info exists hovertimer
]} {
6493 after cancel
$hovertimer
6501 global hoverx hovery hoverid hovertimer
6502 global canv linespc lthickness
6505 set text
[lindex
$commitinfo($hoverid) 0]
6506 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6507 if {$ymax == {}} return
6508 set yfrac
[lindex
[$canv yview
] 0]
6509 set x
[expr {$hoverx + 2 * $linespc}]
6510 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6511 set x0
[expr {$x - 2 * $lthickness}]
6512 set y0
[expr {$y - 2 * $lthickness}]
6513 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
6514 set y1
[expr {$y + $linespc + 2 * $lthickness}]
6515 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
6516 -fill \
#ffff80 -outline black -width 1 -tags hover]
6518 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
6523 proc clickisonarrow
{id y
} {
6526 set ranges
[rowranges
$id]
6527 set thresh
[expr {2 * $lthickness + 6}]
6528 set n
[expr {[llength
$ranges] - 1}]
6529 for {set i
1} {$i < $n} {incr i
} {
6530 set row
[lindex
$ranges $i]
6531 if {abs
([yc
$row] - $y) < $thresh} {
6538 proc arrowjump
{id n y
} {
6541 # 1 <-> 2, 3 <-> 4, etc...
6542 set n
[expr {(($n - 1) ^
1) + 1}]
6543 set row
[lindex
[rowranges
$id] $n]
6545 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6546 if {$ymax eq
{} ||
$ymax <= 0} return
6547 set view
[$canv yview
]
6548 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
6549 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
6553 allcanvs yview moveto
$yfrac
6556 proc lineclick
{x y id isnew
} {
6557 global ctext commitinfo children canv thickerline curview
6559 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6564 # draw this line thicker than normal
6568 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6569 if {$ymax eq
{}} return
6570 set yfrac
[lindex
[$canv yview
] 0]
6571 set y
[expr {$y + $yfrac * $ymax}]
6573 set dirn
[clickisonarrow
$id $y]
6575 arrowjump
$id $dirn $y
6580 addtohistory
[list lineclick
$x $y $id 0]
6582 # fill the details pane with info about this line
6583 $ctext conf
-state normal
6586 $ctext insert end
"[mc "Parent
"]:\t"
6587 $ctext insert end
$id link0
6589 set info
$commitinfo($id)
6590 $ctext insert end
"\n\t[lindex $info 0]\n"
6591 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
6592 set date [formatdate
[lindex
$info 2]]
6593 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
6594 set kids
$children($curview,$id)
6596 $ctext insert end
"\n[mc "Children
"]:"
6598 foreach child
$kids {
6600 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
6601 set info
$commitinfo($child)
6602 $ctext insert end
"\n\t"
6603 $ctext insert end
$child link
$i
6604 setlink
$child link
$i
6605 $ctext insert end
"\n\t[lindex $info 0]"
6606 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
6607 set date [formatdate
[lindex
$info 2]]
6608 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
6611 $ctext conf
-state disabled
6615 proc normalline
{} {
6617 if {[info exists thickerline
]} {
6626 if {[commitinview
$id $curview]} {
6627 selectline
[rowofcommit
$id] 1
6633 if {![info exists startmstime
]} {
6634 set startmstime
[clock clicks
-milliseconds]
6636 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
6639 proc rowmenu
{x y id
} {
6640 global rowctxmenu selectedline rowmenuid curview
6641 global nullid nullid2 fakerowmenu mainhead
6645 if {![info exists selectedline
]
6646 ||
[rowofcommit
$id] eq
$selectedline} {
6651 if {$id ne
$nullid && $id ne
$nullid2} {
6652 set menu
$rowctxmenu
6653 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6655 set menu
$fakerowmenu
6657 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6658 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6659 $menu entryconfigure
[mc
"Make patch"] -state $state
6660 tk_popup
$menu $x $y
6663 proc diffvssel
{dirn
} {
6664 global rowmenuid selectedline
6666 if {![info exists selectedline
]} return
6668 set oldid
[commitonrow
$selectedline]
6669 set newid
$rowmenuid
6671 set oldid
$rowmenuid
6672 set newid
[commitonrow
$selectedline]
6674 addtohistory
[list doseldiff
$oldid $newid]
6675 doseldiff
$oldid $newid
6678 proc doseldiff
{oldid newid
} {
6682 $ctext conf
-state normal
6684 init_flist
[mc
"Top"]
6685 $ctext insert end
"[mc "From
"] "
6686 $ctext insert end
$oldid link0
6687 setlink
$oldid link0
6688 $ctext insert end
"\n "
6689 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6690 $ctext insert end
"\n\n[mc "To
"] "
6691 $ctext insert end
$newid link1
6692 setlink
$newid link1
6693 $ctext insert end
"\n "
6694 $ctext insert end
[lindex
$commitinfo($newid) 0]
6695 $ctext insert end
"\n"
6696 $ctext conf
-state disabled
6697 $ctext tag remove found
1.0 end
6698 startdiff
[list
$oldid $newid]
6702 global rowmenuid currentid commitinfo patchtop patchnum
6704 if {![info exists currentid
]} return
6705 set oldid
$currentid
6706 set oldhead
[lindex
$commitinfo($oldid) 0]
6707 set newid
$rowmenuid
6708 set newhead
[lindex
$commitinfo($newid) 0]
6711 catch
{destroy
$top}
6713 label
$top.title
-text [mc
"Generate patch"]
6714 grid
$top.title
- -pady 10
6715 label
$top.from
-text [mc
"From:"]
6716 entry
$top.fromsha1
-width 40 -relief flat
6717 $top.fromsha1 insert
0 $oldid
6718 $top.fromsha1 conf
-state readonly
6719 grid
$top.from
$top.fromsha1
-sticky w
6720 entry
$top.fromhead
-width 60 -relief flat
6721 $top.fromhead insert
0 $oldhead
6722 $top.fromhead conf
-state readonly
6723 grid x
$top.fromhead
-sticky w
6724 label
$top.to
-text [mc
"To:"]
6725 entry
$top.tosha1
-width 40 -relief flat
6726 $top.tosha1 insert
0 $newid
6727 $top.tosha1 conf
-state readonly
6728 grid
$top.to
$top.tosha1
-sticky w
6729 entry
$top.tohead
-width 60 -relief flat
6730 $top.tohead insert
0 $newhead
6731 $top.tohead conf
-state readonly
6732 grid x
$top.tohead
-sticky w
6733 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6734 grid
$top.
rev x
-pady 10
6735 label
$top.flab
-text [mc
"Output file:"]
6736 entry
$top.fname
-width 60
6737 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6739 grid
$top.flab
$top.fname
-sticky w
6741 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6742 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6743 grid
$top.buts.gen
$top.buts.can
6744 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6745 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6746 grid
$top.buts
- -pady 10 -sticky ew
6750 proc mkpatchrev
{} {
6753 set oldid
[$patchtop.fromsha1 get
]
6754 set oldhead
[$patchtop.fromhead get
]
6755 set newid
[$patchtop.tosha1 get
]
6756 set newhead
[$patchtop.tohead get
]
6757 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6758 v
[list
$newid $newhead $oldid $oldhead] {
6759 $patchtop.
$e conf
-state normal
6760 $patchtop.
$e delete
0 end
6761 $patchtop.
$e insert
0 $v
6762 $patchtop.
$e conf
-state readonly
6767 global patchtop nullid nullid2
6769 set oldid
[$patchtop.fromsha1 get
]
6770 set newid
[$patchtop.tosha1 get
]
6771 set fname
[$patchtop.fname get
]
6772 set cmd
[diffcmd
[list
$oldid $newid] -p]
6773 # trim off the initial "|"
6774 set cmd
[lrange
$cmd 1 end
]
6775 lappend cmd
>$fname &
6776 if {[catch
{eval exec $cmd} err
]} {
6777 error_popup
"[mc "Error creating
patch:"] $err"
6779 catch
{destroy
$patchtop}
6783 proc mkpatchcan
{} {
6786 catch
{destroy
$patchtop}
6791 global rowmenuid mktagtop commitinfo
6795 catch
{destroy
$top}
6797 label
$top.title
-text [mc
"Create tag"]
6798 grid
$top.title
- -pady 10
6799 label
$top.id
-text [mc
"ID:"]
6800 entry
$top.sha1
-width 40 -relief flat
6801 $top.sha1 insert
0 $rowmenuid
6802 $top.sha1 conf
-state readonly
6803 grid
$top.id
$top.sha1
-sticky w
6804 entry
$top.
head -width 60 -relief flat
6805 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6806 $top.
head conf
-state readonly
6807 grid x
$top.
head -sticky w
6808 label
$top.tlab
-text [mc
"Tag name:"]
6809 entry
$top.tag
-width 60
6810 grid
$top.tlab
$top.tag
-sticky w
6812 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6813 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6814 grid
$top.buts.gen
$top.buts.can
6815 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6816 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6817 grid
$top.buts
- -pady 10 -sticky ew
6822 global mktagtop env tagids idtags
6824 set id
[$mktagtop.sha1 get
]
6825 set tag
[$mktagtop.tag get
]
6827 error_popup
[mc
"No tag name specified"]
6830 if {[info exists tagids
($tag)]} {
6831 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6836 set fname
[file join $dir "refs/tags" $tag]
6837 set f
[open
$fname w
]
6841 error_popup
"[mc "Error creating tag
:"] $err"
6845 set tagids
($tag) $id
6846 lappend idtags
($id) $tag
6853 proc redrawtags
{id
} {
6854 global canv linehtag idpos currentid curview
6855 global canvxmax iddrawn
6857 if {![commitinview
$id $curview]} return
6858 if {![info exists iddrawn
($id)]} return
6859 set row
[rowofcommit
$id]
6860 $canv delete tag.
$id
6861 set xt
[eval drawtags
$id $idpos($id)]
6862 $canv coords
$linehtag($row) $xt [lindex
$idpos($id) 2]
6863 set text
[$canv itemcget
$linehtag($row) -text]
6864 set font
[$canv itemcget
$linehtag($row) -font]
6865 set xr
[expr {$xt + [font measure
$font $text]}]
6866 if {$xr > $canvxmax} {
6870 if {[info exists currentid
] && $currentid == $id} {
6878 catch
{destroy
$mktagtop}
6887 proc writecommit
{} {
6888 global rowmenuid wrcomtop commitinfo wrcomcmd
6890 set top .writecommit
6892 catch
{destroy
$top}
6894 label
$top.title
-text [mc
"Write commit to file"]
6895 grid
$top.title
- -pady 10
6896 label
$top.id
-text [mc
"ID:"]
6897 entry
$top.sha1
-width 40 -relief flat
6898 $top.sha1 insert
0 $rowmenuid
6899 $top.sha1 conf
-state readonly
6900 grid
$top.id
$top.sha1
-sticky w
6901 entry
$top.
head -width 60 -relief flat
6902 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6903 $top.
head conf
-state readonly
6904 grid x
$top.
head -sticky w
6905 label
$top.clab
-text [mc
"Command:"]
6906 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6907 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6908 label
$top.flab
-text [mc
"Output file:"]
6909 entry
$top.fname
-width 60
6910 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6911 grid
$top.flab
$top.fname
-sticky w
6913 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6914 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6915 grid
$top.buts.gen
$top.buts.can
6916 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6917 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6918 grid
$top.buts
- -pady 10 -sticky ew
6925 set id
[$wrcomtop.sha1 get
]
6926 set cmd
"echo $id | [$wrcomtop.cmd get]"
6927 set fname
[$wrcomtop.fname get
]
6928 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6929 error_popup
"[mc "Error writing commit
:"] $err"
6931 catch
{destroy
$wrcomtop}
6938 catch
{destroy
$wrcomtop}
6943 global rowmenuid mkbrtop
6946 catch
{destroy
$top}
6948 label
$top.title
-text [mc
"Create new branch"]
6949 grid
$top.title
- -pady 10
6950 label
$top.id
-text [mc
"ID:"]
6951 entry
$top.sha1
-width 40 -relief flat
6952 $top.sha1 insert
0 $rowmenuid
6953 $top.sha1 conf
-state readonly
6954 grid
$top.id
$top.sha1
-sticky w
6955 label
$top.nlab
-text [mc
"Name:"]
6956 entry
$top.name
-width 40
6957 grid
$top.nlab
$top.name
-sticky w
6959 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6960 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6961 grid
$top.buts.go
$top.buts.can
6962 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6963 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6964 grid
$top.buts
- -pady 10 -sticky ew
6969 global headids idheads
6971 set name
[$top.name get
]
6972 set id
[$top.sha1 get
]
6974 error_popup
[mc
"Please specify a name for the new branch"]
6977 catch
{destroy
$top}
6981 exec git branch
$name $id
6986 set headids
($name) $id
6987 lappend idheads
($id) $name
6996 proc cherrypick
{} {
6997 global rowmenuid curview
7000 set oldhead
[exec git rev-parse HEAD
]
7001 set dheads
[descheads
$rowmenuid]
7002 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
7003 set ok
[confirm_popup
[mc
"Commit %s is already\
7004 included in branch %s -- really re-apply it?" \
7005 [string range
$rowmenuid 0 7] $mainhead]]
7008 nowbusy cherrypick
[mc
"Cherry-picking"]
7010 # Unfortunately git-cherry-pick writes stuff to stderr even when
7011 # no error occurs, and exec takes that as an indication of error...
7012 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
7017 set newhead
[exec git rev-parse HEAD
]
7018 if {$newhead eq
$oldhead} {
7020 error_popup
[mc
"No changes committed"]
7023 addnewchild
$newhead $oldhead
7024 if {[commitinview
$oldhead $curview]} {
7025 insertrow
$newhead $oldhead $curview
7026 if {$mainhead ne
{}} {
7027 movehead
$newhead $mainhead
7028 movedhead
$newhead $mainhead
7038 global mainheadid mainhead rowmenuid confirm_ok resettype
7041 set w
".confirmreset"
7044 wm title
$w [mc
"Confirm reset"]
7045 message
$w.m
-text \
7046 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
7047 -justify center
-aspect 1000
7048 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
7049 frame
$w.f
-relief sunken
-border 2
7050 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
7051 grid
$w.f.rt
-sticky w
7053 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
7054 -text [mc
"Soft: Leave working tree and index untouched"]
7055 grid
$w.f.soft
-sticky w
7056 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
7057 -text [mc
"Mixed: Leave working tree untouched, reset index"]
7058 grid
$w.f.mixed
-sticky w
7059 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
7060 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
7061 grid
$w.f.hard
-sticky w
7062 pack
$w.f
-side top
-fill x
7063 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
7064 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
7065 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
7066 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
7067 bind $w <Visibility
> "grab $w; focus $w"
7069 if {!$confirm_ok} return
7070 if {[catch
{set fd
[open \
7071 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
7075 filerun
$fd [list readresetstat
$fd]
7076 nowbusy
reset [mc
"Resetting"]
7081 proc readresetstat
{fd
} {
7082 global mainhead mainheadid showlocalchanges rprogcoord
7084 if {[gets
$fd line
] >= 0} {
7085 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
7086 set rprogcoord
[expr {1.0 * $m / $n}]
7094 if {[catch
{close
$fd} err
]} {
7097 set oldhead
$mainheadid
7098 set newhead
[exec git rev-parse HEAD
]
7099 if {$newhead ne
$oldhead} {
7100 movehead
$newhead $mainhead
7101 movedhead
$newhead $mainhead
7102 set mainheadid
$newhead
7106 if {$showlocalchanges} {
7112 # context menu for a head
7113 proc headmenu
{x y id
head} {
7114 global headmenuid headmenuhead headctxmenu mainhead
7118 set headmenuhead
$head
7120 if {$head eq
$mainhead} {
7123 $headctxmenu entryconfigure
0 -state $state
7124 $headctxmenu entryconfigure
1 -state $state
7125 tk_popup
$headctxmenu $x $y
7129 global headmenuid headmenuhead mainhead headids
7130 global showlocalchanges mainheadid
7132 # check the tree is clean first??
7133 set oldmainhead
$mainhead
7134 nowbusy checkout
[mc
"Checking out"]
7138 exec git checkout
-q $headmenuhead
7144 set mainhead
$headmenuhead
7145 set mainheadid
$headmenuid
7146 if {[info exists headids
($oldmainhead)]} {
7147 redrawtags
$headids($oldmainhead)
7149 redrawtags
$headmenuid
7152 if {$showlocalchanges} {
7158 global headmenuid headmenuhead mainhead
7161 set head $headmenuhead
7163 # this check shouldn't be needed any more...
7164 if {$head eq
$mainhead} {
7165 error_popup
[mc
"Cannot delete the currently checked-out branch"]
7168 set dheads
[descheads
$id]
7169 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
7170 # the stuff on this branch isn't on any other branch
7171 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
7172 branch.\nReally delete branch %s?" $head $head]]} return
7176 if {[catch
{exec git branch
-D $head} err
]} {
7181 removehead
$id $head
7182 removedhead
$id $head
7189 # Display a list of tags and heads
7191 global showrefstop bgcolor fgcolor selectbgcolor
7192 global bglist fglist reflistfilter reflist maincursor
7195 set showrefstop
$top
7196 if {[winfo exists
$top]} {
7202 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
7203 text
$top.list
-background $bgcolor -foreground $fgcolor \
7204 -selectbackground $selectbgcolor -font mainfont \
7205 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7206 -width 30 -height 20 -cursor $maincursor \
7207 -spacing1 1 -spacing3 1 -state disabled
7208 $top.list tag configure highlight
-background $selectbgcolor
7209 lappend bglist
$top.list
7210 lappend fglist
$top.list
7211 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
7212 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
7213 grid
$top.list
$top.ysb
-sticky nsew
7214 grid
$top.xsb x
-sticky ew
7216 label
$top.f.l
-text "[mc "Filter
"]: "
7217 entry
$top.f.e
-width 20 -textvariable reflistfilter
7218 set reflistfilter
"*"
7219 trace add variable reflistfilter
write reflistfilter_change
7220 pack
$top.f.e
-side right
-fill x
-expand 1
7221 pack
$top.f.l
-side left
7222 grid
$top.f
- -sticky ew
-pady 2
7223 button
$top.close
-command [list destroy
$top] -text [mc
"Close"]
7225 grid columnconfigure
$top 0 -weight 1
7226 grid rowconfigure
$top 0 -weight 1
7227 bind $top.list
<1> {break}
7228 bind $top.list
<B1-Motion
> {break}
7229 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
7234 proc sel_reflist
{w x y
} {
7235 global showrefstop reflist headids tagids otherrefids
7237 if {![winfo exists
$showrefstop]} return
7238 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
7239 set ref
[lindex
$reflist [expr {$l-1}]]
7240 set n
[lindex
$ref 0]
7241 switch
-- [lindex
$ref 1] {
7242 "H" {selbyid
$headids($n)}
7243 "T" {selbyid
$tagids($n)}
7244 "o" {selbyid
$otherrefids($n)}
7246 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
7249 proc unsel_reflist
{} {
7252 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7253 $showrefstop.list tag remove highlight
0.0 end
7256 proc reflistfilter_change
{n1 n2 op
} {
7257 global reflistfilter
7259 after cancel refill_reflist
7260 after
200 refill_reflist
7263 proc refill_reflist
{} {
7264 global reflist reflistfilter showrefstop headids tagids otherrefids
7265 global curview commitinterest
7267 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7269 foreach n
[array names headids
] {
7270 if {[string match
$reflistfilter $n]} {
7271 if {[commitinview
$headids($n) $curview]} {
7272 lappend refs
[list
$n H
]
7274 set commitinterest
($headids($n)) {run refill_reflist
}
7278 foreach n
[array names tagids
] {
7279 if {[string match
$reflistfilter $n]} {
7280 if {[commitinview
$tagids($n) $curview]} {
7281 lappend refs
[list
$n T
]
7283 set commitinterest
($tagids($n)) {run refill_reflist
}
7287 foreach n
[array names otherrefids
] {
7288 if {[string match
$reflistfilter $n]} {
7289 if {[commitinview
$otherrefids($n) $curview]} {
7290 lappend refs
[list
$n o
]
7292 set commitinterest
($otherrefids($n)) {run refill_reflist
}
7296 set refs
[lsort
-index 0 $refs]
7297 if {$refs eq
$reflist} return
7299 # Update the contents of $showrefstop.list according to the
7300 # differences between $reflist (old) and $refs (new)
7301 $showrefstop.list conf
-state normal
7302 $showrefstop.list insert end
"\n"
7305 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
7306 if {$i < [llength
$reflist]} {
7307 if {$j < [llength
$refs]} {
7308 set cmp [string compare
[lindex
$reflist $i 0] \
7309 [lindex
$refs $j 0]]
7311 set cmp [string compare
[lindex
$reflist $i 1] \
7312 [lindex
$refs $j 1]]
7322 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
7330 set l
[expr {$j + 1}]
7331 $showrefstop.list image create
$l.0 -align baseline \
7332 -image reficon-
[lindex
$refs $j 1] -padx 2
7333 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
7339 # delete last newline
7340 $showrefstop.list delete end-2c end-1c
7341 $showrefstop.list conf
-state disabled
7344 # Stuff for finding nearby tags
7345 proc getallcommits
{} {
7346 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7347 global idheads idtags idotherrefs allparents tagobjid
7349 if {![info exists allcommits
]} {
7355 set allccache
[file join [gitdir
] "gitk.cache"]
7357 set f
[open
$allccache r
]
7366 set cmd
[list | git rev-list
--parents]
7367 set allcupdate
[expr {$seeds ne
{}}]
7371 set refs
[concat
[array names idheads
] [array names idtags
] \
7372 [array names idotherrefs
]]
7375 foreach name
[array names tagobjid
] {
7376 lappend tagobjs
$tagobjid($name)
7378 foreach id
[lsort
-unique $refs] {
7379 if {![info exists allparents
($id)] &&
7380 [lsearch
-exact $tagobjs $id] < 0} {
7391 set fd
[open
[concat
$cmd $ids] r
]
7392 fconfigure
$fd -blocking 0
7395 filerun
$fd [list getallclines
$fd]
7401 # Since most commits have 1 parent and 1 child, we group strings of
7402 # such commits into "arcs" joining branch/merge points (BMPs), which
7403 # are commits that either don't have 1 parent or don't have 1 child.
7405 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7406 # arcout(id) - outgoing arcs for BMP
7407 # arcids(a) - list of IDs on arc including end but not start
7408 # arcstart(a) - BMP ID at start of arc
7409 # arcend(a) - BMP ID at end of arc
7410 # growing(a) - arc a is still growing
7411 # arctags(a) - IDs out of arcids (excluding end) that have tags
7412 # archeads(a) - IDs out of arcids (excluding end) that have heads
7413 # The start of an arc is at the descendent end, so "incoming" means
7414 # coming from descendents, and "outgoing" means going towards ancestors.
7416 proc getallclines
{fd
} {
7417 global allparents allchildren idtags idheads nextarc
7418 global arcnos arcids arctags arcout arcend arcstart archeads growing
7419 global seeds allcommits cachedarcs allcupdate
7422 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
7423 set id
[lindex
$line 0]
7424 if {[info exists allparents
($id)]} {
7429 set olds
[lrange
$line 1 end
]
7430 set allparents
($id) $olds
7431 if {![info exists allchildren
($id)]} {
7432 set allchildren
($id) {}
7437 if {[llength
$olds] == 1 && [llength
$a] == 1} {
7438 lappend arcids
($a) $id
7439 if {[info exists idtags
($id)]} {
7440 lappend arctags
($a) $id
7442 if {[info exists idheads
($id)]} {
7443 lappend archeads
($a) $id
7445 if {[info exists allparents
($olds)]} {
7446 # seen parent already
7447 if {![info exists arcout
($olds)]} {
7450 lappend arcids
($a) $olds
7451 set arcend
($a) $olds
7454 lappend allchildren
($olds) $id
7455 lappend arcnos
($olds) $a
7459 foreach a
$arcnos($id) {
7460 lappend arcids
($a) $id
7467 lappend allchildren
($p) $id
7468 set a
[incr nextarc
]
7469 set arcstart
($a) $id
7476 if {[info exists allparents
($p)]} {
7477 # seen it already, may need to make a new branch
7478 if {![info exists arcout
($p)]} {
7481 lappend arcids
($a) $p
7485 lappend arcnos
($p) $a
7490 global cached_dheads cached_dtags cached_atags
7491 catch
{unset cached_dheads
}
7492 catch
{unset cached_dtags
}
7493 catch
{unset cached_atags
}
7496 return [expr {$nid >= 1000?
2: 1}]
7500 fconfigure
$fd -blocking 1
7503 # got an error reading the list of commits
7504 # if we were updating, try rereading the whole thing again
7510 error_popup
"[mc "Error reading commit topology information
;\
7511 branch and preceding
/following tag information\
7512 will be incomplete.
"]\n($err)"
7515 if {[incr allcommits
-1] == 0} {
7525 proc recalcarc
{a
} {
7526 global arctags archeads arcids idtags idheads
7530 foreach id
[lrange
$arcids($a) 0 end-1
] {
7531 if {[info exists idtags
($id)]} {
7534 if {[info exists idheads
($id)]} {
7539 set archeads
($a) $ah
7543 global arcnos arcids nextarc arctags archeads idtags idheads
7544 global arcstart arcend arcout allparents growing
7547 if {[llength
$a] != 1} {
7548 puts
"oops splitarc called but [llength $a] arcs already"
7552 set i
[lsearch
-exact $arcids($a) $p]
7554 puts
"oops splitarc $p not in arc $a"
7557 set na
[incr nextarc
]
7558 if {[info exists arcend
($a)]} {
7559 set arcend
($na) $arcend($a)
7561 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
7562 set j
[lsearch
-exact $arcnos($l) $a]
7563 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
7565 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
7566 set arcids
($a) [lrange
$arcids($a) 0 $i]
7568 set arcstart
($na) $p
7570 set arcids
($na) $tail
7571 if {[info exists growing
($a)]} {
7577 if {[llength
$arcnos($id)] == 1} {
7580 set j
[lsearch
-exact $arcnos($id) $a]
7581 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
7585 # reconstruct tags and heads lists
7586 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
7591 set archeads
($na) {}
7595 # Update things for a new commit added that is a child of one
7596 # existing commit. Used when cherry-picking.
7597 proc addnewchild
{id p
} {
7598 global allparents allchildren idtags nextarc
7599 global arcnos arcids arctags arcout arcend arcstart archeads growing
7600 global seeds allcommits
7602 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
7603 set allparents
($id) [list
$p]
7604 set allchildren
($id) {}
7607 lappend allchildren
($p) $id
7608 set a
[incr nextarc
]
7609 set arcstart
($a) $id
7612 set arcids
($a) [list
$p]
7614 if {![info exists arcout
($p)]} {
7617 lappend arcnos
($p) $a
7618 set arcout
($id) [list
$a]
7621 # This implements a cache for the topology information.
7622 # The cache saves, for each arc, the start and end of the arc,
7623 # the ids on the arc, and the outgoing arcs from the end.
7624 proc readcache
{f
} {
7625 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7626 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7631 if {$lim - $a > 500} {
7632 set lim
[expr {$a + 500}]
7636 # finish reading the cache and setting up arctags, etc.
7638 if {$line ne
"1"} {error
"bad final version"}
7640 foreach id
[array names idtags
] {
7641 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7642 [llength
$allparents($id)] == 1} {
7643 set a
[lindex
$arcnos($id) 0]
7644 if {$arctags($a) eq
{}} {
7649 foreach id
[array names idheads
] {
7650 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7651 [llength
$allparents($id)] == 1} {
7652 set a
[lindex
$arcnos($id) 0]
7653 if {$archeads($a) eq
{}} {
7658 foreach id
[lsort
-unique $possible_seeds] {
7659 if {$arcnos($id) eq
{}} {
7665 while {[incr a
] <= $lim} {
7667 if {[llength
$line] != 3} {error
"bad line"}
7668 set s
[lindex
$line 0]
7670 lappend arcout
($s) $a
7671 if {![info exists arcnos
($s)]} {
7672 lappend possible_seeds
$s
7675 set e
[lindex
$line 1]
7680 if {![info exists arcout
($e)]} {
7684 set arcids
($a) [lindex
$line 2]
7685 foreach id
$arcids($a) {
7686 lappend allparents
($s) $id
7688 lappend arcnos
($id) $a
7690 if {![info exists allparents
($s)]} {
7691 set allparents
($s) {}
7696 set nextarc
[expr {$a - 1}]
7709 global nextarc cachedarcs possible_seeds
7713 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7714 # make sure it's an integer
7715 set cachedarcs
[expr {int
([lindex
$line 1])}]
7716 if {$cachedarcs < 0} {error
"bad number of arcs"}
7718 set possible_seeds
{}
7726 proc dropcache
{err
} {
7727 global allcwait nextarc cachedarcs seeds
7729 #puts "dropping cache ($err)"
7730 foreach v
{arcnos arcout arcids arcstart arcend growing \
7731 arctags archeads allparents allchildren
} {
7742 proc writecache
{f
} {
7743 global cachearc cachedarcs allccache
7744 global arcstart arcend arcnos arcids arcout
7748 if {$lim - $a > 1000} {
7749 set lim
[expr {$a + 1000}]
7752 while {[incr a
] <= $lim} {
7753 if {[info exists arcend
($a)]} {
7754 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7756 puts
$f [list
$arcstart($a) {} $arcids($a)]
7761 catch
{file delete
$allccache}
7762 #puts "writing cache failed ($err)"
7765 set cachearc
[expr {$a - 1}]
7766 if {$a > $cachedarcs} {
7775 global nextarc cachedarcs cachearc allccache
7777 if {$nextarc == $cachedarcs} return
7779 set cachedarcs
$nextarc
7781 set f
[open
$allccache w
]
7782 puts
$f [list
1 $cachedarcs]
7787 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7788 # or 0 if neither is true.
7789 proc anc_or_desc
{a b
} {
7790 global arcout arcstart arcend arcnos cached_isanc
7792 if {$arcnos($a) eq
$arcnos($b)} {
7793 # Both are on the same arc(s); either both are the same BMP,
7794 # or if one is not a BMP, the other is also not a BMP or is
7795 # the BMP at end of the arc (and it only has 1 incoming arc).
7796 # Or both can be BMPs with no incoming arcs.
7797 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7800 # assert {[llength $arcnos($a)] == 1}
7801 set arc
[lindex
$arcnos($a) 0]
7802 set i
[lsearch
-exact $arcids($arc) $a]
7803 set j
[lsearch
-exact $arcids($arc) $b]
7804 if {$i < 0 ||
$i > $j} {
7811 if {![info exists arcout
($a)]} {
7812 set arc
[lindex
$arcnos($a) 0]
7813 if {[info exists arcend
($arc)]} {
7814 set aend
$arcend($arc)
7818 set a
$arcstart($arc)
7822 if {![info exists arcout
($b)]} {
7823 set arc
[lindex
$arcnos($b) 0]
7824 if {[info exists arcend
($arc)]} {
7825 set bend
$arcend($arc)
7829 set b
$arcstart($arc)
7839 if {[info exists cached_isanc
($a,$bend)]} {
7840 if {$cached_isanc($a,$bend)} {
7844 if {[info exists cached_isanc
($b,$aend)]} {
7845 if {$cached_isanc($b,$aend)} {
7848 if {[info exists cached_isanc
($a,$bend)]} {
7853 set todo
[list
$a $b]
7856 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7857 set x
[lindex
$todo $i]
7858 if {$anc($x) eq
{}} {
7861 foreach arc
$arcnos($x) {
7862 set xd
$arcstart($arc)
7864 set cached_isanc
($a,$bend) 1
7865 set cached_isanc
($b,$aend) 0
7867 } elseif
{$xd eq
$aend} {
7868 set cached_isanc
($b,$aend) 1
7869 set cached_isanc
($a,$bend) 0
7872 if {![info exists anc
($xd)]} {
7873 set anc
($xd) $anc($x)
7875 } elseif
{$anc($xd) ne
$anc($x)} {
7880 set cached_isanc
($a,$bend) 0
7881 set cached_isanc
($b,$aend) 0
7885 # This identifies whether $desc has an ancestor that is
7886 # a growing tip of the graph and which is not an ancestor of $anc
7887 # and returns 0 if so and 1 if not.
7888 # If we subsequently discover a tag on such a growing tip, and that
7889 # turns out to be a descendent of $anc (which it could, since we
7890 # don't necessarily see children before parents), then $desc
7891 # isn't a good choice to display as a descendent tag of
7892 # $anc (since it is the descendent of another tag which is
7893 # a descendent of $anc). Similarly, $anc isn't a good choice to
7894 # display as a ancestor tag of $desc.
7896 proc is_certain
{desc anc
} {
7897 global arcnos arcout arcstart arcend growing problems
7900 if {[llength
$arcnos($anc)] == 1} {
7901 # tags on the same arc are certain
7902 if {$arcnos($desc) eq
$arcnos($anc)} {
7905 if {![info exists arcout
($anc)]} {
7906 # if $anc is partway along an arc, use the start of the arc instead
7907 set a
[lindex
$arcnos($anc) 0]
7908 set anc
$arcstart($a)
7911 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7914 set a
[lindex
$arcnos($desc) 0]
7920 set anclist
[list
$x]
7924 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7925 set x
[lindex
$anclist $i]
7930 foreach a
$arcout($x) {
7931 if {[info exists growing
($a)]} {
7932 if {![info exists growanc
($x)] && $dl($x)} {
7938 if {[info exists dl
($y)]} {
7942 if {![info exists
done($y)]} {
7945 if {[info exists growanc
($x)]} {
7949 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7950 set z
[lindex
$xl $k]
7951 foreach c
$arcout($z) {
7952 if {[info exists arcend
($c)]} {
7954 if {[info exists dl
($v)] && $dl($v)} {
7956 if {![info exists
done($v)]} {
7959 if {[info exists growanc
($v)]} {
7969 } elseif
{$y eq
$anc ||
!$dl($x)} {
7980 foreach x
[array names growanc
] {
7989 proc validate_arctags
{a
} {
7990 global arctags idtags
7994 foreach id
$arctags($a) {
7996 if {![info exists idtags
($id)]} {
7997 set na
[lreplace
$na $i $i]
8004 proc validate_archeads
{a
} {
8005 global archeads idheads
8008 set na
$archeads($a)
8009 foreach id
$archeads($a) {
8011 if {![info exists idheads
($id)]} {
8012 set na
[lreplace
$na $i $i]
8016 set archeads
($a) $na
8019 # Return the list of IDs that have tags that are descendents of id,
8020 # ignoring IDs that are descendents of IDs already reported.
8021 proc desctags
{id
} {
8022 global arcnos arcstart arcids arctags idtags allparents
8023 global growing cached_dtags
8025 if {![info exists allparents
($id)]} {
8028 set t1
[clock clicks
-milliseconds]
8030 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8031 # part-way along an arc; check that arc first
8032 set a
[lindex
$arcnos($id) 0]
8033 if {$arctags($a) ne
{}} {
8035 set i
[lsearch
-exact $arcids($a) $id]
8037 foreach t
$arctags($a) {
8038 set j
[lsearch
-exact $arcids($a) $t]
8046 set id
$arcstart($a)
8047 if {[info exists idtags
($id)]} {
8051 if {[info exists cached_dtags
($id)]} {
8052 return $cached_dtags($id)
8059 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8060 set id
[lindex
$todo $i]
8062 set ta
[info exists hastaggedancestor
($id)]
8066 # ignore tags on starting node
8067 if {!$ta && $i > 0} {
8068 if {[info exists idtags
($id)]} {
8071 } elseif
{[info exists cached_dtags
($id)]} {
8072 set tagloc
($id) $cached_dtags($id)
8076 foreach a
$arcnos($id) {
8078 if {!$ta && $arctags($a) ne
{}} {
8080 if {$arctags($a) ne
{}} {
8081 lappend tagloc
($id) [lindex
$arctags($a) end
]
8084 if {$ta ||
$arctags($a) ne
{}} {
8085 set tomark
[list
$d]
8086 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8087 set dd [lindex
$tomark $j]
8088 if {![info exists hastaggedancestor
($dd)]} {
8089 if {[info exists
done($dd)]} {
8090 foreach b
$arcnos($dd) {
8091 lappend tomark
$arcstart($b)
8093 if {[info exists tagloc
($dd)]} {
8096 } elseif
{[info exists queued
($dd)]} {
8099 set hastaggedancestor
($dd) 1
8103 if {![info exists queued
($d)]} {
8106 if {![info exists hastaggedancestor
($d)]} {
8113 foreach id
[array names tagloc
] {
8114 if {![info exists hastaggedancestor
($id)]} {
8115 foreach t
$tagloc($id) {
8116 if {[lsearch
-exact $tags $t] < 0} {
8122 set t2
[clock clicks
-milliseconds]
8125 # remove tags that are descendents of other tags
8126 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8127 set a
[lindex
$tags $i]
8128 for {set j
0} {$j < $i} {incr j
} {
8129 set b
[lindex
$tags $j]
8130 set r
[anc_or_desc
$a $b]
8132 set tags
[lreplace
$tags $j $j]
8135 } elseif
{$r == -1} {
8136 set tags
[lreplace
$tags $i $i]
8143 if {[array names growing
] ne
{}} {
8144 # graph isn't finished, need to check if any tag could get
8145 # eclipsed by another tag coming later. Simply ignore any
8146 # tags that could later get eclipsed.
8149 if {[is_certain
$t $origid]} {
8153 if {$tags eq
$ctags} {
8154 set cached_dtags
($origid) $tags
8159 set cached_dtags
($origid) $tags
8161 set t3
[clock clicks
-milliseconds]
8162 if {0 && $t3 - $t1 >= 100} {
8163 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
8164 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8170 global arcnos arcids arcout arcend arctags idtags allparents
8171 global growing cached_atags
8173 if {![info exists allparents
($id)]} {
8176 set t1
[clock clicks
-milliseconds]
8178 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8179 # part-way along an arc; check that arc first
8180 set a
[lindex
$arcnos($id) 0]
8181 if {$arctags($a) ne
{}} {
8183 set i
[lsearch
-exact $arcids($a) $id]
8184 foreach t
$arctags($a) {
8185 set j
[lsearch
-exact $arcids($a) $t]
8191 if {![info exists arcend
($a)]} {
8195 if {[info exists idtags
($id)]} {
8199 if {[info exists cached_atags
($id)]} {
8200 return $cached_atags($id)
8208 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8209 set id
[lindex
$todo $i]
8211 set td
[info exists hastaggeddescendent
($id)]
8215 # ignore tags on starting node
8216 if {!$td && $i > 0} {
8217 if {[info exists idtags
($id)]} {
8220 } elseif
{[info exists cached_atags
($id)]} {
8221 set tagloc
($id) $cached_atags($id)
8225 foreach a
$arcout($id) {
8226 if {!$td && $arctags($a) ne
{}} {
8228 if {$arctags($a) ne
{}} {
8229 lappend tagloc
($id) [lindex
$arctags($a) 0]
8232 if {![info exists arcend
($a)]} continue
8234 if {$td ||
$arctags($a) ne
{}} {
8235 set tomark
[list
$d]
8236 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8237 set dd [lindex
$tomark $j]
8238 if {![info exists hastaggeddescendent
($dd)]} {
8239 if {[info exists
done($dd)]} {
8240 foreach b
$arcout($dd) {
8241 if {[info exists arcend
($b)]} {
8242 lappend tomark
$arcend($b)
8245 if {[info exists tagloc
($dd)]} {
8248 } elseif
{[info exists queued
($dd)]} {
8251 set hastaggeddescendent
($dd) 1
8255 if {![info exists queued
($d)]} {
8258 if {![info exists hastaggeddescendent
($d)]} {
8264 set t2
[clock clicks
-milliseconds]
8267 foreach id
[array names tagloc
] {
8268 if {![info exists hastaggeddescendent
($id)]} {
8269 foreach t
$tagloc($id) {
8270 if {[lsearch
-exact $tags $t] < 0} {
8277 # remove tags that are ancestors of other tags
8278 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8279 set a
[lindex
$tags $i]
8280 for {set j
0} {$j < $i} {incr j
} {
8281 set b
[lindex
$tags $j]
8282 set r
[anc_or_desc
$a $b]
8284 set tags
[lreplace
$tags $j $j]
8287 } elseif
{$r == 1} {
8288 set tags
[lreplace
$tags $i $i]
8295 if {[array names growing
] ne
{}} {
8296 # graph isn't finished, need to check if any tag could get
8297 # eclipsed by another tag coming later. Simply ignore any
8298 # tags that could later get eclipsed.
8301 if {[is_certain
$origid $t]} {
8305 if {$tags eq
$ctags} {
8306 set cached_atags
($origid) $tags
8311 set cached_atags
($origid) $tags
8313 set t3
[clock clicks
-milliseconds]
8314 if {0 && $t3 - $t1 >= 100} {
8315 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
8316 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8321 # Return the list of IDs that have heads that are descendents of id,
8322 # including id itself if it has a head.
8323 proc descheads
{id
} {
8324 global arcnos arcstart arcids archeads idheads cached_dheads
8327 if {![info exists allparents
($id)]} {
8331 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8332 # part-way along an arc; check it first
8333 set a
[lindex
$arcnos($id) 0]
8334 if {$archeads($a) ne
{}} {
8335 validate_archeads
$a
8336 set i
[lsearch
-exact $arcids($a) $id]
8337 foreach t
$archeads($a) {
8338 set j
[lsearch
-exact $arcids($a) $t]
8343 set id
$arcstart($a)
8349 for {set i
0} {$i < [llength
$todo]} {incr i
} {
8350 set id
[lindex
$todo $i]
8351 if {[info exists cached_dheads
($id)]} {
8352 set ret
[concat
$ret $cached_dheads($id)]
8354 if {[info exists idheads
($id)]} {
8357 foreach a
$arcnos($id) {
8358 if {$archeads($a) ne
{}} {
8359 validate_archeads
$a
8360 if {$archeads($a) ne
{}} {
8361 set ret
[concat
$ret $archeads($a)]
8365 if {![info exists seen
($d)]} {
8372 set ret
[lsort
-unique $ret]
8373 set cached_dheads
($origid) $ret
8374 return [concat
$ret $aret]
8377 proc addedtag
{id
} {
8378 global arcnos arcout cached_dtags cached_atags
8380 if {![info exists arcnos
($id)]} return
8381 if {![info exists arcout
($id)]} {
8382 recalcarc
[lindex
$arcnos($id) 0]
8384 catch
{unset cached_dtags
}
8385 catch
{unset cached_atags
}
8388 proc addedhead
{hid
head} {
8389 global arcnos arcout cached_dheads
8391 if {![info exists arcnos
($hid)]} return
8392 if {![info exists arcout
($hid)]} {
8393 recalcarc
[lindex
$arcnos($hid) 0]
8395 catch
{unset cached_dheads
}
8398 proc removedhead
{hid
head} {
8399 global cached_dheads
8401 catch
{unset cached_dheads
}
8404 proc movedhead
{hid
head} {
8405 global arcnos arcout cached_dheads
8407 if {![info exists arcnos
($hid)]} return
8408 if {![info exists arcout
($hid)]} {
8409 recalcarc
[lindex
$arcnos($hid) 0]
8411 catch
{unset cached_dheads
}
8414 proc changedrefs
{} {
8415 global cached_dheads cached_dtags cached_atags
8416 global arctags archeads arcnos arcout idheads idtags
8418 foreach id
[concat
[array names idheads
] [array names idtags
]] {
8419 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
8420 set a
[lindex
$arcnos($id) 0]
8421 if {![info exists donearc
($a)]} {
8427 catch
{unset cached_dtags
}
8428 catch
{unset cached_atags
}
8429 catch
{unset cached_dheads
}
8432 proc rereadrefs
{} {
8433 global idtags idheads idotherrefs mainheadid
8435 set refids
[concat
[array names idtags
] \
8436 [array names idheads
] [array names idotherrefs
]]
8437 foreach id
$refids {
8438 if {![info exists ref
($id)]} {
8439 set ref
($id) [listrefs
$id]
8442 set oldmainhead
$mainheadid
8445 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
8446 [array names idheads
] [array names idotherrefs
]]]
8447 foreach id
$refids {
8448 set v
[listrefs
$id]
8449 if {![info exists ref
($id)] ||
$ref($id) != $v ||
8450 ($id eq
$oldmainhead && $id ne
$mainheadid) ||
8451 ($id eq
$mainheadid && $id ne
$oldmainhead)} {
8458 proc listrefs
{id
} {
8459 global idtags idheads idotherrefs
8462 if {[info exists idtags
($id)]} {
8466 if {[info exists idheads
($id)]} {
8470 if {[info exists idotherrefs
($id)]} {
8471 set z
$idotherrefs($id)
8473 return [list
$x $y $z]
8476 proc showtag
{tag isnew
} {
8477 global ctext tagcontents tagids linknum tagobjid
8480 addtohistory
[list showtag
$tag 0]
8482 $ctext conf
-state normal
8486 if {![info exists tagcontents
($tag)]} {
8488 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
8491 if {[info exists tagcontents
($tag)]} {
8492 set text
$tagcontents($tag)
8494 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
8496 appendwithlinks
$text {}
8497 $ctext conf
-state disabled
8508 proc mkfontdisp
{font top
which} {
8509 global fontattr fontpref
$font
8511 set fontpref
($font) [set $font]
8512 button
$top.
${font}but
-text $which -font optionfont \
8513 -command [list choosefont
$font $which]
8514 label
$top.
$font -relief flat
-font $font \
8515 -text $fontattr($font,family
) -justify left
8516 grid x
$top.
${font}but
$top.
$font -sticky w
8519 proc choosefont
{font
which} {
8520 global fontparam fontlist fonttop fontattr
8522 set fontparam
(which) $which
8523 set fontparam
(font
) $font
8524 set fontparam
(family
) [font actual
$font -family]
8525 set fontparam
(size
) $fontattr($font,size
)
8526 set fontparam
(weight
) $fontattr($font,weight
)
8527 set fontparam
(slant
) $fontattr($font,slant
)
8530 if {![winfo exists
$top]} {
8532 eval font config sample
[font actual
$font]
8534 wm title
$top [mc
"Gitk font chooser"]
8535 label
$top.l
-textvariable fontparam
(which)
8536 pack
$top.l
-side top
8537 set fontlist
[lsort
[font families
]]
8539 listbox
$top.f.fam
-listvariable fontlist \
8540 -yscrollcommand [list
$top.f.sb
set]
8541 bind $top.f.fam
<<ListboxSelect>> selfontfam
8542 scrollbar $top.f.sb -command [list $top.f.fam yview]
8543 pack $top.f.sb -side right -fill y
8544 pack $top.f.fam -side left -fill both -expand 1
8545 pack $top.f -side top -fill both -expand 1
8547 spinbox $top.g.size -from 4 -to 40 -width 4 \
8548 -textvariable fontparam(size) \
8549 -validatecommand {string is integer -strict %s}
8550 checkbutton $top.g.bold -padx 5 \
8551 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8552 -variable fontparam(weight) -onvalue bold -offvalue normal
8553 checkbutton $top.g.ital -padx 5 \
8554 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8555 -variable fontparam(slant) -onvalue italic -offvalue roman
8556 pack $top.g.size $top.g.bold $top.g.ital -side left
8557 pack $top.g -side top
8558 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8560 $top.c create text 100 25 -anchor center -text $which -font sample \
8561 -fill black -tags text
8562 bind $top.c <Configure> [list centertext $top.c]
8563 pack $top.c -side top -fill x
8565 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8566 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8567 grid $top.buts.ok $top.buts.can
8568 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8569 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8570 pack $top.buts -side bottom -fill x
8571 trace add variable fontparam write chg_fontparam
8574 $top.c itemconf text -text $which
8576 set i [lsearch -exact $fontlist $fontparam(family)]
8578 $top.f.fam selection set $i
8583 proc centertext {w} {
8584 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8588 global fontparam fontpref prefstop
8590 set f $fontparam(font)
8591 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8592 if {$fontparam(weight) eq "bold"} {
8593 lappend fontpref($f) "bold"
8595 if {$fontparam(slant) eq "italic"} {
8596 lappend fontpref($f) "italic"
8599 $w conf -text $fontparam(family) -font $fontpref($f)
8605 global fonttop fontparam
8607 if {[info exists fonttop]} {
8608 catch {destroy $fonttop}
8609 catch {font delete sample}
8615 proc selfontfam {} {
8616 global fonttop fontparam
8618 set i [$fonttop.f.fam curselection]
8620 set fontparam(family) [$fonttop.f.fam get $i]
8624 proc chg_fontparam {v sub op} {
8627 font config sample -$sub $fontparam($sub)
8631 global maxwidth maxgraphpct
8632 global oldprefs prefstop showneartags showlocalchanges
8633 global bgcolor fgcolor ctext diffcolors selectbgcolor
8634 global tabstop limitdiffs
8638 if {[winfo exists $top]} {
8642 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8643 limitdiffs tabstop} {
8644 set oldprefs($v) [set $v]
8647 wm title $top [mc "Gitk preferences"]
8648 label $top.ldisp -text [mc "Commit list display options"]
8649 grid $top.ldisp - -sticky w -pady 10
8650 label $top.spacer -text " "
8651 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8653 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8654 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8655 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8657 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8658 grid x $top.maxpctl $top.maxpct -sticky w
8659 frame $top.showlocal
8660 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8661 checkbutton $top.showlocal.b -variable showlocalchanges
8662 pack $top.showlocal.b $top.showlocal.l -side left
8663 grid x $top.showlocal -sticky w
8665 label $top.ddisp -text [mc "Diff display options"]
8666 grid $top.ddisp - -sticky w -pady 10
8667 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8668 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8669 grid x $top.tabstopl $top.tabstop -sticky w
8671 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8672 checkbutton $top.ntag.b -variable showneartags
8673 pack $top.ntag.b $top.ntag.l -side left
8674 grid x $top.ntag -sticky w
8676 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8677 checkbutton $top.ldiff.b -variable limitdiffs
8678 pack $top.ldiff.b $top.ldiff.l -side left
8679 grid x $top.ldiff -sticky w
8681 label $top.cdisp -text [mc "Colors: press to choose"]
8682 grid $top.cdisp - -sticky w -pady 10
8683 label $top.bg -padx 40 -relief sunk -background $bgcolor
8684 button $top.bgbut -text [mc "Background"] -font optionfont \
8685 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8686 grid x $top.bgbut $top.bg -sticky w
8687 label $top.fg -padx 40 -relief sunk -background $fgcolor
8688 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8689 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8690 grid x $top.fgbut $top.fg -sticky w
8691 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8692 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8693 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8694 [list $ctext tag conf d0 -foreground]]
8695 grid x $top.diffoldbut $top.diffold -sticky w
8696 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8697 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8698 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8699 [list $ctext tag conf d1 -foreground]]
8700 grid x $top.diffnewbut $top.diffnew -sticky w
8701 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8702 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8703 -command [list choosecolor diffcolors 2 $top.hunksep \
8704 "diff hunk header" \
8705 [list $ctext tag conf hunksep -foreground]]
8706 grid x $top.hunksepbut $top.hunksep -sticky w
8707 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8708 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8709 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8710 grid x $top.selbgbut $top.selbgsep -sticky w
8712 label $top.cfont -text [mc "Fonts: press to choose"]
8713 grid $top.cfont - -sticky w -pady 10
8714 mkfontdisp mainfont $top [mc "Main font"]
8715 mkfontdisp textfont $top [mc "Diff display font"]
8716 mkfontdisp uifont $top [mc "User interface font"]
8719 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8720 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8721 grid $top.buts.ok $top.buts.can
8722 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8723 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8724 grid $top.buts - - -pady 10 -sticky ew
8725 bind $top <Visibility> "focus $top.buts.ok"
8728 proc choosecolor {v vi w x cmd} {
8731 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8732 -title [mc "Gitk: choose color for %s" $x]]
8733 if {$c eq {}} return
8734 $w conf -background $c
8740 global bglist cflist
8742 $w configure -selectbackground $c
8744 $cflist tag configure highlight \
8745 -background [$cflist cget -selectbackground]
8746 allcanvs itemconf secsel -fill $c
8753 $w conf -background $c
8761 $w conf -foreground $c
8763 allcanvs itemconf text -fill $c
8764 $canv itemconf circle -outline $c
8768 global oldprefs prefstop
8770 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8771 limitdiffs tabstop} {
8773 set $v $oldprefs($v)
8775 catch {destroy $prefstop}
8781 global maxwidth maxgraphpct
8782 global oldprefs prefstop showneartags showlocalchanges
8783 global fontpref mainfont textfont uifont
8784 global limitdiffs treediffs
8786 catch {destroy $prefstop}
8790 if {$mainfont ne $fontpref(mainfont)} {
8791 set mainfont $fontpref(mainfont)
8792 parsefont mainfont $mainfont
8793 eval font configure mainfont [fontflags mainfont]
8794 eval font configure mainfontbold [fontflags mainfont 1]
8798 if {$textfont ne $fontpref(textfont)} {
8799 set textfont $fontpref(textfont)
8800 parsefont textfont $textfont
8801 eval font configure textfont [fontflags textfont]
8802 eval font configure textfontbold [fontflags textfont 1]
8804 if {$uifont ne $fontpref(uifont)} {
8805 set uifont $fontpref(uifont)
8806 parsefont uifont $uifont
8807 eval font configure uifont [fontflags uifont]
8810 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8811 if {$showlocalchanges} {
8817 if {$limitdiffs != $oldprefs(limitdiffs)} {
8818 # treediffs elements are limited by path
8819 catch {unset treediffs}
8821 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8822 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8824 } elseif {$showneartags != $oldprefs(showneartags) ||
8825 $limitdiffs != $oldprefs(limitdiffs)} {
8830 proc formatdate {d} {
8831 global datetimeformat
8833 set d [clock format $d -format $datetimeformat]
8838 # This list of encoding names and aliases is distilled from
8839 # http://www.iana.org/assignments/character-sets.
8840 # Not all of them are supported by Tcl.
8841 set encoding_aliases {
8842 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8843 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8844 { ISO-10646-UTF-1 csISO10646UTF1 }
8845 { ISO_646.basic:1983 ref csISO646basic1983 }
8846 { INVARIANT csINVARIANT }
8847 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8848 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8849 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8850 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8851 { NATS-DANO iso-ir-9-1 csNATSDANO }
8852 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8853 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8854 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8855 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8856 { ISO-2022-KR csISO2022KR }
8858 { ISO-2022-JP csISO2022JP }
8859 { ISO-2022-JP-2 csISO2022JP2 }
8860 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8862 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8863 { IT iso-ir-15 ISO646-IT csISO15Italian }
8864 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8865 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8866 { greek7-old iso-ir-18 csISO18Greek7Old }
8867 { latin-greek iso-ir-19 csISO19LatinGreek }
8868 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8869 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8870 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8871 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8872 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8873 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8874 { INIS iso-ir-49 csISO49INIS }
8875 { INIS-8 iso-ir-50 csISO50INIS8 }
8876 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8877 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8878 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8879 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8880 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8881 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8883 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8884 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8885 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8886 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8887 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8888 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8889 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8890 { greek7 iso-ir-88 csISO88Greek7 }
8891 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8892 { iso-ir-90 csISO90 }
8893 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8894 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8895 csISO92JISC62991984b }
8896 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8897 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8898 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8899 csISO95JIS62291984handadd }
8900 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8901 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8902 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8903 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8905 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8906 { T.61-7bit iso-ir-102 csISO102T617bit }
8907 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8908 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8909 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8910 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8911 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8912 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8913 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8914 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8915 arabic csISOLatinArabic }
8916 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8917 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8918 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8919 greek greek8 csISOLatinGreek }
8920 { T.101-G2 iso-ir-128 csISO128T101G2 }
8921 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8923 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8924 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8925 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8926 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8927 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8928 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8929 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8930 csISOLatinCyrillic }
8931 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8932 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8933 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8934 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8935 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8936 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8937 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8938 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8939 { ISO_10367-box iso-ir-155 csISO10367Box }
8940 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8941 { latin-lap lap iso-ir-158 csISO158Lap }
8942 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8943 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8946 { JIS_X0201 X0201 csHalfWidthKatakana }
8947 { KSC5636 ISO646-KR csKSC5636 }
8948 { ISO-10646-UCS-2 csUnicode }
8949 { ISO-10646-UCS-4 csUCS4 }
8950 { DEC-MCS dec csDECMCS }
8951 { hp-roman8 roman8 r8 csHPRoman8 }
8952 { macintosh mac csMacintosh }
8953 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8955 { IBM038 EBCDIC-INT cp038 csIBM038 }
8956 { IBM273 CP273 csIBM273 }
8957 { IBM274 EBCDIC-BE CP274 csIBM274 }
8958 { IBM275 EBCDIC-BR cp275 csIBM275 }
8959 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8960 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8961 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8962 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8963 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8964 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8965 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8966 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8967 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8968 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8969 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8970 { IBM437 cp437 437 csPC8CodePage437 }
8971 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8972 { IBM775 cp775 csPC775Baltic }
8973 { IBM850 cp850 850 csPC850Multilingual }
8974 { IBM851 cp851 851 csIBM851 }
8975 { IBM852 cp852 852 csPCp852 }
8976 { IBM855 cp855 855 csIBM855 }
8977 { IBM857 cp857 857 csIBM857 }
8978 { IBM860 cp860 860 csIBM860 }
8979 { IBM861 cp861 861 cp-is csIBM861 }
8980 { IBM862 cp862 862 csPC862LatinHebrew }
8981 { IBM863 cp863 863 csIBM863 }
8982 { IBM864 cp864 csIBM864 }
8983 { IBM865 cp865 865 csIBM865 }
8984 { IBM866 cp866 866 csIBM866 }
8985 { IBM868 CP868 cp-ar csIBM868 }
8986 { IBM869 cp869 869 cp-gr csIBM869 }
8987 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8988 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8989 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8990 { IBM891 cp891 csIBM891 }
8991 { IBM903 cp903 csIBM903 }
8992 { IBM904 cp904 904 csIBBM904 }
8993 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8994 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8995 { IBM1026 CP1026 csIBM1026 }
8996 { EBCDIC-AT-DE csIBMEBCDICATDE }
8997 { EBCDIC-AT-DE-A csEBCDICATDEA }
8998 { EBCDIC-CA-FR csEBCDICCAFR }
8999 { EBCDIC-DK-NO csEBCDICDKNO }
9000 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9001 { EBCDIC-FI-SE csEBCDICFISE }
9002 { EBCDIC-FI-SE-A csEBCDICFISEA }
9003 { EBCDIC-FR csEBCDICFR }
9004 { EBCDIC-IT csEBCDICIT }
9005 { EBCDIC-PT csEBCDICPT }
9006 { EBCDIC-ES csEBCDICES }
9007 { EBCDIC-ES-A csEBCDICESA }
9008 { EBCDIC-ES-S csEBCDICESS }
9009 { EBCDIC-UK csEBCDICUK }
9010 { EBCDIC-US csEBCDICUS }
9011 { UNKNOWN-8BIT csUnknown8BiT }
9012 { MNEMONIC csMnemonic }
9017 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9018 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9019 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9020 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9021 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9022 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9023 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9024 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9025 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9026 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9027 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9028 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9029 { IBM1047 IBM-1047 }
9030 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9031 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9032 { UNICODE-1-1 csUnicode11 }
9035 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9036 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9038 { ISO-8859-15 ISO_8859-15 Latin-9 }
9039 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9040 { GBK CP936 MS936 windows-936 }
9041 { JIS_Encoding csJISEncoding }
9042 { Shift_JIS MS_Kanji csShiftJIS }
9043 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9045 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9046 { ISO-10646-UCS-Basic csUnicodeASCII }
9047 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9048 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9049 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9050 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9051 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9052 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9053 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9054 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9055 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9056 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9057 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9058 { Ventura-US csVenturaUS }
9059 { Ventura-International csVenturaInternational }
9060 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9061 { PC8-Turkish csPC8Turkish }
9062 { IBM-Symbols csIBMSymbols }
9063 { IBM-Thai csIBMThai }
9064 { HP-Legal csHPLegal }
9065 { HP-Pi-font csHPPiFont }
9066 { HP-Math8 csHPMath8 }
9067 { Adobe-Symbol-Encoding csHPPSMath }
9068 { HP-DeskTop csHPDesktop }
9069 { Ventura-Math csVenturaMath }
9070 { Microsoft-Publishing csMicrosoftPublishing }
9071 { Windows-31J csWindows31J }
9076 proc tcl_encoding {enc} {
9077 global encoding_aliases
9078 set names [encoding names]
9079 set lcnames [string tolower $names]
9080 set enc [string tolower $enc]
9081 set i [lsearch -exact $lcnames $enc]
9083 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9084 if {[regsub {^iso[-_]} $enc iso encx]} {
9085 set i [lsearch -exact $lcnames $encx]
9089 foreach l $encoding_aliases {
9090 set ll [string tolower $l]
9091 if {[lsearch -exact $ll $enc] < 0} continue
9092 # look through the aliases for one that tcl knows about
9094 set i [lsearch -exact $lcnames $e]
9096 if {[regsub {^iso[-_]} $e iso ex]} {
9097 set i [lsearch -exact $lcnames $ex]
9106 return [lindex $names $i]
9111 # First check that Tcl/Tk is recent enough
9112 if {[catch {package require Tk 8.4} err]} {
9113 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9114 Gitk requires at least Tcl/Tk 8.4."]
9120 set wrcomcmd "git diff-tree --stdin -p --pretty"
9124 set gitencoding [exec git config --get i18n.commitencoding]
9126 if {$gitencoding == ""} {
9127 set gitencoding "utf-8"
9129 set tclencoding [tcl_encoding $gitencoding]
9130 if {$tclencoding == {}} {
9131 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9134 set mainfont {Helvetica 9}
9135 set textfont {Courier 9}
9136 set uifont {Helvetica 9 bold}
9138 set findmergefiles 0
9146 set cmitmode "patch"
9147 set wrapcomment "none"
9151 set showlocalchanges 1
9153 set datetimeformat "%Y-%m-%d %H:%M:%S"
9155 set colors {green red blue magenta darkgrey brown orange}
9158 set diffcolors {red "#00a000" blue}
9160 set selectbgcolor gray85
9162 ## For msgcat loading, first locate the installation location.
9163 if { [info exists ::env(GITK_MSGSDIR)] } {
9164 ## Msgsdir was manually set in the environment.
9165 set gitk_msgsdir $::env(GITK_MSGSDIR)
9167 ## Let's guess the prefix from argv0.
9168 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9169 set gitk_libdir [file join $gitk_prefix share gitk lib]
9170 set gitk_msgsdir [file join $gitk_libdir msgs]
9174 ## Internationalization (i18n) through msgcat and gettext. See
9175 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9176 package require msgcat
9177 namespace import ::msgcat::mc
9178 ## And eventually load the actual message catalog
9179 ::msgcat::mcload $gitk_msgsdir
9181 catch {source ~/.gitk}
9183 font create optionfont -family sans-serif -size -12
9185 parsefont mainfont $mainfont
9186 eval font create mainfont [fontflags mainfont]
9187 eval font create mainfontbold [fontflags mainfont 1]
9189 parsefont textfont $textfont
9190 eval font create textfont [fontflags textfont]
9191 eval font create textfontbold [fontflags textfont 1]
9193 parsefont uifont $uifont
9194 eval font create uifont [fontflags uifont]
9198 # check that we can find a .git directory somewhere...
9199 if {[catch {set gitdir [gitdir]}]} {
9200 show_error {} . [mc "Cannot find a git repository here."]
9203 if {![file isdirectory $gitdir]} {
9204 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9210 set cmdline_files {}
9215 "-d" { set datemode 1 }
9218 lappend revtreeargs $arg
9221 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9225 lappend revtreeargs $arg
9231 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9232 # no -- on command line, but some arguments (other than -d)
9234 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9235 set cmdline_files [split $f "\n"]
9236 set n [llength $cmdline_files]
9237 set revtreeargs [lrange $revtreeargs 0 end-$n]
9238 # Unfortunately git rev-parse doesn't produce an error when
9239 # something is both a revision and a filename. To be consistent
9240 # with git log and git rev-list, check revtreeargs for filenames.
9241 foreach arg $revtreeargs {
9242 if {[file exists $arg]} {
9243 show_error {} . [mc "Ambiguous argument '%s': both revision\
9249 # unfortunately we get both stdout and stderr in $err,
9250 # so look for "fatal:".
9251 set i [string first "fatal:" $err]
9253 set err [string range $err [expr {$i + 6}] end]
9255 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9261 # find the list of unmerged files
9265 set fd [open "| git ls-files -u" r]
9267 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9270 while {[gets $fd line] >= 0} {
9271 set i [string first "\t" $line]
9272 if {$i < 0} continue
9273 set fname [string range $line [expr {$i+1}] end]
9274 if {[lsearch -exact $mlist $fname] >= 0} continue
9276 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9277 lappend mlist $fname
9282 if {$nr_unmerged == 0} {
9283 show_error {} . [mc "No files selected: --merge specified but\
9284 no files are unmerged."]
9286 show_error {} . [mc "No files selected: --merge specified but\
9287 no unmerged files are within file limit."]
9291 set cmdline_files $mlist
9294 set nullid "0000000000000000000000000000000000000000"
9295 set nullid2 "0000000000000000000000000000000000000001"
9297 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9304 set highlight_paths {}
9306 set searchdirn -forwards
9310 set markingmatches 0
9311 set linkentercount 0
9312 set need_redisplay 0
9319 set selectedhlview [mc "None"]
9320 set highlight_related [mc "None"]
9321 set highlight_files {}
9334 # wait for the window to become visible
9336 wm title . "[file tail $argv0]: [file tail [pwd]]"
9339 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9340 # create a view for the files/dirs specified on the command line
9344 set viewname(1) [mc "Command line"]
9345 set viewfiles(1) $cmdline_files
9346 set viewargs(1) $revtreeargs
9349 .bar.view entryconf [mc "Edit view..."] -state normal
9350 .bar.view entryconf [mc "Delete view"] -state normal
9353 if {[info exists permviews]} {
9354 foreach v $permviews {
9357 set viewname($n) [lindex $v 0]
9358 set viewfiles($n) [lindex $v 1]
9359 set viewargs($n) [lindex $v 2]