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
102 set startmsecs
[clock clicks
-milliseconds]
103 set commitidx
($view) 0
104 set viewcomplete
($view) 0
105 set viewactive
($view) 1
106 set vnextroot
($view) 0
109 set commits
[eval exec git rev-parse
--default HEAD
--revs-only \
111 set viewincl
($view) {}
113 if {[regexp
{^
[0-9a-fA-F]{40}$
} $c]} {
114 lappend viewincl
($view) $c
118 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
119 --boundary $commits "--" $viewfiles($view)] r
]
121 error_popup
"[mc "Error executing git log
:"] $err"
124 set i
[incr loginstance
]
125 set viewinstances
($view) [list
$i]
128 if {$showlocalchanges} {
129 lappend commitinterest
($mainheadid) {dodiffindex
}
131 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
132 if {$tclencoding != {}} {
133 fconfigure
$fd -encoding $tclencoding
135 filerun
$fd [list getcommitlines
$fd $i $view]
136 nowbusy
$view [mc
"Reading"]
137 if {$view == $curview} {
139 set progresscoords
{0 0}
144 proc stop_rev_list
{view
} {
145 global commfd viewinstances leftover
147 foreach inst
$viewinstances($view) {
148 set fd
$commfd($inst)
156 unset leftover
($inst)
158 set viewinstances
($view) {}
165 start_rev_list
$curview
166 show_status
[mc
"Reading commits..."]
169 proc updatecommits
{} {
170 global curview viewargs viewfiles viewincl viewinstances
171 global viewactive viewcomplete loginstance tclencoding mainheadid
172 global varcid startmsecs commfd showneartags showlocalchanges leftover
175 set oldmainid
$mainheadid
177 if {$showlocalchanges} {
178 if {$mainheadid ne
$oldmainid} {
181 if {[commitinview
$mainheadid $curview]} {
186 set commits
[exec git rev-parse
--default HEAD
--revs-only \
192 if {[string match
"^*" $c]} {
194 } elseif
{[regexp
{^
[0-9a-fA-F]{40}$
} $c]} {
195 if {!([info exists varcid
($view,$c)] ||
196 [lsearch
-exact $viewincl($view) $c] >= 0)} {
206 foreach id
$viewincl($view) {
209 set viewincl
($view) [concat
$viewincl($view) $pos]
211 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
212 --boundary $pos $neg $flags "--" $viewfiles($view)] r
]
214 error_popup
"Error executing git log: $err"
217 if {$viewactive($view) == 0} {
218 set startmsecs
[clock clicks
-milliseconds]
220 set i
[incr loginstance
]
221 lappend viewinstances
($view) $i
224 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
225 if {$tclencoding != {}} {
226 fconfigure
$fd -encoding $tclencoding
228 filerun
$fd [list getcommitlines
$fd $i $view]
229 incr viewactive
($view)
230 set viewcomplete
($view) 0
231 nowbusy
$view "Reading"
237 proc reloadcommits
{} {
238 global curview viewcomplete selectedline currentid thickerline
239 global showneartags treediffs commitinterest cached_commitrow
240 global progresscoords targetid
242 if {!$viewcomplete($curview)} {
243 stop_rev_list
$curview
244 set progresscoords
{0 0}
248 catch
{unset selectedline
}
249 catch
{unset currentid
}
250 catch
{unset thickerline
}
251 catch
{unset treediffs
}
258 catch
{unset commitinterest
}
259 catch
{unset cached_commitrow
}
260 catch
{unset targetid
}
265 # This makes a string representation of a positive integer which
266 # sorts as a string in numerical order
269 return [format
"%x" $n]
270 } elseif
{$n < 256} {
271 return [format
"x%.2x" $n]
272 } elseif
{$n < 65536} {
273 return [format
"y%.4x" $n]
275 return [format
"z%.8x" $n]
278 # Procedures used in reordering commits from git log (without
279 # --topo-order) into the order for display.
281 proc varcinit
{view
} {
282 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
283 global vtokmod varcmod vrowmod varcix vlastins
285 set varcstart
($view) {{}}
286 set vupptr
($view) {0}
287 set vdownptr
($view) {0}
288 set vleftptr
($view) {0}
289 set vbackptr
($view) {0}
290 set varctok
($view) {{}}
291 set varcrow
($view) {{}}
292 set vtokmod
($view) {}
295 set varcix
($view) {{}}
296 set vlastins
($view) {0}
299 proc resetvarcs
{view
} {
300 global varcid varccommits parents children vseedcount ordertok
302 foreach vid
[array names varcid
$view,*] {
307 # some commits might have children but haven't been seen yet
308 foreach vid
[array names children
$view,*] {
311 foreach va
[array names varccommits
$view,*] {
312 unset varccommits
($va)
314 foreach vd
[array names vseedcount
$view,*] {
315 unset vseedcount
($vd)
317 catch
{unset ordertok
}
320 proc newvarc
{view id
} {
321 global varcid varctok parents children datemode
322 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
323 global commitdata commitinfo vseedcount varccommits vlastins
325 set a
[llength
$varctok($view)]
327 if {[llength
$children($vid)] == 0 ||
$datemode} {
328 if {![info exists commitinfo
($id)]} {
329 parsecommit
$id $commitdata($id) 1
331 set cdate
[lindex
$commitinfo($id) 4]
332 if {![string is integer
-strict $cdate]} {
335 if {![info exists vseedcount
($view,$cdate)]} {
336 set vseedcount
($view,$cdate) -1
338 set c
[incr vseedcount
($view,$cdate)]
339 set cdate
[expr {$cdate ^
0xffffffff}]
340 set tok
"s[strrep $cdate][strrep $c]"
345 if {[llength
$children($vid)] > 0} {
346 set kid
[lindex
$children($vid) end
]
347 set k
$varcid($view,$kid)
348 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
351 set tok
[lindex
$varctok($view) $k]
355 set i
[lsearch
-exact $parents($view,$ki) $id]
356 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
357 append tok
[strrep
$j]
359 set c
[lindex
$vlastins($view) $ka]
360 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
362 set b
[lindex
$vdownptr($view) $ka]
364 set b
[lindex
$vleftptr($view) $c]
366 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
368 set b
[lindex
$vleftptr($view) $c]
371 lset vdownptr
($view) $ka $a
372 lappend vbackptr
($view) 0
374 lset vleftptr
($view) $c $a
375 lappend vbackptr
($view) $c
377 lset vlastins
($view) $ka $a
378 lappend vupptr
($view) $ka
379 lappend vleftptr
($view) $b
381 lset vbackptr
($view) $b $a
383 lappend varctok
($view) $tok
384 lappend varcstart
($view) $id
385 lappend vdownptr
($view) 0
386 lappend varcrow
($view) {}
387 lappend varcix
($view) {}
388 set varccommits
($view,$a) {}
389 lappend vlastins
($view) 0
393 proc splitvarc
{p v
} {
394 global varcid varcstart varccommits varctok
395 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
397 set oa
$varcid($v,$p)
398 set ac
$varccommits($v,$oa)
399 set i
[lsearch
-exact $varccommits($v,$oa) $p]
401 set na
[llength
$varctok($v)]
402 # "%" sorts before "0"...
403 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
404 lappend varctok
($v) $tok
405 lappend varcrow
($v) {}
406 lappend varcix
($v) {}
407 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
408 set varccommits
($v,$na) [lrange
$ac $i end
]
409 lappend varcstart
($v) $p
410 foreach id
$varccommits($v,$na) {
411 set varcid
($v,$id) $na
413 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
414 lset vdownptr
($v) $oa $na
415 lappend vupptr
($v) $oa
416 lappend vleftptr
($v) 0
417 lappend vbackptr
($v) 0
418 lappend vlastins
($v) 0
419 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
420 lset vupptr
($v) $b $na
424 proc renumbervarc
{a v
} {
425 global parents children varctok varcstart varccommits
426 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
428 set t1
[clock clicks
-milliseconds]
434 if {[info exists isrelated
($a)]} {
436 set id
[lindex
$varccommits($v,$a) end
]
437 foreach p
$parents($v,$id) {
438 if {[info exists varcid
($v,$p)]} {
439 set isrelated
($varcid($v,$p)) 1
444 set b
[lindex
$vdownptr($v) $a]
447 set b
[lindex
$vleftptr($v) $a]
449 set a
[lindex
$vupptr($v) $a]
455 if {![info exists kidchanged
($a)]} continue
456 set id
[lindex
$varcstart($v) $a]
457 if {[llength
$children($v,$id)] > 1} {
458 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
461 set oldtok
[lindex
$varctok($v) $a]
468 set kid
[last_real_child
$v,$id]
470 set k
$varcid($v,$kid)
471 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
474 set tok
[lindex
$varctok($v) $k]
478 set i
[lsearch
-exact $parents($v,$ki) $id]
479 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
480 append tok
[strrep
$j]
482 if {$tok eq
$oldtok} {
485 set id
[lindex
$varccommits($v,$a) end
]
486 foreach p
$parents($v,$id) {
487 if {[info exists varcid
($v,$p)]} {
488 set kidchanged
($varcid($v,$p)) 1
493 lset varctok
($v) $a $tok
494 set b
[lindex
$vupptr($v) $a]
496 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
499 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
502 set c
[lindex
$vbackptr($v) $a]
503 set d
[lindex
$vleftptr($v) $a]
505 lset vdownptr
($v) $b $d
507 lset vleftptr
($v) $c $d
510 lset vbackptr
($v) $d $c
512 lset vupptr
($v) $a $ka
513 set c
[lindex
$vlastins($v) $ka]
515 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
517 set b
[lindex
$vdownptr($v) $ka]
519 set b
[lindex
$vleftptr($v) $c]
522 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
524 set b
[lindex
$vleftptr($v) $c]
527 lset vdownptr
($v) $ka $a
528 lset vbackptr
($v) $a 0
530 lset vleftptr
($v) $c $a
531 lset vbackptr
($v) $a $c
533 lset vleftptr
($v) $a $b
535 lset vbackptr
($v) $b $a
537 lset vlastins
($v) $ka $a
540 foreach id
[array names sortkids
] {
541 if {[llength
$children($v,$id)] > 1} {
542 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
546 set t2
[clock clicks
-milliseconds]
547 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
550 proc fix_reversal
{p a v
} {
551 global varcid varcstart varctok vupptr
553 set pa
$varcid($v,$p)
554 if {$p ne
[lindex
$varcstart($v) $pa]} {
556 set pa
$varcid($v,$p)
558 # seeds always need to be renumbered
559 if {[lindex
$vupptr($v) $pa] == 0 ||
560 [string compare
[lindex
$varctok($v) $a] \
561 [lindex
$varctok($v) $pa]] > 0} {
566 proc insertrow
{id p v
} {
567 global varcid varccommits parents children cmitlisted
568 global commitidx varctok vtokmod targetid targetrow
571 set i
[lsearch
-exact $varccommits($v,$a) $p]
573 puts
"oops: insertrow can't find [shortids $p] on arc $a"
576 set children
($v,$id) {}
577 set parents
($v,$id) [list
$p]
578 set varcid
($v,$id) $a
579 lappend children
($v,$p) $id
580 set cmitlisted
($v,$id) 1
582 # note we deliberately don't update varcstart($v) even if $i == 0
583 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
584 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
587 if {[info exists targetid
]} {
588 if {![comes_before
$targetid $p]} {
595 proc removerow
{id v
} {
596 global varcid varccommits parents children commitidx
597 global varctok vtokmod cmitlisted currentid selectedline
600 if {[llength
$parents($v,$id)] != 1} {
601 puts
"oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
604 set p
[lindex
$parents($v,$id) 0]
605 set a
$varcid($v,$id)
606 set i
[lsearch
-exact $varccommits($v,$a) $id]
608 puts
"oops: removerow can't find [shortids $id] on arc $a"
612 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
613 unset parents
($v,$id)
614 unset children
($v,$id)
615 unset cmitlisted
($v,$id)
616 incr commitidx
($v) -1
617 set j
[lsearch
-exact $children($v,$p) $id]
619 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
621 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
624 if {[info exist currentid
] && $id eq
$currentid} {
628 if {[info exists targetid
] && $targetid eq
$id} {
634 proc first_real_child
{vp
} {
635 global children nullid nullid2
637 foreach id
$children($vp) {
638 if {$id ne
$nullid && $id ne
$nullid2} {
645 proc last_real_child
{vp
} {
646 global children nullid nullid2
648 set kids
$children($vp)
649 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
650 set id
[lindex
$kids $i]
651 if {$id ne
$nullid && $id ne
$nullid2} {
658 proc vtokcmp
{v a b
} {
659 global varctok varcid
661 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
662 [lindex
$varctok($v) $varcid($v,$b)]]
665 proc modify_arc
{v a
{lim
{}}} {
666 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
668 set vtokmod
($v) [lindex
$varctok($v) $a]
670 if {$v == $curview} {
671 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
672 set a
[lindex
$vupptr($v) $a]
678 set lim
[llength
$varccommits($v,$a)]
680 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
687 proc update_arcrows
{v
} {
688 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
689 global varcid vrownum varcorder varcix varccommits
690 global vupptr vdownptr vleftptr varctok
691 global displayorder parentlist curview cached_commitrow
693 set narctot
[expr {[llength
$varctok($v)] - 1}]
695 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
696 # go up the tree until we find something that has a row number,
697 # or we get to a seed
698 set a
[lindex
$vupptr($v) $a]
701 set a
[lindex
$vdownptr($v) 0]
704 set varcorder
($v) [list
$a]
706 lset varcrow
($v) $a 0
710 set arcn
[lindex
$varcix($v) $a]
711 # see if a is the last arc; if so, nothing to do
712 if {$arcn == $narctot - 1} {
715 if {[llength
$vrownum($v)] > $arcn + 1} {
716 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
717 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
719 set row
[lindex
$varcrow($v) $a]
721 if {$v == $curview} {
722 if {[llength
$displayorder] > $vrowmod($v)} {
723 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
724 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
726 catch
{unset cached_commitrow
}
730 incr row
[llength
$varccommits($v,$a)]
731 # go down if possible
732 set b
[lindex
$vdownptr($v) $a]
734 # if not, go left, or go up until we can go left
736 set b
[lindex
$vleftptr($v) $a]
738 set a
[lindex
$vupptr($v) $a]
744 lappend vrownum
($v) $row
745 lappend varcorder
($v) $a
746 lset varcix
($v) $a $arcn
747 lset varcrow
($v) $a $row
749 set vtokmod
($v) [lindex
$varctok($v) $p]
752 if {[info exists currentid
]} {
753 set selectedline
[rowofcommit
$currentid]
757 # Test whether view $v contains commit $id
758 proc commitinview
{id v
} {
761 return [info exists varcid
($v,$id)]
764 # Return the row number for commit $id in the current view
765 proc rowofcommit
{id
} {
766 global varcid varccommits varcrow curview cached_commitrow
767 global varctok vtokmod
770 if {![info exists varcid
($v,$id)]} {
771 puts
"oops rowofcommit no arc for [shortids $id]"
774 set a
$varcid($v,$id)
775 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
778 if {[info exists cached_commitrow
($id)]} {
779 return $cached_commitrow($id)
781 set i
[lsearch
-exact $varccommits($v,$a) $id]
783 puts
"oops didn't find commit [shortids $id] in arc $a"
786 incr i
[lindex
$varcrow($v) $a]
787 set cached_commitrow
($id) $i
791 # Returns 1 if a is on an earlier row than b, otherwise 0
792 proc comes_before
{a b
} {
793 global varcid varctok curview
796 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
797 ![info exists varcid
($v,$b)]} {
800 if {$varcid($v,$a) != $varcid($v,$b)} {
801 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
802 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
804 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
807 proc bsearch
{l elt
} {
808 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
813 while {$hi - $lo > 1} {
814 set mid
[expr {int
(($lo + $hi) / 2)}]
815 set t
[lindex
$l $mid]
818 } elseif
{$elt > $t} {
827 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
828 proc make_disporder
{start end
} {
829 global vrownum curview commitidx displayorder parentlist
830 global varccommits varcorder parents vrowmod varcrow
831 global d_valid_start d_valid_end
833 if {$end > $vrowmod($curview)} {
834 update_arcrows
$curview
836 set ai
[bsearch
$vrownum($curview) $start]
837 set start
[lindex
$vrownum($curview) $ai]
838 set narc
[llength
$vrownum($curview)]
839 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
840 set a
[lindex
$varcorder($curview) $ai]
841 set l
[llength
$displayorder]
842 set al
[llength
$varccommits($curview,$a)]
845 set pad
[ntimes
[expr {$r - $l}] {}]
846 set displayorder
[concat
$displayorder $pad]
847 set parentlist
[concat
$parentlist $pad]
849 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
850 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
852 foreach id
$varccommits($curview,$a) {
853 lappend displayorder
$id
854 lappend parentlist
$parents($curview,$id)
856 } elseif
{[lindex
$displayorder $r] eq
{}} {
858 foreach id
$varccommits($curview,$a) {
859 lset displayorder
$i $id
860 lset parentlist
$i $parents($curview,$id)
868 proc commitonrow
{row
} {
871 set id
[lindex
$displayorder $row]
873 make_disporder
$row [expr {$row + 1}]
874 set id
[lindex
$displayorder $row]
879 proc closevarcs
{v
} {
880 global varctok varccommits varcid parents children
881 global cmitlisted commitidx commitinterest vtokmod
883 set missing_parents
0
885 set narcs
[llength
$varctok($v)]
886 for {set a
1} {$a < $narcs} {incr a
} {
887 set id
[lindex
$varccommits($v,$a) end
]
888 foreach p
$parents($v,$id) {
889 if {[info exists varcid
($v,$p)]} continue
890 # add p as a new commit
892 set cmitlisted
($v,$p) 0
893 set parents
($v,$p) {}
894 if {[llength
$children($v,$p)] == 1 &&
895 [llength
$parents($v,$id)] == 1} {
898 set b
[newvarc
$v $p]
901 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
904 lappend varccommits
($v,$b) $p
906 if {[info exists commitinterest
($p)]} {
907 foreach
script $commitinterest($p) {
908 lappend scripts
[string map
[list
"%I" $p] $script]
910 unset commitinterest
($id)
914 if {$missing_parents > 0} {
921 proc getcommitlines
{fd inst view
} {
922 global cmitlisted commitinterest leftover
923 global commitidx commitdata datemode
924 global parents children curview hlview
925 global vnextroot idpending ordertok
926 global varccommits varcid varctok vtokmod
928 set stuff
[read $fd 500000]
929 # git log doesn't terminate the last commit with a null...
930 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
937 global commfd viewcomplete viewactive viewname progresscoords
940 set i
[lsearch
-exact $viewinstances($view) $inst]
942 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
944 # set it blocking so we wait for the process to terminate
945 fconfigure
$fd -blocking 1
946 if {[catch
{close
$fd} err
]} {
948 if {$view != $curview} {
949 set fv
" for the \"$viewname($view)\" view"
951 if {[string range
$err 0 4] == "usage"} {
952 set err
"Gitk: error reading commits$fv:\
953 bad arguments to git rev-list."
954 if {$viewname($view) eq
"Command line"} {
956 " (Note: arguments to gitk are passed to git rev-list\
957 to allow selection of commits to be displayed.)"
960 set err
"Error reading commits$fv: $err"
964 if {[incr viewactive
($view) -1] <= 0} {
965 set viewcomplete
($view) 1
966 # Check if we have seen any ids listed as parents that haven't
967 # appeared in the list
970 set progresscoords
{0 0}
973 if {$view == $curview} {
974 run chewcommits
$view
982 set i
[string first
"\0" $stuff $start]
984 append leftover
($inst) [string range
$stuff $start end
]
988 set cmit
$leftover($inst)
989 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
990 set leftover
($inst) {}
992 set cmit
[string range
$stuff $start [expr {$i - 1}]]
994 set start
[expr {$i + 1}]
995 set j
[string first
"\n" $cmit]
998 if {$j >= 0 && [string match
"commit *" $cmit]} {
999 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1000 if {[string match
{[-<>]*} $ids]} {
1001 switch
-- [string index
$ids 0] {
1006 set ids
[string range
$ids 1 end
]
1010 if {[string length
$id] != 40} {
1018 if {[string length
$shortcmit] > 80} {
1019 set shortcmit
"[string range $shortcmit 0 80]..."
1021 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1024 set id [lindex $ids 0]
1026 if {!$listed && [info exists parents($vid)]} continue
1028 set olds [lrange $ids 1 end]
1032 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1033 set cmitlisted($vid) $listed
1034 set parents($vid) $olds
1036 if {![info exists children($vid)]} {
1037 set children($vid) {}
1038 } elseif {[llength $children($vid)] == 1} {
1039 set k [lindex $children($vid) 0]
1040 if {[llength $parents($view,$k)] == 1 &&
1042 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1043 set a $varcid($view,$k)
1048 set a [newvarc $view $id]
1051 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1054 lappend varccommits($view,$a) $id
1058 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1060 if {[llength [lappend children($vp) $id]] > 1 &&
1061 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1062 set children($vp) [lsort -command [list vtokcmp $view] \
1064 catch {unset ordertok}
1066 if {[info exists varcid($view,$p)]} {
1067 fix_reversal $p $a $view
1073 incr commitidx($view)
1074 if {[info exists commitinterest($id)]} {
1075 foreach script $commitinterest($id) {
1076 lappend scripts [string map [list "%I" $id] $script]
1078 unset commitinterest($id)
1083 run chewcommits $view
1084 foreach s $scripts {
1087 if {$view == $curview} {
1088 # update progress bar
1089 global progressdirn progresscoords proglastnc
1090 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1091 set proglastnc $commitidx($view)
1092 set l [lindex $progresscoords 0]
1093 set r [lindex $progresscoords 1]
1094 if {$progressdirn} {
1095 set r [expr {$r + $inc}]
1101 set l [expr {$r - 0.2}]
1104 set l [expr {$l - $inc}]
1109 set r [expr {$l + 0.2}]
1111 set progresscoords [list $l $r]
1118 proc chewcommits {view} {
1119 global curview hlview viewcomplete
1120 global pending_select
1122 if {$view == $curview} {
1124 if {$viewcomplete($view)} {
1125 global commitidx varctok
1126 global numcommits startmsecs
1127 global mainheadid commitinfo nullid
1129 if {[info exists pending_select]} {
1130 set row [first_real_row]
1133 if {$commitidx($curview) > 0} {
1134 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1135 #puts "overall $ms ms for $numcommits commits"
1136 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1138 show_status [mc "No commits selected"]
1143 if {[info exists hlview] && $view == $hlview} {
1149 proc readcommit {id} {
1150 if {[catch {set contents [exec git cat-file commit $id]}]} return
1151 parsecommit $id $contents 0
1154 proc parsecommit {id contents listed} {
1155 global commitinfo cdate
1164 set hdrend [string first "\n\n" $contents]
1166 # should never happen...
1167 set hdrend [string length $contents]
1169 set header [string range $contents 0 [expr {$hdrend - 1}]]
1170 set comment [string range $contents [expr {$hdrend + 2}] end]
1171 foreach line [split $header "\n"] {
1172 set tag [lindex $line 0]
1173 if {$tag == "author"} {
1174 set audate [lindex $line end-1]
1175 set auname [lrange $line 1 end-2]
1176 } elseif {$tag == "committer"} {
1177 set comdate [lindex $line end-1]
1178 set comname [lrange $line 1 end-2]
1182 # take the first non-blank line of the comment as the headline
1183 set headline [string trimleft $comment]
1184 set i [string first "\n" $headline]
1186 set headline [string range $headline 0 $i]
1188 set headline [string trimright $headline]
1189 set i [string first "\r" $headline]
1191 set headline [string trimright [string range $headline 0 $i]]
1194 # git rev-list indents the comment by 4 spaces;
1195 # if we got this via git cat-file, add the indentation
1197 foreach line [split $comment "\n"] {
1198 append newcomment " "
1199 append newcomment $line
1200 append newcomment "\n"
1202 set comment $newcomment
1204 if {$comdate != {}} {
1205 set cdate($id) $comdate
1207 set commitinfo($id) [list $headline $auname $audate \
1208 $comname $comdate $comment]
1211 proc getcommit {id} {
1212 global commitdata commitinfo
1214 if {[info exists commitdata($id)]} {
1215 parsecommit $id $commitdata($id) 1
1218 if {![info exists commitinfo($id)]} {
1219 set commitinfo($id) [list [mc "No commit information available"]]
1226 global tagids idtags headids idheads tagobjid
1227 global otherrefids idotherrefs mainhead mainheadid
1229 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1232 set refd [open [list | git show-ref -d] r]
1233 while {[gets $refd line] >= 0} {
1234 if {[string index $line 40] ne " "} continue
1235 set id [string range $line 0 39]
1236 set ref [string range $line 41 end]
1237 if {![string match "refs/*" $ref]} continue
1238 set name [string range $ref 5 end]
1239 if {[string match "remotes/*" $name]} {
1240 if {![string match "*/HEAD" $name]} {
1241 set headids($name) $id
1242 lappend idheads($id) $name
1244 } elseif {[string match "heads/*" $name]} {
1245 set name [string range $name 6 end]
1246 set headids($name) $id
1247 lappend idheads($id) $name
1248 } elseif {[string match "tags/*" $name]} {
1249 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1250 # which is what we want since the former is the commit ID
1251 set name [string range $name 5 end]
1252 if {[string match "*^{}" $name]} {
1253 set name [string range $name 0 end-3]
1255 set tagobjid($name) $id
1257 set tagids($name) $id
1258 lappend idtags($id) $name
1260 set otherrefids($name) $id
1261 lappend idotherrefs($id) $name
1268 set thehead [exec git symbolic-ref HEAD]
1269 if {[string match "refs/heads/*" $thehead]} {
1270 set mainhead [string range $thehead 11 end]
1271 if {[info exists headids($mainhead)]} {
1272 set mainheadid $headids($mainhead)
1278 # skip over fake commits
1279 proc first_real_row {} {
1280 global nullid nullid2 numcommits
1282 for {set row 0} {$row < $numcommits} {incr row} {
1283 set id [commitonrow $row]
1284 if {$id ne $nullid && $id ne $nullid2} {
1291 # update things for a head moved to a child of its previous location
1292 proc movehead {id name} {
1293 global headids idheads
1295 removehead $headids($name) $name
1296 set headids($name) $id
1297 lappend idheads($id) $name
1300 # update things when a head has been removed
1301 proc removehead {id name} {
1302 global headids idheads
1304 if {$idheads($id) eq $name} {
1307 set i [lsearch -exact $idheads($id) $name]
1309 set idheads($id) [lreplace $idheads($id) $i $i]
1312 unset headids($name)
1315 proc show_error {w top msg} {
1316 message $w.m -text $msg -justify center -aspect 400
1317 pack $w.m -side top -fill x -padx 20 -pady 20
1318 button $w.ok -text [mc OK] -command "destroy $top"
1319 pack $w.ok -side bottom -fill x
1320 bind $top <Visibility> "grab $top; focus $top"
1321 bind $top <Key-Return> "destroy $top"
1325 proc error_popup msg {
1329 show_error $w $w $msg
1332 proc confirm_popup msg {
1338 message $w.m -text $msg -justify center -aspect 400
1339 pack $w.m -side top -fill x -padx 20 -pady 20
1340 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1341 pack $w.ok -side left -fill x
1342 button $w.cancel -text [mc Cancel] -command "destroy $w"
1343 pack $w.cancel -side right -fill x
1344 bind $w <Visibility> "grab $w; focus $w"
1349 proc setoptions {} {
1350 option add *Panedwindow.showHandle 1 startupFile
1351 option add *Panedwindow.sashRelief raised startupFile
1352 option add *Button.font uifont startupFile
1353 option add *Checkbutton.font uifont startupFile
1354 option add *Radiobutton.font uifont startupFile
1355 option add *Menu.font uifont startupFile
1356 option add *Menubutton.font uifont startupFile
1357 option add *Label.font uifont startupFile
1358 option add *Message.font uifont startupFile
1359 option add *Entry.font uifont startupFile
1362 proc makewindow {} {
1363 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1365 global findtype findtypemenu findloc findstring fstring geometry
1366 global entries sha1entry sha1string sha1but
1367 global diffcontextstring diffcontext
1368 global maincursor textcursor curtextcursor
1369 global rowctxmenu fakerowmenu mergemax wrapcomment
1370 global highlight_files gdttype
1371 global searchstring sstring
1372 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1373 global headctxmenu progresscanv progressitem progresscoords statusw
1374 global fprogitem fprogcoord lastprogupdate progupdatepending
1375 global rprogitem rprogcoord
1379 .bar add cascade -label [mc "File"] -menu .bar.file
1381 .bar.file add command -label [mc "Update"] -command updatecommits
1382 .bar.file add command -label [mc "Reload"] -command reloadcommits
1383 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1384 .bar.file add command -label [mc "List references"] -command showrefs
1385 .bar.file add command -label [mc "Quit"] -command doquit
1387 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1388 .bar.edit add command -label [mc "Preferences"] -command doprefs
1391 .bar add cascade -label [mc "View"] -menu .bar.view
1392 .bar.view add command -label [mc "New view..."] -command {newview 0}
1393 .bar.view add command -label [mc "Edit view..."] -command editview \
1395 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1396 .bar.view add separator
1397 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1398 -variable selectedview -value 0
1401 .bar add cascade -label [mc "Help"] -menu .bar.help
1402 .bar.help add command -label [mc "About gitk"] -command about
1403 .bar.help add command -label [mc "Key bindings"] -command keys
1405 . configure -menu .bar
1407 # the gui has upper and lower half, parts of a paned window.
1408 panedwindow .ctop -orient vertical
1410 # possibly use assumed geometry
1411 if {![info exists geometry(pwsash0)]} {
1412 set geometry(topheight) [expr {15 * $linespc}]
1413 set geometry(topwidth) [expr {80 * $charspc}]
1414 set geometry(botheight) [expr {15 * $linespc}]
1415 set geometry(botwidth) [expr {50 * $charspc}]
1416 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1417 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1420 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1421 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1423 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1425 # create three canvases
1426 set cscroll .tf.histframe.csb
1427 set canv .tf.histframe.pwclist.canv
1429 -selectbackground $selectbgcolor \
1430 -background $bgcolor -bd 0 \
1431 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1432 .tf.histframe.pwclist add $canv
1433 set canv2 .tf.histframe.pwclist.canv2
1435 -selectbackground $selectbgcolor \
1436 -background $bgcolor -bd 0 -yscrollincr $linespc
1437 .tf.histframe.pwclist add $canv2
1438 set canv3 .tf.histframe.pwclist.canv3
1440 -selectbackground $selectbgcolor \
1441 -background $bgcolor -bd 0 -yscrollincr $linespc
1442 .tf.histframe.pwclist add $canv3
1443 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1444 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1446 # a scroll bar to rule them
1447 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1448 pack $cscroll -side right -fill y
1449 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1450 lappend bglist $canv $canv2 $canv3
1451 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1453 # we have two button bars at bottom of top frame. Bar 1
1455 frame .tf.lbar -height 15
1457 set sha1entry .tf.bar.sha1
1458 set entries $sha1entry
1459 set sha1but .tf.bar.sha1label
1460 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1461 -command gotocommit -width 8
1462 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1463 pack .tf.bar.sha1label -side left
1464 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1465 trace add variable sha1string write sha1change
1466 pack $sha1entry -side left -pady 2
1468 image create bitmap bm-left -data {
1469 #define left_width 16
1470 #define left_height 16
1471 static unsigned char left_bits[] = {
1472 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1473 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1474 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1476 image create bitmap bm-right -data {
1477 #define right_width 16
1478 #define right_height 16
1479 static unsigned char right_bits[] = {
1480 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1481 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1482 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1484 button .tf.bar.leftbut -image bm-left -command goback \
1485 -state disabled -width 26
1486 pack .tf.bar.leftbut -side left -fill y
1487 button .tf.bar.rightbut -image bm-right -command goforw \
1488 -state disabled -width 26
1489 pack .tf.bar.rightbut -side left -fill y
1491 # Status label and progress bar
1492 set statusw .tf.bar.status
1493 label $statusw -width 15 -relief sunken
1494 pack $statusw -side left -padx 5
1495 set h [expr {[font metrics uifont -linespace] + 2}]
1496 set progresscanv .tf.bar.progress
1497 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1498 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1499 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1500 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1501 pack $progresscanv -side right -expand 1 -fill x
1502 set progresscoords {0 0}
1505 bind $progresscanv <Configure> adjustprogress
1506 set lastprogupdate [clock clicks -milliseconds]
1507 set progupdatepending 0
1509 # build up the bottom bar of upper window
1510 label .tf.lbar.flabel -text "[mc "Find"] "
1511 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1512 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1513 label .tf.lbar.flab2 -text " [mc "commit"] "
1514 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1516 set gdttype [mc "containing:"]
1517 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1518 [mc "containing:"] \
1519 [mc "touching paths:"] \
1520 [mc "adding/removing string:"]]
1521 trace add variable gdttype write gdttype_change
1522 pack .tf.lbar.gdttype -side left -fill y
1525 set fstring .tf.lbar.findstring
1526 lappend entries $fstring
1527 entry $fstring -width 30 -font textfont -textvariable findstring
1528 trace add variable findstring write find_change
1529 set findtype [mc "Exact"]
1530 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1531 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1532 trace add variable findtype write findcom_change
1533 set findloc [mc "All fields"]
1534 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1535 [mc "Comments"] [mc "Author"] [mc "Committer"]
1536 trace add variable findloc write find_change
1537 pack .tf.lbar.findloc -side right
1538 pack .tf.lbar.findtype -side right
1539 pack $fstring -side left -expand 1 -fill x
1541 # Finish putting the upper half of the viewer together
1542 pack .tf.lbar -in .tf -side bottom -fill x
1543 pack .tf.bar -in .tf -side bottom -fill x
1544 pack .tf.histframe -fill both -side top -expand 1
1546 .ctop paneconfigure .tf -height $geometry(topheight)
1547 .ctop paneconfigure .tf -width $geometry(topwidth)
1549 # now build up the bottom
1550 panedwindow .pwbottom -orient horizontal
1552 # lower left, a text box over search bar, scroll bar to the right
1553 # if we know window height, then that will set the lower text height, otherwise
1554 # we set lower text height which will drive window height
1555 if {[info exists geometry(main)]} {
1556 frame .bleft -width $geometry(botwidth)
1558 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1563 button .bleft.top.search -text [mc "Search"] -command dosearch
1564 pack .bleft.top.search -side left -padx 5
1565 set sstring .bleft.top.sstring
1566 entry $sstring -width 20 -font textfont -textvariable searchstring
1567 lappend entries $sstring
1568 trace add variable searchstring write incrsearch
1569 pack $sstring -side left -expand 1 -fill x
1570 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1571 -command changediffdisp -variable diffelide -value {0 0}
1572 radiobutton .bleft.mid.old -text [mc "Old version"] \
1573 -command changediffdisp -variable diffelide -value {0 1}
1574 radiobutton .bleft.mid.new -text [mc "New version"] \
1575 -command changediffdisp -variable diffelide -value {1 0}
1576 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1577 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1578 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1579 -from 1 -increment 1 -to 10000000 \
1580 -validate all -validatecommand "diffcontextvalidate %P" \
1581 -textvariable diffcontextstring
1582 .bleft.mid.diffcontext set $diffcontext
1583 trace add variable diffcontextstring write diffcontextchange
1584 lappend entries .bleft.mid.diffcontext
1585 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1586 set ctext .bleft.ctext
1587 text $ctext -background $bgcolor -foreground $fgcolor \
1588 -state disabled -font textfont \
1589 -yscrollcommand scrolltext -wrap none
1591 $ctext conf -tabstyle wordprocessor
1593 scrollbar .bleft.sb -command "$ctext yview"
1594 pack .bleft.top -side top -fill x
1595 pack .bleft.mid -side top -fill x
1596 pack .bleft.sb -side right -fill y
1597 pack $ctext -side left -fill both -expand 1
1598 lappend bglist $ctext
1599 lappend fglist $ctext
1601 $ctext tag conf comment -wrap $wrapcomment
1602 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1603 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1604 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1605 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1606 $ctext tag conf m0 -fore red
1607 $ctext tag conf m1 -fore blue
1608 $ctext tag conf m2 -fore green
1609 $ctext tag conf m3 -fore purple
1610 $ctext tag conf m4 -fore brown
1611 $ctext tag conf m5 -fore "#009090"
1612 $ctext tag conf m6 -fore magenta
1613 $ctext tag conf m7 -fore "#808000"
1614 $ctext tag conf m8 -fore "#009000"
1615 $ctext tag conf m9 -fore "#ff0080"
1616 $ctext tag conf m10 -fore cyan
1617 $ctext tag conf m11 -fore "#b07070"
1618 $ctext tag conf m12 -fore "#70b0f0"
1619 $ctext tag conf m13 -fore "#70f0b0"
1620 $ctext tag conf m14 -fore "#f0b070"
1621 $ctext tag conf m15 -fore "#ff70b0"
1622 $ctext tag conf mmax -fore darkgrey
1624 $ctext tag conf mresult -font textfontbold
1625 $ctext tag conf msep -font textfontbold
1626 $ctext tag conf found -back yellow
1628 .pwbottom add .bleft
1629 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1634 radiobutton .bright.mode.patch -text [mc "Patch"] \
1635 -command reselectline -variable cmitmode -value "patch"
1636 radiobutton .bright.mode.tree -text [mc "Tree"] \
1637 -command reselectline -variable cmitmode -value "tree"
1638 grid .bright.mode.patch .bright.mode.tree -sticky ew
1639 pack .bright.mode -side top -fill x
1640 set cflist .bright.cfiles
1641 set indent [font measure mainfont "nn"]
1643 -selectbackground $selectbgcolor \
1644 -background $bgcolor -foreground $fgcolor \
1646 -tabs [list $indent [expr {2 * $indent}]] \
1647 -yscrollcommand ".bright.sb set" \
1648 -cursor [. cget -cursor] \
1649 -spacing1 1 -spacing3 1
1650 lappend bglist $cflist
1651 lappend fglist $cflist
1652 scrollbar .bright.sb -command "$cflist yview"
1653 pack .bright.sb -side right -fill y
1654 pack $cflist -side left -fill both -expand 1
1655 $cflist tag configure highlight \
1656 -background [$cflist cget -selectbackground]
1657 $cflist tag configure bold -font mainfontbold
1659 .pwbottom add .bright
1662 # restore window position if known
1663 if {[info exists geometry(main)]} {
1664 wm geometry . "$geometry(main)"
1667 if {[tk windowingsystem] eq {aqua}} {
1673 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1674 pack .ctop -fill both -expand 1
1675 bindall <1> {selcanvline %W %x %y}
1676 #bindall <B1-Motion> {selcanvline %W %x %y}
1677 if {[tk windowingsystem] == "win32"} {
1678 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1679 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1681 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1682 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1683 if {[tk windowingsystem] eq "aqua"} {
1684 bindall <MouseWheel> {
1685 set delta [expr {- (%D)}]
1686 allcanvs yview scroll $delta units
1690 bindall <2> "canvscan mark %W %x %y"
1691 bindall <B2-Motion> "canvscan dragto %W %x %y"
1692 bindkey <Home> selfirstline
1693 bindkey <End> sellastline
1694 bind . <Key-Up> "selnextline -1"
1695 bind . <Key-Down> "selnextline 1"
1696 bind . <Shift-Key-Up> "dofind -1 0"
1697 bind . <Shift-Key-Down> "dofind 1 0"
1698 bindkey <Key-Right> "goforw"
1699 bindkey <Key-Left> "goback"
1700 bind . <Key-Prior> "selnextpage -1"
1701 bind . <Key-Next> "selnextpage 1"
1702 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1703 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1704 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1705 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1706 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1707 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1708 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1709 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1710 bindkey <Key-space> "$ctext yview scroll 1 pages"
1711 bindkey p "selnextline -1"
1712 bindkey n "selnextline 1"
1715 bindkey i "selnextline -1"
1716 bindkey k "selnextline 1"
1719 bindkey b "$ctext yview scroll -1 pages"
1720 bindkey d "$ctext yview scroll 18 units"
1721 bindkey u "$ctext yview scroll -18 units"
1722 bindkey / {dofind 1 1}
1723 bindkey <Key-Return> {dofind 1 1}
1724 bindkey ? {dofind -1 1}
1726 bindkey <F5> updatecommits
1727 bind . <$M1B-q> doquit
1728 bind . <$M1B-f> {dofind 1 1}
1729 bind . <$M1B-g> {dofind 1 0}
1730 bind . <$M1B-r> dosearchback
1731 bind . <$M1B-s> dosearch
1732 bind . <$M1B-equal> {incrfont 1}
1733 bind . <$M1B-KP_Add> {incrfont 1}
1734 bind . <$M1B-minus> {incrfont -1}
1735 bind . <$M1B-KP_Subtract> {incrfont -1}
1736 wm protocol . WM_DELETE_WINDOW doquit
1737 bind . <Button-1> "click %W"
1738 bind $fstring <Key-Return> {dofind 1 1}
1739 bind $sha1entry <Key-Return> gotocommit
1740 bind $sha1entry <<PasteSelection>> clearsha1
1741 bind $cflist <1> {sel_flist %W %x %y; break}
1742 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1743 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1744 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1746 set maincursor [. cget -cursor]
1747 set textcursor [$ctext cget -cursor]
1748 set curtextcursor $textcursor
1750 set rowctxmenu .rowctxmenu
1751 menu $rowctxmenu -tearoff 0
1752 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1753 -command {diffvssel 0}
1754 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1755 -command {diffvssel 1}
1756 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1757 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1758 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1759 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1760 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1762 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1765 set fakerowmenu .fakerowmenu
1766 menu $fakerowmenu -tearoff 0
1767 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1768 -command {diffvssel 0}
1769 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1770 -command {diffvssel 1}
1771 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1772 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1773 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1774 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1776 set headctxmenu .headctxmenu
1777 menu $headctxmenu -tearoff 0
1778 $headctxmenu add command -label [mc "Check out this branch"] \
1780 $headctxmenu add command -label [mc "Remove this branch"] \
1784 set flist_menu .flistctxmenu
1785 menu $flist_menu -tearoff 0
1786 $flist_menu add command -label [mc "Highlight this too"] \
1787 -command {flist_hl 0}
1788 $flist_menu add command -label [mc "Highlight this only"] \
1789 -command {flist_hl 1}
1792 # Windows sends all mouse wheel events to the current focused window, not
1793 # the one where the mouse hovers, so bind those events here and redirect
1794 # to the correct window
1795 proc windows_mousewheel_redirector {W X Y D} {
1796 global canv canv2 canv3
1797 set w [winfo containing -displayof $W $X $Y]
1799 set u [expr {$D < 0 ? 5 : -5}]
1800 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1801 allcanvs yview scroll $u units
1804 $w yview scroll $u units
1810 # mouse-2 makes all windows scan vertically, but only the one
1811 # the cursor is in scans horizontally
1812 proc canvscan {op w x y} {
1813 global canv canv2 canv3
1814 foreach c [list $canv $canv2 $canv3] {
1823 proc scrollcanv {cscroll f0 f1} {
1824 $cscroll set $f0 $f1
1829 # when we make a key binding for the toplevel, make sure
1830 # it doesn't get triggered when that key is pressed
in the
1831 # find string entry widget.
1832 proc bindkey
{ev
script} {
1835 set escript
[bind Entry
$ev]
1836 if {$escript == {}} {
1837 set escript
[bind Entry
<Key
>]
1839 foreach e
$entries {
1840 bind $e $ev "$escript; break"
1844 # set the focus back to the toplevel for any click outside
1847 global ctext entries
1848 foreach e
[concat
$entries $ctext] {
1849 if {$w == $e} return
1854 # Adjust the progress bar for a change in requested extent or canvas size
1855 proc adjustprogress
{} {
1856 global progresscanv progressitem progresscoords
1857 global fprogitem fprogcoord lastprogupdate progupdatepending
1858 global rprogitem rprogcoord
1860 set w
[expr {[winfo width
$progresscanv] - 4}]
1861 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1862 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1863 set h
[winfo height
$progresscanv]
1864 $progresscanv coords
$progressitem $x0 0 $x1 $h
1865 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1866 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1867 set now
[clock clicks
-milliseconds]
1868 if {$now >= $lastprogupdate + 100} {
1869 set progupdatepending
0
1871 } elseif
{!$progupdatepending} {
1872 set progupdatepending
1
1873 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1877 proc doprogupdate
{} {
1878 global lastprogupdate progupdatepending
1880 if {$progupdatepending} {
1881 set progupdatepending
0
1882 set lastprogupdate
[clock clicks
-milliseconds]
1887 proc savestuff
{w
} {
1888 global canv canv2 canv3 mainfont textfont uifont tabstop
1889 global stuffsaved findmergefiles maxgraphpct
1890 global maxwidth showneartags showlocalchanges
1891 global viewname viewfiles viewargs viewperm nextviewnum
1892 global cmitmode wrapcomment datetimeformat limitdiffs
1893 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1895 if {$stuffsaved} return
1896 if {![winfo viewable .
]} return
1898 set f
[open
"~/.gitk-new" w
]
1899 puts
$f [list
set mainfont
$mainfont]
1900 puts
$f [list
set textfont
$textfont]
1901 puts
$f [list
set uifont
$uifont]
1902 puts
$f [list
set tabstop
$tabstop]
1903 puts
$f [list
set findmergefiles
$findmergefiles]
1904 puts
$f [list
set maxgraphpct
$maxgraphpct]
1905 puts
$f [list
set maxwidth
$maxwidth]
1906 puts
$f [list
set cmitmode
$cmitmode]
1907 puts
$f [list
set wrapcomment
$wrapcomment]
1908 puts
$f [list
set showneartags
$showneartags]
1909 puts
$f [list
set showlocalchanges
$showlocalchanges]
1910 puts
$f [list
set datetimeformat
$datetimeformat]
1911 puts
$f [list
set limitdiffs
$limitdiffs]
1912 puts
$f [list
set bgcolor
$bgcolor]
1913 puts
$f [list
set fgcolor
$fgcolor]
1914 puts
$f [list
set colors
$colors]
1915 puts
$f [list
set diffcolors
$diffcolors]
1916 puts
$f [list
set diffcontext
$diffcontext]
1917 puts
$f [list
set selectbgcolor
$selectbgcolor]
1919 puts
$f "set geometry(main) [wm geometry .]"
1920 puts
$f "set geometry(topwidth) [winfo width .tf]"
1921 puts
$f "set geometry(topheight) [winfo height .tf]"
1922 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1923 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1924 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1925 puts
$f "set geometry(botheight) [winfo height .bleft]"
1927 puts
-nonewline $f "set permviews {"
1928 for {set v
0} {$v < $nextviewnum} {incr v
} {
1929 if {$viewperm($v)} {
1930 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1935 file rename
-force "~/.gitk-new" "~/.gitk"
1940 proc resizeclistpanes
{win w
} {
1942 if {[info exists oldwidth
($win)]} {
1943 set s0
[$win sash coord
0]
1944 set s1
[$win sash coord
1]
1946 set sash0
[expr {int
($w/2 - 2)}]
1947 set sash1
[expr {int
($w*5/6 - 2)}]
1949 set factor [expr {1.0 * $w / $oldwidth($win)}]
1950 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1951 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1955 if {$sash1 < $sash0 + 20} {
1956 set sash1
[expr {$sash0 + 20}]
1958 if {$sash1 > $w - 10} {
1959 set sash1
[expr {$w - 10}]
1960 if {$sash0 > $sash1 - 20} {
1961 set sash0
[expr {$sash1 - 20}]
1965 $win sash place
0 $sash0 [lindex
$s0 1]
1966 $win sash place
1 $sash1 [lindex
$s1 1]
1968 set oldwidth
($win) $w
1971 proc resizecdetpanes
{win w
} {
1973 if {[info exists oldwidth
($win)]} {
1974 set s0
[$win sash coord
0]
1976 set sash0
[expr {int
($w*3/4 - 2)}]
1978 set factor [expr {1.0 * $w / $oldwidth($win)}]
1979 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1983 if {$sash0 > $w - 15} {
1984 set sash0
[expr {$w - 15}]
1987 $win sash place
0 $sash0 [lindex
$s0 1]
1989 set oldwidth
($win) $w
1992 proc allcanvs args
{
1993 global canv canv2 canv3
1999 proc bindall
{event action
} {
2000 global canv canv2 canv3
2001 bind $canv $event $action
2002 bind $canv2 $event $action
2003 bind $canv3 $event $action
2009 if {[winfo exists
$w]} {
2014 wm title
$w [mc
"About gitk"]
2015 message
$w.m
-text [mc
"
2016 Gitk - a commit viewer for git
2018 Copyright © 2005-2006 Paul Mackerras
2020 Use and redistribute under the terms of the GNU General Public License"] \
2021 -justify center
-aspect 400 -border 2 -bg white
-relief groove
2022 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
2023 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2024 pack
$w.ok
-side bottom
2025 bind $w <Visibility
> "focus $w.ok"
2026 bind $w <Key-Escape
> "destroy $w"
2027 bind $w <Key-Return
> "destroy $w"
2032 if {[winfo exists
$w]} {
2036 if {[tk windowingsystem
] eq
{aqua
}} {
2042 wm title
$w [mc
"Gitk key bindings"]
2043 message
$w.m
-text [mc
"
2047 <Home> Move to first commit
2048 <End> Move to last commit
2049 <Up>, p, i Move up one commit
2050 <Down>, n, k Move down one commit
2051 <Left>, z, j Go back in history list
2052 <Right>, x, l Go forward in history list
2053 <PageUp> Move up one page in commit list
2054 <PageDown> Move down one page in commit list
2055 <$M1T-Home> Scroll to top of commit list
2056 <$M1T-End> Scroll to bottom of commit list
2057 <$M1T-Up> Scroll commit list up one line
2058 <$M1T-Down> Scroll commit list down one line
2059 <$M1T-PageUp> Scroll commit list up one page
2060 <$M1T-PageDown> Scroll commit list down one page
2061 <Shift-Up> Find backwards (upwards, later commits)
2062 <Shift-Down> Find forwards (downwards, earlier commits)
2063 <Delete>, b Scroll diff view up one page
2064 <Backspace> Scroll diff view up one page
2065 <Space> Scroll diff view down one page
2066 u Scroll diff view up 18 lines
2067 d Scroll diff view down 18 lines
2069 <$M1T-G> Move to next find hit
2070 <Return> Move to next find hit
2071 / Move to next find hit, or redo find
2072 ? Move to previous find hit
2073 f Scroll diff view to next file
2074 <$M1T-S> Search for next hit in diff view
2075 <$M1T-R> Search for previous hit in diff view
2076 <$M1T-KP+> Increase font size
2077 <$M1T-plus> Increase font size
2078 <$M1T-KP-> Decrease font size
2079 <$M1T-minus> Decrease font size
2082 -justify left
-bg white
-border 2 -relief groove
2083 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
2084 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2085 pack
$w.ok
-side bottom
2086 bind $w <Visibility
> "focus $w.ok"
2087 bind $w <Key-Escape
> "destroy $w"
2088 bind $w <Key-Return
> "destroy $w"
2091 # Procedures for manipulating the file list window at the
2092 # bottom right of the overall window.
2094 proc treeview
{w l openlevs
} {
2095 global treecontents treediropen treeheight treeparent treeindex
2105 set treecontents
() {}
2106 $w conf
-state normal
2108 while {[string range
$f 0 $prefixend] ne
$prefix} {
2109 if {$lev <= $openlevs} {
2110 $w mark
set e
:$treeindex($prefix) "end -1c"
2111 $w mark gravity e
:$treeindex($prefix) left
2113 set treeheight
($prefix) $ht
2114 incr ht
[lindex
$htstack end
]
2115 set htstack
[lreplace
$htstack end end
]
2116 set prefixend
[lindex
$prefendstack end
]
2117 set prefendstack
[lreplace
$prefendstack end end
]
2118 set prefix
[string range
$prefix 0 $prefixend]
2121 set tail [string range
$f [expr {$prefixend+1}] end
]
2122 while {[set slash
[string first
"/" $tail]] >= 0} {
2125 lappend prefendstack
$prefixend
2126 incr prefixend
[expr {$slash + 1}]
2127 set d
[string range
$tail 0 $slash]
2128 lappend treecontents
($prefix) $d
2129 set oldprefix
$prefix
2131 set treecontents
($prefix) {}
2132 set treeindex
($prefix) [incr ix
]
2133 set treeparent
($prefix) $oldprefix
2134 set tail [string range
$tail [expr {$slash+1}] end
]
2135 if {$lev <= $openlevs} {
2137 set treediropen
($prefix) [expr {$lev < $openlevs}]
2138 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
2139 $w mark
set d
:$ix "end -1c"
2140 $w mark gravity d
:$ix left
2142 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2144 $w image create end
-align center
-image $bm -padx 1 \
2146 $w insert end
$d [highlight_tag
$prefix]
2147 $w mark
set s
:$ix "end -1c"
2148 $w mark gravity s
:$ix left
2153 if {$lev <= $openlevs} {
2156 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2158 $w insert end
$tail [highlight_tag
$f]
2160 lappend treecontents
($prefix) $tail
2163 while {$htstack ne
{}} {
2164 set treeheight
($prefix) $ht
2165 incr ht
[lindex
$htstack end
]
2166 set htstack
[lreplace
$htstack end end
]
2167 set prefixend
[lindex
$prefendstack end
]
2168 set prefendstack
[lreplace
$prefendstack end end
]
2169 set prefix
[string range
$prefix 0 $prefixend]
2171 $w conf
-state disabled
2174 proc linetoelt
{l
} {
2175 global treeheight treecontents
2180 foreach e
$treecontents($prefix) {
2185 if {[string index
$e end
] eq
"/"} {
2186 set n
$treeheight($prefix$e)
2198 proc highlight_tree
{y prefix
} {
2199 global treeheight treecontents cflist
2201 foreach e
$treecontents($prefix) {
2203 if {[highlight_tag
$path] ne
{}} {
2204 $cflist tag add bold
$y.0 "$y.0 lineend"
2207 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
2208 set y
[highlight_tree
$y $path]
2214 proc treeclosedir
{w dir
} {
2215 global treediropen treeheight treeparent treeindex
2217 set ix
$treeindex($dir)
2218 $w conf
-state normal
2219 $w delete s
:$ix e
:$ix
2220 set treediropen
($dir) 0
2221 $w image configure a
:$ix -image tri-rt
2222 $w conf
-state disabled
2223 set n
[expr {1 - $treeheight($dir)}]
2224 while {$dir ne
{}} {
2225 incr treeheight
($dir) $n
2226 set dir
$treeparent($dir)
2230 proc treeopendir
{w dir
} {
2231 global treediropen treeheight treeparent treecontents treeindex
2233 set ix
$treeindex($dir)
2234 $w conf
-state normal
2235 $w image configure a
:$ix -image tri-dn
2236 $w mark
set e
:$ix s
:$ix
2237 $w mark gravity e
:$ix right
2240 set n
[llength
$treecontents($dir)]
2241 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
2244 incr treeheight
($x) $n
2246 foreach e
$treecontents($dir) {
2248 if {[string index
$e end
] eq
"/"} {
2249 set iy
$treeindex($de)
2250 $w mark
set d
:$iy e
:$ix
2251 $w mark gravity d
:$iy left
2252 $w insert e
:$ix $str
2253 set treediropen
($de) 0
2254 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
2256 $w insert e
:$ix $e [highlight_tag
$de]
2257 $w mark
set s
:$iy e
:$ix
2258 $w mark gravity s
:$iy left
2259 set treeheight
($de) 1
2261 $w insert e
:$ix $str
2262 $w insert e
:$ix $e [highlight_tag
$de]
2265 $w mark gravity e
:$ix left
2266 $w conf
-state disabled
2267 set treediropen
($dir) 1
2268 set top
[lindex
[split [$w index @
0,0] .
] 0]
2269 set ht
[$w cget
-height]
2270 set l
[lindex
[split [$w index s
:$ix] .
] 0]
2273 } elseif
{$l + $n + 1 > $top + $ht} {
2274 set top
[expr {$l + $n + 2 - $ht}]
2282 proc treeclick
{w x y
} {
2283 global treediropen cmitmode ctext cflist cflist_top
2285 if {$cmitmode ne
"tree"} return
2286 if {![info exists cflist_top
]} return
2287 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2288 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2289 $cflist tag add highlight
$l.0 "$l.0 lineend"
2295 set e
[linetoelt
$l]
2296 if {[string index
$e end
] ne
"/"} {
2298 } elseif
{$treediropen($e)} {
2305 proc setfilelist
{id
} {
2306 global treefilelist cflist
2308 treeview
$cflist $treefilelist($id) 0
2311 image create bitmap tri-rt
-background black
-foreground blue
-data {
2312 #define tri-rt_width 13
2313 #define tri-rt_height 13
2314 static unsigned char tri-rt_bits
[] = {
2315 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2316 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2319 #define tri-rt-mask_width 13
2320 #define tri-rt-mask_height 13
2321 static unsigned char tri-rt-mask_bits
[] = {
2322 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2323 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2326 image create bitmap tri-dn
-background black
-foreground blue
-data {
2327 #define tri-dn_width 13
2328 #define tri-dn_height 13
2329 static unsigned char tri-dn_bits
[] = {
2330 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2331 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2334 #define tri-dn-mask_width 13
2335 #define tri-dn-mask_height 13
2336 static unsigned char tri-dn-mask_bits
[] = {
2337 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2338 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2342 image create bitmap reficon-T
-background black
-foreground yellow
-data {
2343 #define tagicon_width 13
2344 #define tagicon_height 9
2345 static unsigned char tagicon_bits
[] = {
2346 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2347 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2349 #define tagicon-mask_width 13
2350 #define tagicon-mask_height 9
2351 static unsigned char tagicon-mask_bits
[] = {
2352 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2353 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2356 #define headicon_width 13
2357 #define headicon_height 9
2358 static unsigned char headicon_bits
[] = {
2359 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2360 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2363 #define headicon-mask_width 13
2364 #define headicon-mask_height 9
2365 static unsigned char headicon-mask_bits
[] = {
2366 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2367 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2369 image create bitmap reficon-H
-background black
-foreground green \
2370 -data $rectdata -maskdata $rectmask
2371 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
2372 -data $rectdata -maskdata $rectmask
2374 proc init_flist
{first
} {
2375 global cflist cflist_top difffilestart
2377 $cflist conf
-state normal
2378 $cflist delete
0.0 end
2380 $cflist insert end
$first
2382 $cflist tag add highlight
1.0 "1.0 lineend"
2384 catch
{unset cflist_top
}
2386 $cflist conf
-state disabled
2387 set difffilestart
{}
2390 proc highlight_tag
{f
} {
2391 global highlight_paths
2393 foreach p
$highlight_paths {
2394 if {[string match
$p $f]} {
2401 proc highlight_filelist
{} {
2402 global cmitmode cflist
2404 $cflist conf
-state normal
2405 if {$cmitmode ne
"tree"} {
2406 set end
[lindex
[split [$cflist index end
] .
] 0]
2407 for {set l
2} {$l < $end} {incr l
} {
2408 set line
[$cflist get
$l.0 "$l.0 lineend"]
2409 if {[highlight_tag
$line] ne
{}} {
2410 $cflist tag add bold
$l.0 "$l.0 lineend"
2416 $cflist conf
-state disabled
2419 proc unhighlight_filelist
{} {
2422 $cflist conf
-state normal
2423 $cflist tag remove bold
1.0 end
2424 $cflist conf
-state disabled
2427 proc add_flist
{fl
} {
2430 $cflist conf
-state normal
2432 $cflist insert end
"\n"
2433 $cflist insert end
$f [highlight_tag
$f]
2435 $cflist conf
-state disabled
2438 proc sel_flist
{w x y
} {
2439 global ctext difffilestart cflist cflist_top cmitmode
2441 if {$cmitmode eq
"tree"} return
2442 if {![info exists cflist_top
]} return
2443 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2444 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2445 $cflist tag add highlight
$l.0 "$l.0 lineend"
2450 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
2454 proc pop_flist_menu
{w X Y x y
} {
2455 global ctext cflist cmitmode flist_menu flist_menu_file
2456 global treediffs diffids
2459 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2461 if {$cmitmode eq
"tree"} {
2462 set e
[linetoelt
$l]
2463 if {[string index
$e end
] eq
"/"} return
2465 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
2467 set flist_menu_file
$e
2468 tk_popup
$flist_menu $X $Y
2471 proc flist_hl
{only
} {
2472 global flist_menu_file findstring gdttype
2474 set x
[shellquote
$flist_menu_file]
2475 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
2478 append findstring
" " $x
2480 set gdttype
[mc
"touching paths:"]
2483 # Functions for adding and removing shell-type quoting
2485 proc shellquote
{str
} {
2486 if {![string match
"*\['\"\\ \t]*" $str]} {
2489 if {![string match
"*\['\"\\]*" $str]} {
2492 if {![string match
"*'*" $str]} {
2495 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2498 proc shellarglist
{l
} {
2504 append str
[shellquote
$a]
2509 proc shelldequote
{str
} {
2514 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
2515 append ret
[string range
$str $used end
]
2516 set used
[string length
$str]
2519 set first
[lindex
$first 0]
2520 set ch
[string index
$str $first]
2521 if {$first > $used} {
2522 append ret
[string range
$str $used [expr {$first - 1}]]
2525 if {$ch eq
" " ||
$ch eq
"\t"} break
2528 set first
[string first
"'" $str $used]
2530 error
"unmatched single-quote"
2532 append ret
[string range
$str $used [expr {$first - 1}]]
2537 if {$used >= [string length
$str]} {
2538 error
"trailing backslash"
2540 append ret
[string index
$str $used]
2545 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
2546 error
"unmatched double-quote"
2548 set first
[lindex
$first 0]
2549 set ch
[string index
$str $first]
2550 if {$first > $used} {
2551 append ret
[string range
$str $used [expr {$first - 1}]]
2554 if {$ch eq
"\""} break
2556 append ret
[string index
$str $used]
2560 return [list
$used $ret]
2563 proc shellsplit
{str
} {
2566 set str
[string trimleft
$str]
2567 if {$str eq
{}} break
2568 set dq
[shelldequote
$str]
2569 set n
[lindex
$dq 0]
2570 set word
[lindex
$dq 1]
2571 set str
[string range
$str $n end
]
2577 # Code to implement multiple views
2579 proc newview
{ishighlight
} {
2580 global nextviewnum newviewname newviewperm newishighlight
2581 global newviewargs revtreeargs
2583 set newishighlight
$ishighlight
2585 if {[winfo exists
$top]} {
2589 set newviewname
($nextviewnum) "View $nextviewnum"
2590 set newviewperm
($nextviewnum) 0
2591 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
2592 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
2597 global viewname viewperm newviewname newviewperm
2598 global viewargs newviewargs
2600 set top .gitkvedit-
$curview
2601 if {[winfo exists
$top]} {
2605 set newviewname
($curview) $viewname($curview)
2606 set newviewperm
($curview) $viewperm($curview)
2607 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
2608 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
2611 proc vieweditor
{top n title
} {
2612 global newviewname newviewperm viewfiles bgcolor
2615 wm title
$top $title
2616 label
$top.
nl -text [mc
"Name"]
2617 entry
$top.name
-width 20 -textvariable newviewname
($n)
2618 grid
$top.
nl $top.name
-sticky w
-pady 5
2619 checkbutton
$top.perm
-text [mc
"Remember this view"] \
2620 -variable newviewperm
($n)
2621 grid
$top.perm
- -pady 5 -sticky w
2622 message
$top.al
-aspect 1000 \
2623 -text [mc
"Commits to include (arguments to git rev-list):"]
2624 grid
$top.al
- -sticky w
-pady 5
2625 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
2626 -background $bgcolor
2627 grid
$top.args
- -sticky ew
-padx 5
2628 message
$top.l
-aspect 1000 \
2629 -text [mc
"Enter files and directories to include, one per line:"]
2630 grid
$top.l
- -sticky w
2631 text
$top.t
-width 40 -height 10 -background $bgcolor -font uifont
2632 if {[info exists viewfiles
($n)]} {
2633 foreach f
$viewfiles($n) {
2634 $top.t insert end
$f
2635 $top.t insert end
"\n"
2637 $top.t delete
{end
- 1c
} end
2638 $top.t mark
set insert
0.0
2640 grid
$top.t
- -sticky ew
-padx 5
2642 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n]
2643 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top]
2644 grid
$top.buts.ok
$top.buts.can
2645 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
2646 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
2647 grid
$top.buts
- -pady 10 -sticky ew
2651 proc doviewmenu
{m first cmd op argv
} {
2652 set nmenu
[$m index end
]
2653 for {set i
$first} {$i <= $nmenu} {incr i
} {
2654 if {[$m entrycget
$i -command] eq
$cmd} {
2655 eval $m $op $i $argv
2661 proc allviewmenus
{n op args
} {
2664 doviewmenu .bar.view
5 [list showview
$n] $op $args
2665 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2668 proc newviewok
{top n
} {
2669 global nextviewnum newviewperm newviewname newishighlight
2670 global viewname viewfiles viewperm selectedview curview
2671 global viewargs newviewargs viewhlmenu
2674 set newargs
[shellsplit
$newviewargs($n)]
2676 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
2682 foreach f
[split [$top.t get
0.0 end
] "\n"] {
2683 set ft
[string trim
$f]
2688 if {![info exists viewfiles
($n)]} {
2689 # creating a new view
2691 set viewname
($n) $newviewname($n)
2692 set viewperm
($n) $newviewperm($n)
2693 set viewfiles
($n) $files
2694 set viewargs
($n) $newargs
2696 if {!$newishighlight} {
2699 run addvhighlight
$n
2702 # editing an existing view
2703 set viewperm
($n) $newviewperm($n)
2704 if {$newviewname($n) ne
$viewname($n)} {
2705 set viewname
($n) $newviewname($n)
2706 doviewmenu .bar.view
5 [list showview
$n] \
2707 entryconf
[list
-label $viewname($n)]
2708 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2709 # entryconf [list -label $viewname($n) -value $viewname($n)]
2711 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n)} {
2712 set viewfiles
($n) $files
2713 set viewargs
($n) $newargs
2714 if {$curview == $n} {
2719 catch
{destroy
$top}
2723 global curview viewperm hlview selectedhlview
2725 if {$curview == 0} return
2726 if {[info exists hlview
] && $hlview == $curview} {
2727 set selectedhlview
[mc
"None"]
2730 allviewmenus
$curview delete
2731 set viewperm
($curview) 0
2735 proc addviewmenu
{n
} {
2736 global viewname viewhlmenu
2738 .bar.view add radiobutton
-label $viewname($n) \
2739 -command [list showview
$n] -variable selectedview
-value $n
2740 #$viewhlmenu add radiobutton -label $viewname($n) \
2741 # -command [list addvhighlight $n] -variable selectedhlview
2745 global curview viewfiles cached_commitrow ordertok
2746 global displayorder parentlist rowidlist rowisopt rowfinal
2747 global colormap rowtextx nextcolor canvxmax
2748 global numcommits viewcomplete
2749 global selectedline currentid canv canvy0
2751 global pending_select
2753 global selectedview selectfirst
2754 global hlview selectedhlview commitinterest
2756 if {$n == $curview} return
2758 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2759 set span
[$canv yview
]
2760 set ytop
[expr {[lindex
$span 0] * $ymax}]
2761 set ybot
[expr {[lindex
$span 1] * $ymax}]
2762 set yscreen
[expr {($ybot - $ytop) / 2}]
2763 if {[info exists selectedline
]} {
2764 set selid
$currentid
2765 set y
[yc
$selectedline]
2766 if {$ytop < $y && $y < $ybot} {
2767 set yscreen
[expr {$y - $ytop}]
2769 } elseif
{[info exists pending_select
]} {
2770 set selid
$pending_select
2771 unset pending_select
2775 catch
{unset treediffs
}
2777 if {[info exists hlview
] && $hlview == $n} {
2779 set selectedhlview
[mc
"None"]
2781 catch
{unset commitinterest
}
2782 catch
{unset cached_commitrow
}
2783 catch
{unset ordertok
}
2787 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2788 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2791 if {![info exists viewcomplete
($n)]} {
2793 set pending_select
$selid
2804 set numcommits
$commitidx($n)
2806 catch
{unset colormap
}
2807 catch
{unset rowtextx
}
2809 set canvxmax
[$canv cget
-width]
2816 if {$selid ne
{} && [commitinview
$selid $n]} {
2817 set row
[rowofcommit
$selid]
2818 # try to get the selected row in the same position on the screen
2819 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2820 set ytop
[expr {[yc
$row] - $yscreen}]
2824 set yf
[expr {$ytop * 1.0 / $ymax}]
2826 allcanvs yview moveto
$yf
2830 } elseif
{$selid ne
{}} {
2831 set pending_select
$selid
2833 set row
[first_real_row
]
2834 if {$row < $numcommits} {
2840 if {!$viewcomplete($n)} {
2841 if {$numcommits == 0} {
2842 show_status
[mc
"Reading commits..."]
2844 } elseif
{$numcommits == 0} {
2845 show_status
[mc
"No commits selected"]
2849 # Stuff relating to the highlighting facility
2851 proc ishighlighted
{id
} {
2852 global vhighlights fhighlights nhighlights rhighlights
2854 if {[info exists nhighlights
($id)] && $nhighlights($id) > 0} {
2855 return $nhighlights($id)
2857 if {[info exists vhighlights
($id)] && $vhighlights($id) > 0} {
2858 return $vhighlights($id)
2860 if {[info exists fhighlights
($id)] && $fhighlights($id) > 0} {
2861 return $fhighlights($id)
2863 if {[info exists rhighlights
($id)] && $rhighlights($id) > 0} {
2864 return $rhighlights($id)
2869 proc bolden
{row font
} {
2870 global canv linehtag selectedline boldrows
2872 lappend boldrows
$row
2873 $canv itemconf
$linehtag($row) -font $font
2874 if {[info exists selectedline
] && $row == $selectedline} {
2876 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2877 -outline {{}} -tags secsel \
2878 -fill [$canv cget
-selectbackground]]
2883 proc bolden_name
{row font
} {
2884 global canv2 linentag selectedline boldnamerows
2886 lappend boldnamerows
$row
2887 $canv2 itemconf
$linentag($row) -font $font
2888 if {[info exists selectedline
] && $row == $selectedline} {
2889 $canv2 delete secsel
2890 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2891 -outline {{}} -tags secsel \
2892 -fill [$canv2 cget
-selectbackground]]
2901 foreach row
$boldrows {
2902 if {![ishighlighted
[commitonrow
$row]]} {
2903 bolden
$row mainfont
2905 lappend stillbold
$row
2908 set boldrows
$stillbold
2911 proc addvhighlight
{n
} {
2912 global hlview viewcomplete curview vhl_done commitidx
2914 if {[info exists hlview
]} {
2918 if {$n != $curview && ![info exists viewcomplete
($n)]} {
2921 set vhl_done
$commitidx($hlview)
2922 if {$vhl_done > 0} {
2927 proc delvhighlight
{} {
2928 global hlview vhighlights
2930 if {![info exists hlview
]} return
2932 catch
{unset vhighlights
}
2936 proc vhighlightmore
{} {
2937 global hlview vhl_done commitidx vhighlights curview
2939 set max
$commitidx($hlview)
2940 set vr
[visiblerows
]
2941 set r0
[lindex
$vr 0]
2942 set r1
[lindex
$vr 1]
2943 for {set i
$vhl_done} {$i < $max} {incr i
} {
2944 set id
[commitonrow
$i $hlview]
2945 if {[commitinview
$id $curview]} {
2946 set row
[rowofcommit
$id]
2947 if {$r0 <= $row && $row <= $r1} {
2948 if {![highlighted
$row]} {
2949 bolden
$row mainfontbold
2951 set vhighlights
($id) 1
2958 proc askvhighlight
{row id
} {
2959 global hlview vhighlights iddrawn
2961 if {[commitinview
$id $hlview]} {
2962 if {[info exists iddrawn
($id)] && ![ishighlighted
$id]} {
2963 bolden
$row mainfontbold
2965 set vhighlights
($id) 1
2967 set vhighlights
($id) 0
2971 proc hfiles_change
{} {
2972 global highlight_files filehighlight fhighlights fh_serial
2973 global highlight_paths gdttype
2975 if {[info exists filehighlight
]} {
2976 # delete previous highlights
2977 catch
{close
$filehighlight}
2979 catch
{unset fhighlights
}
2981 unhighlight_filelist
2983 set highlight_paths
{}
2984 after cancel do_file_hl
$fh_serial
2986 if {$highlight_files ne
{}} {
2987 after
300 do_file_hl
$fh_serial
2991 proc gdttype_change
{name ix op
} {
2992 global gdttype highlight_files findstring findpattern
2995 if {$findstring ne
{}} {
2996 if {$gdttype eq
[mc
"containing:"]} {
2997 if {$highlight_files ne
{}} {
2998 set highlight_files
{}
3003 if {$findpattern ne
{}} {
3007 set highlight_files
$findstring
3012 # enable/disable findtype/findloc menus too
3015 proc find_change
{name ix op
} {
3016 global gdttype findstring highlight_files
3019 if {$gdttype eq
[mc
"containing:"]} {
3022 if {$highlight_files ne
$findstring} {
3023 set highlight_files
$findstring
3030 proc findcom_change args
{
3031 global nhighlights boldnamerows
3032 global findpattern findtype findstring gdttype
3035 # delete previous highlights, if any
3036 foreach row
$boldnamerows {
3037 bolden_name
$row mainfont
3040 catch
{unset nhighlights
}
3043 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
3045 } elseif
{$findtype eq
[mc
"Regexp"]} {
3046 set findpattern
$findstring
3048 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3050 set findpattern
"*$e*"
3054 proc makepatterns
{l
} {
3057 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3058 if {[string index
$ee end
] eq
"/"} {
3068 proc do_file_hl
{serial
} {
3069 global highlight_files filehighlight highlight_paths gdttype fhl_list
3071 if {$gdttype eq
[mc
"touching paths:"]} {
3072 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
3073 set highlight_paths
[makepatterns
$paths]
3075 set gdtargs
[concat
-- $paths]
3076 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
3077 set gdtargs
[list
"-S$highlight_files"]
3079 # must be "containing:", i.e. we're searching commit info
3082 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
3083 set filehighlight
[open
$cmd r
+]
3084 fconfigure
$filehighlight -blocking 0
3085 filerun
$filehighlight readfhighlight
3091 proc flushhighlights
{} {
3092 global filehighlight fhl_list
3094 if {[info exists filehighlight
]} {
3096 puts
$filehighlight ""
3097 flush
$filehighlight
3101 proc askfilehighlight
{row id
} {
3102 global filehighlight fhighlights fhl_list
3104 lappend fhl_list
$id
3105 set fhighlights
($id) -1
3106 puts
$filehighlight $id
3109 proc readfhighlight
{} {
3110 global filehighlight fhighlights curview iddrawn
3111 global fhl_list find_dirn
3113 if {![info exists filehighlight
]} {
3117 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
3118 set line
[string trim
$line]
3119 set i
[lsearch
-exact $fhl_list $line]
3120 if {$i < 0} continue
3121 for {set j
0} {$j < $i} {incr j
} {
3122 set id
[lindex
$fhl_list $j]
3123 set fhighlights
($id) 0
3125 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
3126 if {$line eq
{}} continue
3127 if {![commitinview
$line $curview]} continue
3128 set row
[rowofcommit
$line]
3129 if {[info exists iddrawn
($line)] && ![ishighlighted
$line]} {
3130 bolden
$row mainfontbold
3132 set fhighlights
($line) 1
3134 if {[eof
$filehighlight]} {
3136 puts
"oops, git diff-tree died"
3137 catch
{close
$filehighlight}
3141 if {[info exists find_dirn
]} {
3147 proc doesmatch
{f
} {
3148 global findtype findpattern
3150 if {$findtype eq
[mc
"Regexp"]} {
3151 return [regexp
$findpattern $f]
3152 } elseif
{$findtype eq
[mc
"IgnCase"]} {
3153 return [string match
-nocase $findpattern $f]
3155 return [string match
$findpattern $f]
3159 proc askfindhighlight
{row id
} {
3160 global nhighlights commitinfo iddrawn
3162 global markingmatches
3164 if {![info exists commitinfo
($id)]} {
3167 set info
$commitinfo($id)
3169 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
3170 foreach f
$info ty
$fldtypes {
3171 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
3173 if {$ty eq
[mc
"Author"]} {
3180 if {$isbold && [info exists iddrawn
($id)]} {
3181 if {![ishighlighted
$id]} {
3182 bolden
$row mainfontbold
3184 bolden_name
$row mainfontbold
3187 if {$markingmatches} {
3188 markrowmatches
$row $id
3191 set nhighlights
($id) $isbold
3194 proc markrowmatches
{row id
} {
3195 global canv canv2 linehtag linentag commitinfo findloc
3197 set headline
[lindex
$commitinfo($id) 0]
3198 set author
[lindex
$commitinfo($id) 1]
3199 $canv delete match
$row
3200 $canv2 delete match
$row
3201 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
3202 set m
[findmatches
$headline]
3204 markmatches
$canv $row $headline $linehtag($row) $m \
3205 [$canv itemcget
$linehtag($row) -font] $row
3208 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
3209 set m
[findmatches
$author]
3211 markmatches
$canv2 $row $author $linentag($row) $m \
3212 [$canv2 itemcget
$linentag($row) -font] $row
3217 proc vrel_change
{name ix op
} {
3218 global highlight_related
3221 if {$highlight_related ne
[mc
"None"]} {
3226 # prepare for testing whether commits are descendents or ancestors of a
3227 proc rhighlight_sel
{a
} {
3228 global descendent desc_todo ancestor anc_todo
3229 global highlight_related
3231 catch
{unset descendent
}
3232 set desc_todo
[list
$a]
3233 catch
{unset ancestor
}
3234 set anc_todo
[list
$a]
3235 if {$highlight_related ne
[mc
"None"]} {
3241 proc rhighlight_none
{} {
3244 catch
{unset rhighlights
}
3248 proc is_descendent
{a
} {
3249 global curview children descendent desc_todo
3252 set la
[rowofcommit
$a]
3256 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3257 set do [lindex
$todo $i]
3258 if {[rowofcommit
$do] < $la} {
3259 lappend leftover
$do
3262 foreach nk
$children($v,$do) {
3263 if {![info exists descendent
($nk)]} {
3264 set descendent
($nk) 1
3272 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3276 set descendent
($a) 0
3277 set desc_todo
$leftover
3280 proc is_ancestor
{a
} {
3281 global curview parents ancestor anc_todo
3284 set la
[rowofcommit
$a]
3288 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3289 set do [lindex
$todo $i]
3290 if {![commitinview
$do $v] ||
[rowofcommit
$do] > $la} {
3291 lappend leftover
$do
3294 foreach np
$parents($v,$do) {
3295 if {![info exists ancestor
($np)]} {
3304 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3309 set anc_todo
$leftover
3312 proc askrelhighlight
{row id
} {
3313 global descendent highlight_related iddrawn rhighlights
3314 global selectedline ancestor
3316 if {![info exists selectedline
]} return
3318 if {$highlight_related eq
[mc
"Descendent"] ||
3319 $highlight_related eq
[mc
"Not descendent"]} {
3320 if {![info exists descendent
($id)]} {
3323 if {$descendent($id) == ($highlight_related eq
[mc
"Descendent"])} {
3326 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
3327 $highlight_related eq
[mc
"Not ancestor"]} {
3328 if {![info exists ancestor
($id)]} {
3331 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
3335 if {[info exists iddrawn
($id)]} {
3336 if {$isbold && ![ishighlighted
$id]} {
3337 bolden
$row mainfontbold
3340 set rhighlights
($id) $isbold
3343 # Graph layout functions
3345 proc shortids
{ids
} {
3348 if {[llength
$id] > 1} {
3349 lappend res
[shortids
$id]
3350 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
3351 lappend res
[string range
$id 0 7]
3362 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
3363 if {($n & $mask) != 0} {
3364 set ret
[concat
$ret $o]
3366 set o
[concat
$o $o]
3371 proc ordertoken
{id
} {
3372 global ordertok curview varcid varcstart varctok curview parents children
3373 global nullid nullid2
3375 if {[info exists ordertok
($id)]} {
3376 return $ordertok($id)
3381 if {[info exists varcid
($curview,$id)]} {
3382 set a
$varcid($curview,$id)
3383 set p
[lindex
$varcstart($curview) $a]
3385 set p
[lindex
$children($curview,$id) 0]
3387 if {[info exists ordertok
($p)]} {
3388 set tok
$ordertok($p)
3391 set id
[first_real_child
$curview,$p]
3394 set tok
[lindex
$varctok($curview) $a]
3397 if {[llength
$parents($curview,$id)] == 1} {
3398 lappend todo
[list
$p {}]
3400 set j
[lsearch
-exact $parents($curview,$id) $p]
3402 puts
"oops didn't find [shortids $p] in parents of [shortids $id]"
3404 lappend todo
[list
$p [strrep
$j]]
3407 for {set i
[llength
$todo]} {[incr i
-1] >= 0} {} {
3408 set p
[lindex
$todo $i 0]
3409 append tok
[lindex
$todo $i 1]
3410 set ordertok
($p) $tok
3412 set ordertok
($origid) $tok
3416 # Work out where id should go in idlist so that order-token
3417 # values increase from left to right
3418 proc idcol
{idlist id
{i
0}} {
3419 set t
[ordertoken
$id]
3423 if {$i >= [llength
$idlist] ||
$t < [ordertoken
[lindex
$idlist $i]]} {
3424 if {$i > [llength
$idlist]} {
3425 set i
[llength
$idlist]
3427 while {[incr i
-1] >= 0 && $t < [ordertoken
[lindex
$idlist $i]]} {}
3430 if {$t > [ordertoken
[lindex
$idlist $i]]} {
3431 while {[incr i
] < [llength
$idlist] &&
3432 $t >= [ordertoken
[lindex
$idlist $i]]} {}
3438 proc initlayout
{} {
3439 global rowidlist rowisopt rowfinal displayorder parentlist
3440 global numcommits canvxmax canv
3442 global colormap rowtextx
3452 set canvxmax
[$canv cget
-width]
3453 catch
{unset colormap
}
3454 catch
{unset rowtextx
}
3458 proc setcanvscroll
{} {
3459 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3461 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3462 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
3463 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
3464 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
3467 proc visiblerows
{} {
3468 global canv numcommits linespc
3470 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3471 if {$ymax eq
{} ||
$ymax == 0} return
3473 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
3474 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
3478 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
3479 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
3480 if {$r1 >= $numcommits} {
3481 set r1
[expr {$numcommits - 1}]
3483 return [list
$r0 $r1]
3486 proc layoutmore
{} {
3487 global commitidx viewcomplete curview
3488 global numcommits pending_select selectedline curview
3489 global selectfirst lastscrollset commitinterest
3491 set canshow
$commitidx($curview)
3492 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3493 if {$numcommits == 0} {
3497 set prev
$numcommits
3498 set numcommits
$canshow
3499 set t
[clock clicks
-milliseconds]
3500 if {$prev < 100 ||
$viewcomplete($curview) ||
$t - $lastscrollset > 500} {
3501 set lastscrollset
$t
3504 set rows
[visiblerows
]
3505 set r1
[lindex
$rows 1]
3506 if {$r1 >= $canshow} {
3507 set r1
[expr {$canshow - 1}]
3512 if {[info exists pending_select
] &&
3513 [commitinview
$pending_select $curview]} {
3514 selectline
[rowofcommit
$pending_select] 1
3517 if {[info exists selectedline
] ||
[info exists pending_select
]} {
3520 set l
[first_real_row
]
3527 proc doshowlocalchanges
{} {
3528 global curview mainheadid
3530 if {[commitinview
$mainheadid $curview]} {
3533 lappend commitinterest
($mainheadid) {dodiffindex
}
3537 proc dohidelocalchanges
{} {
3538 global nullid nullid2 lserial curview
3540 if {[commitinview
$nullid $curview]} {
3541 removerow
$nullid $curview
3543 if {[commitinview
$nullid2 $curview]} {
3544 removerow
$nullid2 $curview
3549 # spawn off a process to do git diff-index --cached HEAD
3550 proc dodiffindex
{} {
3551 global lserial showlocalchanges
3553 if {!$showlocalchanges} return
3555 set fd
[open
"|git diff-index --cached HEAD" r
]
3556 fconfigure
$fd -blocking 0
3557 filerun
$fd [list readdiffindex
$fd $lserial]
3560 proc readdiffindex
{fd serial
} {
3561 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3564 if {[gets
$fd line
] < 0} {
3570 # we only need to see one line and we don't really care what it says...
3573 if {$serial != $lserial} {
3577 # now see if there are any local changes not checked in to the index
3578 set fd
[open
"|git diff-files" r
]
3579 fconfigure
$fd -blocking 0
3580 filerun
$fd [list readdifffiles
$fd $serial]
3582 if {$isdiff && ![commitinview
$nullid2 $curview]} {
3583 # add the line for the changes in the index to the graph
3584 set hl
[mc
"Local changes checked in to index but not committed"]
3585 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
3586 set commitdata
($nullid2) "\n $hl\n"
3587 if {[commitinview
$nullid $curview]} {
3588 removerow
$nullid $curview
3590 insertrow
$nullid2 $mainheadid $curview
3591 } elseif
{!$isdiff && [commitinview
$nullid2 $curview]} {
3592 removerow
$nullid2 $curview
3597 proc readdifffiles
{fd serial
} {
3598 global mainheadid nullid nullid2 curview
3599 global commitinfo commitdata lserial
3602 if {[gets
$fd line
] < 0} {
3608 # we only need to see one line and we don't really care what it says...
3611 if {$serial != $lserial} {
3615 if {$isdiff && ![commitinview
$nullid $curview]} {
3616 # add the line for the local diff to the graph
3617 set hl
[mc
"Local uncommitted changes, not checked in to index"]
3618 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
3619 set commitdata
($nullid) "\n $hl\n"
3620 if {[commitinview
$nullid2 $curview]} {
3625 insertrow
$nullid $p $curview
3626 } elseif
{!$isdiff && [commitinview
$nullid $curview]} {
3627 removerow
$nullid $curview
3632 proc nextuse
{id row
} {
3633 global curview children
3635 if {[info exists children
($curview,$id)]} {
3636 foreach kid
$children($curview,$id) {
3637 if {![commitinview
$kid $curview]} {
3640 if {[rowofcommit
$kid] > $row} {
3641 return [rowofcommit
$kid]
3645 if {[commitinview
$id $curview]} {
3646 return [rowofcommit
$id]
3651 proc prevuse
{id row
} {
3652 global curview children
3655 if {[info exists children
($curview,$id)]} {
3656 foreach kid
$children($curview,$id) {
3657 if {![commitinview
$kid $curview]} break
3658 if {[rowofcommit
$kid] < $row} {
3659 set ret
[rowofcommit
$kid]
3666 proc make_idlist
{row
} {
3667 global displayorder parentlist uparrowlen downarrowlen mingaplen
3668 global commitidx curview children
3670 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
3674 set ra
[expr {$row - $downarrowlen}]
3678 set rb
[expr {$row + $uparrowlen}]
3679 if {$rb > $commitidx($curview)} {
3680 set rb
$commitidx($curview)
3682 make_disporder
$r [expr {$rb + 1}]
3684 for {} {$r < $ra} {incr r
} {
3685 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3686 foreach p
[lindex
$parentlist $r] {
3687 if {$p eq
$nextid} continue
3688 set rn
[nextuse
$p $r]
3690 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3691 lappend ids
[list
[ordertoken
$p] $p]
3695 for {} {$r < $row} {incr r
} {
3696 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3697 foreach p
[lindex
$parentlist $r] {
3698 if {$p eq
$nextid} continue
3699 set rn
[nextuse
$p $r]
3700 if {$rn < 0 ||
$rn >= $row} {
3701 lappend ids
[list
[ordertoken
$p] $p]
3705 set id
[lindex
$displayorder $row]
3706 lappend ids
[list
[ordertoken
$id] $id]
3708 foreach p
[lindex
$parentlist $r] {
3709 set firstkid
[lindex
$children($curview,$p) 0]
3710 if {[rowofcommit
$firstkid] < $row} {
3711 lappend ids
[list
[ordertoken
$p] $p]
3715 set id
[lindex
$displayorder $r]
3717 set firstkid
[lindex
$children($curview,$id) 0]
3718 if {$firstkid ne
{} && [rowofcommit
$firstkid] < $row} {
3719 lappend ids
[list
[ordertoken
$id] $id]
3724 foreach idx
[lsort
-unique $ids] {
3725 lappend idlist
[lindex
$idx 1]
3730 proc rowsequal
{a b
} {
3731 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3732 set a
[lreplace
$a $i $i]
3734 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3735 set b
[lreplace
$b $i $i]
3737 return [expr {$a eq
$b}]
3740 proc makeupline
{id row rend
col} {
3741 global rowidlist uparrowlen downarrowlen mingaplen
3743 for {set r
$rend} {1} {set r
$rstart} {
3744 set rstart
[prevuse
$id $r]
3745 if {$rstart < 0} return
3746 if {$rstart < $row} break
3748 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3749 set rstart
[expr {$rend - $uparrowlen - 1}]
3751 for {set r
$rstart} {[incr r
] <= $row} {} {
3752 set idlist
[lindex
$rowidlist $r]
3753 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3754 set col [idcol
$idlist $id $col]
3755 lset rowidlist
$r [linsert
$idlist $col $id]
3761 proc layoutrows
{row endrow
} {
3762 global rowidlist rowisopt rowfinal displayorder
3763 global uparrowlen downarrowlen maxwidth mingaplen
3764 global children parentlist
3765 global commitidx viewcomplete curview
3767 make_disporder
[expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3770 set rm1
[expr {$row - 1}]
3771 foreach id
[lindex
$rowidlist $rm1] {
3776 set final
[lindex
$rowfinal $rm1]
3778 for {} {$row < $endrow} {incr row
} {
3779 set rm1
[expr {$row - 1}]
3780 if {$rm1 < 0 ||
$idlist eq
{}} {
3781 set idlist
[make_idlist
$row]
3784 set id
[lindex
$displayorder $rm1]
3785 set col [lsearch
-exact $idlist $id]
3786 set idlist
[lreplace
$idlist $col $col]
3787 foreach p
[lindex
$parentlist $rm1] {
3788 if {[lsearch
-exact $idlist $p] < 0} {
3789 set col [idcol
$idlist $p $col]
3790 set idlist
[linsert
$idlist $col $p]
3791 # if not the first child, we have to insert a line going up
3792 if {$id ne
[lindex
$children($curview,$p) 0]} {
3793 makeupline
$p $rm1 $row $col
3797 set id
[lindex
$displayorder $row]
3798 if {$row > $downarrowlen} {
3799 set termrow
[expr {$row - $downarrowlen - 1}]
3800 foreach p
[lindex
$parentlist $termrow] {
3801 set i
[lsearch
-exact $idlist $p]
3802 if {$i < 0} continue
3803 set nr
[nextuse
$p $termrow]
3804 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3805 set idlist
[lreplace
$idlist $i $i]
3809 set col [lsearch
-exact $idlist $id]
3811 set col [idcol
$idlist $id]
3812 set idlist
[linsert
$idlist $col $id]
3813 if {$children($curview,$id) ne
{}} {
3814 makeupline
$id $rm1 $row $col
3817 set r
[expr {$row + $uparrowlen - 1}]
3818 if {$r < $commitidx($curview)} {
3820 foreach p
[lindex
$parentlist $r] {
3821 if {[lsearch
-exact $idlist $p] >= 0} continue
3822 set fk
[lindex
$children($curview,$p) 0]
3823 if {[rowofcommit
$fk] < $row} {
3824 set x
[idcol
$idlist $p $x]
3825 set idlist
[linsert
$idlist $x $p]
3828 if {[incr r
] < $commitidx($curview)} {
3829 set p
[lindex
$displayorder $r]
3830 if {[lsearch
-exact $idlist $p] < 0} {
3831 set fk
[lindex
$children($curview,$p) 0]
3832 if {$fk ne
{} && [rowofcommit
$fk] < $row} {
3833 set x
[idcol
$idlist $p $x]
3834 set idlist
[linsert
$idlist $x $p]
3840 if {$final && !$viewcomplete($curview) &&
3841 $row + $uparrowlen + $mingaplen + $downarrowlen
3842 >= $commitidx($curview)} {
3845 set l
[llength
$rowidlist]
3847 lappend rowidlist
$idlist
3849 lappend rowfinal
$final
3850 } elseif
{$row < $l} {
3851 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3852 lset rowidlist
$row $idlist
3855 lset rowfinal
$row $final
3857 set pad
[ntimes
[expr {$row - $l}] {}]
3858 set rowidlist
[concat
$rowidlist $pad]
3859 lappend rowidlist
$idlist
3860 set rowfinal
[concat
$rowfinal $pad]
3861 lappend rowfinal
$final
3862 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3868 proc changedrow
{row
} {
3869 global displayorder iddrawn rowisopt need_redisplay
3871 set l
[llength
$rowisopt]
3873 lset rowisopt
$row 0
3874 if {$row + 1 < $l} {
3875 lset rowisopt
[expr {$row + 1}] 0
3876 if {$row + 2 < $l} {
3877 lset rowisopt
[expr {$row + 2}] 0
3881 set id
[lindex
$displayorder $row]
3882 if {[info exists iddrawn
($id)]} {
3883 set need_redisplay
1
3887 proc insert_pad
{row
col npad
} {
3890 set pad
[ntimes
$npad {}]
3891 set idlist
[lindex
$rowidlist $row]
3892 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3893 set aft
[lrange
$idlist $col end
]
3894 set i
[lsearch
-exact $aft {}]
3896 set aft
[lreplace
$aft $i $i]
3898 lset rowidlist
$row [concat
$bef $pad $aft]
3902 proc optimize_rows
{row
col endrow
} {
3903 global rowidlist rowisopt displayorder curview children
3908 for {} {$row < $endrow} {incr row
; set col 0} {
3909 if {[lindex
$rowisopt $row]} continue
3911 set y0
[expr {$row - 1}]
3912 set ym
[expr {$row - 2}]
3913 set idlist
[lindex
$rowidlist $row]
3914 set previdlist
[lindex
$rowidlist $y0]
3915 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3917 set pprevidlist
[lindex
$rowidlist $ym]
3918 if {$pprevidlist eq
{}} continue
3924 for {} {$col < [llength
$idlist]} {incr
col} {
3925 set id
[lindex
$idlist $col]
3926 if {[lindex
$previdlist $col] eq
$id} continue
3931 set x0
[lsearch
-exact $previdlist $id]
3932 if {$x0 < 0} continue
3933 set z
[expr {$x0 - $col}]
3937 set xm
[lsearch
-exact $pprevidlist $id]
3939 set z0
[expr {$xm - $x0}]
3943 # if row y0 is the first child of $id then it's not an arrow
3944 if {[lindex
$children($curview,$id) 0] ne
3945 [lindex
$displayorder $y0]} {
3949 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3950 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3953 # Looking at lines from this row to the previous row,
3954 # make them go straight up if they end in an arrow on
3955 # the previous row; otherwise make them go straight up
3957 if {$z < -1 ||
($z < 0 && $isarrow)} {
3958 # Line currently goes left too much;
3959 # insert pads in the previous row, then optimize it
3960 set npad
[expr {-1 - $z + $isarrow}]
3961 insert_pad
$y0 $x0 $npad
3963 optimize_rows
$y0 $x0 $row
3965 set previdlist
[lindex
$rowidlist $y0]
3966 set x0
[lsearch
-exact $previdlist $id]
3967 set z
[expr {$x0 - $col}]
3969 set pprevidlist
[lindex
$rowidlist $ym]
3970 set xm
[lsearch
-exact $pprevidlist $id]
3971 set z0
[expr {$xm - $x0}]
3973 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3974 # Line currently goes right too much;
3975 # insert pads in this line
3976 set npad
[expr {$z - 1 + $isarrow}]
3977 insert_pad
$row $col $npad
3978 set idlist
[lindex
$rowidlist $row]
3980 set z
[expr {$x0 - $col}]
3983 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3984 # this line links to its first child on row $row-2
3985 set id
[lindex
$displayorder $ym]
3986 set xc
[lsearch
-exact $pprevidlist $id]
3988 set z0
[expr {$xc - $x0}]
3991 # avoid lines jigging left then immediately right
3992 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3993 insert_pad
$y0 $x0 1
3995 optimize_rows
$y0 $x0 $row
3996 set previdlist
[lindex
$rowidlist $y0]
4000 # Find the first column that doesn't have a line going right
4001 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
4002 set id
[lindex
$idlist $col]
4003 if {$id eq
{}} break
4004 set x0
[lsearch
-exact $previdlist $id]
4006 # check if this is the link to the first child
4007 set kid
[lindex
$displayorder $y0]
4008 if {[lindex
$children($curview,$id) 0] eq
$kid} {
4009 # it is, work out offset to child
4010 set x0
[lsearch
-exact $previdlist $kid]
4013 if {$x0 <= $col} break
4015 # Insert a pad at that column as long as it has a line and
4016 # isn't the last column
4017 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
4018 set idlist
[linsert
$idlist $col {}]
4019 lset rowidlist
$row $idlist
4027 global canvx0 linespc
4028 return [expr {$canvx0 + $col * $linespc}]
4032 global canvy0 linespc
4033 return [expr {$canvy0 + $row * $linespc}]
4036 proc linewidth
{id
} {
4037 global thickerline lthickness
4040 if {[info exists thickerline
] && $id eq
$thickerline} {
4041 set wid
[expr {2 * $lthickness}]
4046 proc rowranges
{id
} {
4047 global curview children uparrowlen downarrowlen
4050 set kids
$children($curview,$id)
4056 foreach child
$kids {
4057 if {![commitinview
$child $curview]} break
4058 set row
[rowofcommit
$child]
4059 if {![info exists prev
]} {
4060 lappend ret
[expr {$row + 1}]
4062 if {$row <= $prevrow} {
4063 puts
"oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4065 # see if the line extends the whole way from prevrow to row
4066 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4067 [lsearch
-exact [lindex
$rowidlist \
4068 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
4069 # it doesn't, see where it ends
4070 set r
[expr {$prevrow + $downarrowlen}]
4071 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4072 while {[incr r
-1] > $prevrow &&
4073 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4075 while {[incr r
] <= $row &&
4076 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4080 # see where it starts up again
4081 set r
[expr {$row - $uparrowlen}]
4082 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4083 while {[incr r
] < $row &&
4084 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4086 while {[incr r
-1] >= $prevrow &&
4087 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4093 if {$child eq
$id} {
4102 proc drawlineseg
{id row endrow arrowlow
} {
4103 global rowidlist displayorder iddrawn linesegs
4104 global canv colormap linespc curview maxlinelen parentlist
4106 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
4107 set le
[expr {$row + 1}]
4110 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
4116 set x
[lindex
$displayorder $le]
4121 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
4122 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
4138 if {[info exists linesegs
($id)]} {
4139 set lines
$linesegs($id)
4141 set r0
[lindex
$li 0]
4143 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
4153 set li
[lindex
$lines [expr {$i-1}]]
4154 set r1
[lindex
$li 1]
4155 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
4160 set x
[lindex
$cols [expr {$le - $row}]]
4161 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
4162 set dir
[expr {$xp - $x}]
4164 set ith
[lindex
$lines $i 2]
4165 set coords
[$canv coords
$ith]
4166 set ah
[$canv itemcget
$ith -arrow]
4167 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
4168 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
4169 if {$x2 ne
{} && $x - $x2 == $dir} {
4170 set coords
[lrange
$coords 0 end-2
]
4173 set coords
[list
[xc
$le $x] [yc
$le]]
4176 set itl
[lindex
$lines [expr {$i-1}] 2]
4177 set al
[$canv itemcget
$itl -arrow]
4178 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
4179 } elseif
{$arrowlow} {
4180 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
4181 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
4185 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
4186 for {set y
$le} {[incr y
-1] > $row} {} {
4188 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
4189 set ndir
[expr {$xp - $x}]
4190 if {$dir != $ndir ||
$xp < 0} {
4191 lappend coords
[xc
$y $x] [yc
$y]
4197 # join parent line to first child
4198 set ch
[lindex
$displayorder $row]
4199 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
4201 puts
"oops: drawlineseg: child $ch not on row $row"
4202 } elseif
{$xc != $x} {
4203 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
4204 set d
[expr {int
(0.5 * $linespc)}]
4207 set x2
[expr {$x1 - $d}]
4209 set x2
[expr {$x1 + $d}]
4212 set y1
[expr {$y2 + $d}]
4213 lappend coords
$x1 $y1 $x2 $y2
4214 } elseif
{$xc < $x - 1} {
4215 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
4216 } elseif
{$xc > $x + 1} {
4217 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
4221 lappend coords
[xc
$row $x] [yc
$row]
4223 set xn
[xc
$row $xp]
4225 lappend coords
$xn $yn
4229 set t
[$canv create line
$coords -width [linewidth
$id] \
4230 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
4233 set lines
[linsert
$lines $i [list
$row $le $t]]
4235 $canv coords
$ith $coords
4236 if {$arrow ne
$ah} {
4237 $canv itemconf
$ith -arrow $arrow
4239 lset lines
$i 0 $row
4242 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
4243 set ndir
[expr {$xo - $xp}]
4244 set clow
[$canv coords
$itl]
4245 if {$dir == $ndir} {
4246 set clow
[lrange
$clow 2 end
]
4248 set coords
[concat
$coords $clow]
4250 lset lines
[expr {$i-1}] 1 $le
4252 # coalesce two pieces
4254 set b
[lindex
$lines [expr {$i-1}] 0]
4255 set e
[lindex
$lines $i 1]
4256 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
4258 $canv coords
$itl $coords
4259 if {$arrow ne
$al} {
4260 $canv itemconf
$itl -arrow $arrow
4264 set linesegs
($id) $lines
4268 proc drawparentlinks
{id row
} {
4269 global rowidlist canv colormap curview parentlist
4270 global idpos linespc
4272 set rowids
[lindex
$rowidlist $row]
4273 set col [lsearch
-exact $rowids $id]
4274 if {$col < 0} return
4275 set olds
[lindex
$parentlist $row]
4276 set row2
[expr {$row + 1}]
4277 set x
[xc
$row $col]
4280 set d
[expr {int
(0.5 * $linespc)}]
4281 set ymid
[expr {$y + $d}]
4282 set ids
[lindex
$rowidlist $row2]
4283 # rmx = right-most X coord used
4286 set i
[lsearch
-exact $ids $p]
4288 puts
"oops, parent $p of $id not in list"
4291 set x2
[xc
$row2 $i]
4295 set j
[lsearch
-exact $rowids $p]
4297 # drawlineseg will do this one for us
4301 # should handle duplicated parents here...
4302 set coords
[list
$x $y]
4304 # if attaching to a vertical segment, draw a smaller
4305 # slant for visual distinctness
4308 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
4310 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
4312 } elseif
{$i < $col && $i < $j} {
4313 # segment slants towards us already
4314 lappend coords
[xc
$row $j] $y
4316 if {$i < $col - 1} {
4317 lappend coords
[expr {$x2 + $linespc}] $y
4318 } elseif
{$i > $col + 1} {
4319 lappend coords
[expr {$x2 - $linespc}] $y
4321 lappend coords
$x2 $y2
4324 lappend coords
$x2 $y2
4326 set t
[$canv create line
$coords -width [linewidth
$p] \
4327 -fill $colormap($p) -tags lines.
$p]
4331 if {$rmx > [lindex
$idpos($id) 1]} {
4332 lset idpos
($id) 1 $rmx
4337 proc drawlines
{id
} {
4340 $canv itemconf lines.
$id -width [linewidth
$id]
4343 proc drawcmittext
{id row
col} {
4344 global linespc canv canv2 canv3 fgcolor curview
4345 global cmitlisted commitinfo rowidlist parentlist
4346 global rowtextx idpos idtags idheads idotherrefs
4347 global linehtag linentag linedtag selectedline
4348 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4350 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4351 set listed
$cmitlisted($curview,$id)
4352 if {$id eq
$nullid} {
4354 } elseif
{$id eq
$nullid2} {
4357 set ofill
[expr {$listed != 0?
"blue": "white"}]
4359 set x
[xc
$row $col]
4361 set orad
[expr {$linespc / 3}]
4363 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
4364 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4365 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4366 } elseif
{$listed == 2} {
4367 # triangle pointing left for left-side commits
4368 set t
[$canv create polygon \
4369 [expr {$x - $orad}] $y \
4370 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4371 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4372 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4374 # triangle pointing right for right-side commits
4375 set t
[$canv create polygon \
4376 [expr {$x + $orad - 1}] $y \
4377 [expr {$x - $orad}] [expr {$y - $orad}] \
4378 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4379 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4382 $canv bind $t <1> {selcanvline
{} %x
%y
}
4383 set rmx
[llength
[lindex
$rowidlist $row]]
4384 set olds
[lindex
$parentlist $row]
4386 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
4388 set i
[lsearch
-exact $nextids $p]
4394 set xt
[xc
$row $rmx]
4395 set rowtextx
($row) $xt
4396 set idpos
($id) [list
$x $xt $y]
4397 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
4398 ||
[info exists idotherrefs
($id)]} {
4399 set xt
[drawtags
$id $x $xt $y]
4401 set headline
[lindex
$commitinfo($id) 0]
4402 set name
[lindex
$commitinfo($id) 1]
4403 set date [lindex
$commitinfo($id) 2]
4404 set date [formatdate
$date]
4407 set isbold
[ishighlighted
$id]
4409 lappend boldrows
$row
4410 set font mainfontbold
4412 lappend boldnamerows
$row
4413 set nfont mainfontbold
4416 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
4417 -text $headline -font $font -tags text
]
4418 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
4419 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
4420 -text $name -font $nfont -tags text
]
4421 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
4422 -text $date -font mainfont
-tags text
]
4423 if {[info exists selectedline
] && $selectedline == $row} {
4426 set xr
[expr {$xt + [font measure
$font $headline]}]
4427 if {$xr > $canvxmax} {
4433 proc drawcmitrow
{row
} {
4434 global displayorder rowidlist nrows_drawn
4435 global iddrawn markingmatches
4436 global commitinfo numcommits
4437 global filehighlight fhighlights findpattern nhighlights
4438 global hlview vhighlights
4439 global highlight_related rhighlights
4441 if {$row >= $numcommits} return
4443 set id
[lindex
$displayorder $row]
4444 if {[info exists hlview
] && ![info exists vhighlights
($id)]} {
4445 askvhighlight
$row $id
4447 if {[info exists filehighlight
] && ![info exists fhighlights
($id)]} {
4448 askfilehighlight
$row $id
4450 if {$findpattern ne
{} && ![info exists nhighlights
($id)]} {
4451 askfindhighlight
$row $id
4453 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($id)]} {
4454 askrelhighlight
$row $id
4456 if {![info exists iddrawn
($id)]} {
4457 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
4459 puts
"oops, row $row id $id not in list"
4462 if {![info exists commitinfo
($id)]} {
4466 drawcmittext
$id $row $col
4470 if {$markingmatches} {
4471 markrowmatches
$row $id
4475 proc drawcommits
{row
{endrow
{}}} {
4476 global numcommits iddrawn displayorder curview need_redisplay
4477 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4482 if {$endrow eq
{}} {
4485 if {$endrow >= $numcommits} {
4486 set endrow
[expr {$numcommits - 1}]
4489 set rl1
[expr {$row - $downarrowlen - 3}]
4493 set ro1
[expr {$row - 3}]
4497 set r2
[expr {$endrow + $uparrowlen + 3}]
4498 if {$r2 > $numcommits} {
4501 for {set r
$rl1} {$r < $r2} {incr r
} {
4502 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
4506 set rl1
[expr {$r + 1}]
4512 optimize_rows
$ro1 0 $r2
4513 if {$need_redisplay ||
$nrows_drawn > 2000} {
4518 # make the lines join to already-drawn rows either side
4519 set r
[expr {$row - 1}]
4520 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
4523 set er
[expr {$endrow + 1}]
4524 if {$er >= $numcommits ||
4525 ![info exists iddrawn
([lindex
$displayorder $er])]} {
4528 for {} {$r <= $er} {incr r
} {
4529 set id
[lindex
$displayorder $r]
4530 set wasdrawn
[info exists iddrawn
($id)]
4532 if {$r == $er} break
4533 set nextid
[lindex
$displayorder [expr {$r + 1}]]
4534 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
4535 drawparentlinks
$id $r
4537 set rowids
[lindex
$rowidlist $r]
4538 foreach lid
$rowids {
4539 if {$lid eq
{}} continue
4540 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
4542 # see if this is the first child of any of its parents
4543 foreach p
[lindex
$parentlist $r] {
4544 if {[lsearch
-exact $rowids $p] < 0} {
4545 # make this line extend up to the child
4546 set lineend
($p) [drawlineseg
$p $r $er 0]
4550 set lineend
($lid) [drawlineseg
$lid $r $er 1]
4556 proc undolayout
{row
} {
4557 global uparrowlen mingaplen downarrowlen
4558 global rowidlist rowisopt rowfinal need_redisplay
4560 set r
[expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4564 if {[llength
$rowidlist] > $r} {
4566 set rowidlist
[lrange
$rowidlist 0 $r]
4567 set rowfinal
[lrange
$rowfinal 0 $r]
4568 set rowisopt
[lrange
$rowisopt 0 $r]
4569 set need_redisplay
1
4574 proc drawvisible
{} {
4575 global canv linespc curview vrowmod selectedline targetrow targetid
4576 global need_redisplay cscroll numcommits
4578 set fs
[$canv yview
]
4579 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4580 if {$ymax eq
{} ||
$ymax == 0} return
4581 set f0
[lindex
$fs 0]
4582 set f1
[lindex
$fs 1]
4583 set y0
[expr {int
($f0 * $ymax)}]
4584 set y1
[expr {int
($f1 * $ymax)}]
4586 if {[info exists targetid
]} {
4587 if {[commitinview
$targetid $curview]} {
4588 set r
[rowofcommit
$targetid]
4589 if {$r != $targetrow} {
4590 # Fix up the scrollregion and change the scrolling position
4591 # now that our target row has moved.
4592 set diff [expr {($r - $targetrow) * $linespc}]
4595 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4598 set f0
[expr {$y0 / $ymax}]
4599 set f1
[expr {$y1 / $ymax}]
4600 allcanvs yview moveto
$f0
4601 $cscroll set $f0 $f1
4602 set need_redisplay
1
4609 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
4610 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
4611 if {$endrow >= $vrowmod($curview)} {
4612 update_arcrows
$curview
4614 if {[info exists selectedline
] &&
4615 $row <= $selectedline && $selectedline <= $endrow} {
4616 set targetrow
$selectedline
4618 set targetrow
[expr {int
(($row + $endrow) / 2)}]
4620 if {$targetrow >= $numcommits} {
4621 set targetrow
[expr {$numcommits - 1}]
4623 set targetid
[commitonrow
$targetrow]
4624 drawcommits
$row $endrow
4627 proc clear_display
{} {
4628 global iddrawn linesegs need_redisplay nrows_drawn
4629 global vhighlights fhighlights nhighlights rhighlights
4632 catch
{unset iddrawn
}
4633 catch
{unset linesegs
}
4634 catch
{unset vhighlights
}
4635 catch
{unset fhighlights
}
4636 catch
{unset nhighlights
}
4637 catch
{unset rhighlights
}
4638 set need_redisplay
0
4642 proc findcrossings
{id
} {
4643 global rowidlist parentlist numcommits displayorder
4647 foreach
{s e
} [rowranges
$id] {
4648 if {$e >= $numcommits} {
4649 set e
[expr {$numcommits - 1}]
4651 if {$e <= $s} continue
4652 for {set row
$e} {[incr row
-1] >= $s} {} {
4653 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
4655 set olds
[lindex
$parentlist $row]
4656 set kid
[lindex
$displayorder $row]
4657 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
4658 if {$kidx < 0} continue
4659 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
4661 set px
[lsearch
-exact $nextrow $p]
4662 if {$px < 0} continue
4663 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
4664 if {[lsearch
-exact $ccross $p] >= 0} continue
4665 if {$x == $px + ($kidx < $px?
-1: 1)} {
4667 } elseif
{[lsearch
-exact $cross $p] < 0} {
4674 return [concat
$ccross {{}} $cross]
4677 proc assigncolor
{id
} {
4678 global colormap colors nextcolor
4679 global parents children children curview
4681 if {[info exists colormap
($id)]} return
4682 set ncolors
[llength
$colors]
4683 if {[info exists children
($curview,$id)]} {
4684 set kids
$children($curview,$id)
4688 if {[llength
$kids] == 1} {
4689 set child
[lindex
$kids 0]
4690 if {[info exists colormap
($child)]
4691 && [llength
$parents($curview,$child)] == 1} {
4692 set colormap
($id) $colormap($child)
4698 foreach x
[findcrossings
$id] {
4700 # delimiter between corner crossings and other crossings
4701 if {[llength
$badcolors] >= $ncolors - 1} break
4702 set origbad
$badcolors
4704 if {[info exists colormap
($x)]
4705 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
4706 lappend badcolors
$colormap($x)
4709 if {[llength
$badcolors] >= $ncolors} {
4710 set badcolors
$origbad
4712 set origbad
$badcolors
4713 if {[llength
$badcolors] < $ncolors - 1} {
4714 foreach child
$kids {
4715 if {[info exists colormap
($child)]
4716 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
4717 lappend badcolors
$colormap($child)
4719 foreach p
$parents($curview,$child) {
4720 if {[info exists colormap
($p)]
4721 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
4722 lappend badcolors
$colormap($p)
4726 if {[llength
$badcolors] >= $ncolors} {
4727 set badcolors
$origbad
4730 for {set i
0} {$i <= $ncolors} {incr i
} {
4731 set c
[lindex
$colors $nextcolor]
4732 if {[incr nextcolor
] >= $ncolors} {
4735 if {[lsearch
-exact $badcolors $c]} break
4737 set colormap
($id) $c
4740 proc bindline
{t id
} {
4743 $canv bind $t <Enter
> "lineenter %x %y $id"
4744 $canv bind $t <Motion
> "linemotion %x %y $id"
4745 $canv bind $t <Leave
> "lineleave $id"
4746 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4749 proc drawtags
{id x xt y1
} {
4750 global idtags idheads idotherrefs mainhead
4751 global linespc lthickness
4752 global canv rowtextx curview fgcolor bgcolor
4757 if {[info exists idtags
($id)]} {
4758 set marks
$idtags($id)
4759 set ntags
[llength
$marks]
4761 if {[info exists idheads
($id)]} {
4762 set marks
[concat
$marks $idheads($id)]
4763 set nheads
[llength
$idheads($id)]
4765 if {[info exists idotherrefs
($id)]} {
4766 set marks
[concat
$marks $idotherrefs($id)]
4772 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4773 set yt
[expr {$y1 - 0.5 * $linespc}]
4774 set yb
[expr {$yt + $linespc - 1}]
4778 foreach tag
$marks {
4780 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4781 set wid
[font measure mainfontbold
$tag]
4783 set wid
[font measure mainfont
$tag]
4787 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4789 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4790 -width $lthickness -fill black
-tags tag.
$id]
4792 foreach tag
$marks x
$xvals wid
$wvals {
4793 set xl
[expr {$x + $delta}]
4794 set xr
[expr {$x + $delta + $wid + $lthickness}]
4796 if {[incr ntags
-1] >= 0} {
4798 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4799 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4800 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4801 $canv bind $t <1> [list showtag
$tag 1]
4802 set rowtextx
([rowofcommit
$id]) [expr {$xr + $linespc}]
4804 # draw a head or other ref
4805 if {[incr nheads
-1] >= 0} {
4807 if {$tag eq
$mainhead} {
4808 set font mainfontbold
4813 set xl
[expr {$xl - $delta/2}]
4814 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4815 -width 1 -outline black
-fill $col -tags tag.
$id
4816 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4817 set rwid
[font measure mainfont
$remoteprefix]
4818 set xi
[expr {$x + 1}]
4819 set yti
[expr {$yt + 1}]
4820 set xri
[expr {$x + $rwid}]
4821 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4822 -width 0 -fill "#ffddaa" -tags tag.
$id
4825 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4826 -font $font -tags [list tag.
$id text
]]
4828 $canv bind $t <1> [list showtag
$tag 1]
4829 } elseif
{$nheads >= 0} {
4830 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4836 proc xcoord
{i level
ln} {
4837 global canvx0 xspc1 xspc2
4839 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4840 if {$i > 0 && $i == $level} {
4841 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4842 } elseif
{$i > $level} {
4843 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4848 proc show_status
{msg
} {
4852 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4853 -tags text
-fill $fgcolor
4856 # Don't change the text pane cursor if it is currently the hand cursor,
4857 # showing that we are over a sha1 ID link.
4858 proc settextcursor
{c
} {
4859 global ctext curtextcursor
4861 if {[$ctext cget
-cursor] == $curtextcursor} {
4862 $ctext config
-cursor $c
4864 set curtextcursor
$c
4867 proc nowbusy
{what
{name
{}}} {
4868 global isbusy busyname statusw
4870 if {[array names isbusy
] eq
{}} {
4871 . config
-cursor watch
4875 set busyname
($what) $name
4877 $statusw conf
-text $name
4881 proc notbusy
{what
} {
4882 global isbusy maincursor textcursor busyname statusw
4886 if {$busyname($what) ne
{} &&
4887 [$statusw cget
-text] eq
$busyname($what)} {
4888 $statusw conf
-text {}
4891 if {[array names isbusy
] eq
{}} {
4892 . config
-cursor $maincursor
4893 settextcursor
$textcursor
4897 proc findmatches
{f
} {
4898 global findtype findstring
4899 if {$findtype == [mc
"Regexp"]} {
4900 set matches
[regexp
-indices -all -inline $findstring $f]
4903 if {$findtype == [mc
"IgnCase"]} {
4904 set f
[string tolower
$f]
4905 set fs
[string tolower
$fs]
4909 set l
[string length
$fs]
4910 while {[set j
[string first
$fs $f $i]] >= 0} {
4911 lappend matches
[list
$j [expr {$j+$l-1}]]
4912 set i
[expr {$j + $l}]
4918 proc dofind
{{dirn
1} {wrap
1}} {
4919 global findstring findstartline findcurline selectedline numcommits
4920 global gdttype filehighlight fh_serial find_dirn findallowwrap
4922 if {[info exists find_dirn
]} {
4923 if {$find_dirn == $dirn} return
4927 if {$findstring eq
{} ||
$numcommits == 0} return
4928 if {![info exists selectedline
]} {
4929 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4931 set findstartline
$selectedline
4933 set findcurline
$findstartline
4934 nowbusy finding
[mc
"Searching"]
4935 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4936 after cancel do_file_hl
$fh_serial
4937 do_file_hl
$fh_serial
4940 set findallowwrap
$wrap
4944 proc stopfinding
{} {
4945 global find_dirn findcurline fprogcoord
4947 if {[info exists find_dirn
]} {
4957 global commitdata commitinfo numcommits findpattern findloc
4958 global findstartline findcurline findallowwrap
4959 global find_dirn gdttype fhighlights fprogcoord
4960 global curview varcorder vrownum varccommits vrowmod
4962 if {![info exists find_dirn
]} {
4965 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4968 if {$find_dirn > 0} {
4970 if {$l >= $numcommits} {
4973 if {$l <= $findstartline} {
4974 set lim
[expr {$findstartline + 1}]
4977 set moretodo
$findallowwrap
4984 if {$l >= $findstartline} {
4985 set lim
[expr {$findstartline - 1}]
4988 set moretodo
$findallowwrap
4991 set n
[expr {($lim - $l) * $find_dirn}]
4996 if {$l + ($find_dirn > 0?
$n: 1) > $vrowmod($curview)} {
4997 update_arcrows
$curview
5001 set ai
[bsearch
$vrownum($curview) $l]
5002 set a
[lindex
$varcorder($curview) $ai]
5003 set arow
[lindex
$vrownum($curview) $ai]
5004 set ids
[lindex
$varccommits($curview,$a)]
5005 set arowend
[expr {$arow + [llength
$ids]}]
5006 if {$gdttype eq
[mc
"containing:"]} {
5007 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5008 if {$l < $arow ||
$l >= $arowend} {
5010 set a
[lindex
$varcorder($curview) $ai]
5011 set arow
[lindex
$vrownum($curview) $ai]
5012 set ids
[lindex
$varccommits($curview,$a)]
5013 set arowend
[expr {$arow + [llength
$ids]}]
5015 set id
[lindex
$ids [expr {$l - $arow}]]
5016 # shouldn't happen unless git log doesn't give all the commits...
5017 if {![info exists commitdata
($id)] ||
5018 ![doesmatch
$commitdata($id)]} {
5021 if {![info exists commitinfo
($id)]} {
5024 set info
$commitinfo($id)
5025 foreach f
$info ty
$fldtypes {
5026 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
5035 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5036 if {$l < $arow ||
$l >= $arowend} {
5038 set a
[lindex
$varcorder($curview) $ai]
5039 set arow
[lindex
$vrownum($curview) $ai]
5040 set ids
[lindex
$varccommits($curview,$a)]
5041 set arowend
[expr {$arow + [llength
$ids]}]
5043 set id
[lindex
$ids [expr {$l - $arow}]]
5044 if {![info exists fhighlights
($id)]} {
5045 # this sets fhighlights($id) to -1
5046 askfilehighlight
$l $id
5048 if {$fhighlights($id) > 0} {
5052 if {$fhighlights($id) < 0} {
5055 set findcurline
[expr {$l - $find_dirn}]
5060 if {$found ||
($domore && !$moretodo)} {
5076 set findcurline
[expr {$l - $find_dirn}]
5078 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
5082 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
5087 proc findselectline
{l
} {
5088 global findloc commentend ctext findcurline markingmatches gdttype
5090 set markingmatches
1
5093 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
5094 # highlight the matches in the comments
5095 set f
[$ctext get
1.0 $commentend]
5096 set matches
[findmatches
$f]
5097 foreach match
$matches {
5098 set start
[lindex
$match 0]
5099 set end
[expr {[lindex
$match 1] + 1}]
5100 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
5106 # mark the bits of a headline or author that match a find string
5107 proc markmatches
{canv l str tag matches font row
} {
5110 set bbox
[$canv bbox
$tag]
5111 set x0
[lindex
$bbox 0]
5112 set y0
[lindex
$bbox 1]
5113 set y1
[lindex
$bbox 3]
5114 foreach match
$matches {
5115 set start
[lindex
$match 0]
5116 set end
[lindex
$match 1]
5117 if {$start > $end} continue
5118 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
5119 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
5120 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
5121 [expr {$x0+$xlen+2}] $y1 \
5122 -outline {} -tags [list match
$l matches
] -fill yellow
]
5124 if {[info exists selectedline
] && $row == $selectedline} {
5125 $canv raise
$t secsel
5130 proc unmarkmatches
{} {
5131 global markingmatches
5133 allcanvs delete matches
5134 set markingmatches
0
5138 proc selcanvline
{w x y
} {
5139 global canv canvy0 ctext linespc
5141 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5142 if {$ymax == {}} return
5143 set yfrac
[lindex
[$canv yview
] 0]
5144 set y
[expr {$y + $yfrac * $ymax}]
5145 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
5150 set xmax
[lindex
[$canv cget
-scrollregion] 2]
5151 set xleft
[expr {[lindex
[$canv xview
] 0] * $xmax}]
5152 if {![info exists rowtextx
($l)] ||
$xleft + $x < $rowtextx($l)} return
5158 proc commit_descriptor
{p
} {
5160 if {![info exists commitinfo
($p)]} {
5164 if {[llength
$commitinfo($p)] > 1} {
5165 set l
[lindex
$commitinfo($p) 0]
5170 # append some text to the ctext widget, and make any SHA1 ID
5171 # that we know about be a clickable link.
5172 proc appendwithlinks
{text tags
} {
5173 global ctext linknum curview pendinglinks
5175 set start
[$ctext index
"end - 1c"]
5176 $ctext insert end
$text $tags
5177 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
5181 set linkid
[string range
$text $s $e]
5183 $ctext tag delete link
$linknum
5184 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
5185 setlink
$linkid link
$linknum
5190 proc setlink
{id lk
} {
5191 global curview ctext pendinglinks commitinterest
5193 if {[commitinview
$id $curview]} {
5194 $ctext tag conf
$lk -foreground blue
-underline 1
5195 $ctext tag
bind $lk <1> [list selectline
[rowofcommit
$id] 1]
5196 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
5197 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
5199 lappend pendinglinks
($id) $lk
5200 lappend commitinterest
($id) {makelink
%I
}
5204 proc makelink
{id
} {
5207 if {![info exists pendinglinks
($id)]} return
5208 foreach lk
$pendinglinks($id) {
5211 unset pendinglinks
($id)
5214 proc linkcursor
{w inc
} {
5215 global linkentercount curtextcursor
5217 if {[incr linkentercount
$inc] > 0} {
5218 $w configure
-cursor hand2
5220 $w configure
-cursor $curtextcursor
5221 if {$linkentercount < 0} {
5222 set linkentercount
0
5227 proc viewnextline
{dir
} {
5231 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5232 set wnow
[$canv yview
]
5233 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5234 set newtop
[expr {$wtop + $dir * $linespc}]
5237 } elseif
{$newtop > $ymax} {
5240 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5243 # add a list of tag or branch names at position pos
5244 # returns the number of names inserted
5245 proc appendrefs
{pos ids var
} {
5246 global ctext linknum curview
$var maxrefs
5248 if {[catch
{$ctext index
$pos}]} {
5251 $ctext conf
-state normal
5252 $ctext delete
$pos "$pos lineend"
5255 foreach tag
[set $var\
($id\
)] {
5256 lappend tags
[list
$tag $id]
5259 if {[llength
$tags] > $maxrefs} {
5260 $ctext insert
$pos "many ([llength $tags])"
5262 set tags
[lsort
-index 0 -decreasing $tags]
5265 set id
[lindex
$ti 1]
5268 $ctext tag delete
$lk
5269 $ctext insert
$pos $sep
5270 $ctext insert
$pos [lindex
$ti 0] $lk
5275 $ctext conf
-state disabled
5276 return [llength
$tags]
5279 # called when we have finished computing the nearby tags
5280 proc dispneartags
{delay
} {
5281 global selectedline currentid showneartags tagphase
5283 if {![info exists selectedline
] ||
!$showneartags} return
5284 after cancel dispnexttag
5286 after
200 dispnexttag
5289 after idle dispnexttag
5294 proc dispnexttag
{} {
5295 global selectedline currentid showneartags tagphase ctext
5297 if {![info exists selectedline
] ||
!$showneartags} return
5298 switch
-- $tagphase {
5300 set dtags
[desctags
$currentid]
5302 appendrefs precedes
$dtags idtags
5306 set atags
[anctags
$currentid]
5308 appendrefs follows
$atags idtags
5312 set dheads
[descheads
$currentid]
5313 if {$dheads ne
{}} {
5314 if {[appendrefs branch
$dheads idheads
] > 1
5315 && [$ctext get
"branch -3c"] eq
"h"} {
5316 # turn "Branch" into "Branches"
5317 $ctext conf
-state normal
5318 $ctext insert
"branch -2c" "es"
5319 $ctext conf
-state disabled
5324 if {[incr tagphase
] <= 2} {
5325 after idle dispnexttag
5329 proc make_secsel
{l
} {
5330 global linehtag linentag linedtag canv canv2 canv3
5332 if {![info exists linehtag
($l)]} return
5334 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
5335 -tags secsel
-fill [$canv cget
-selectbackground]]
5337 $canv2 delete secsel
5338 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
5339 -tags secsel
-fill [$canv2 cget
-selectbackground]]
5341 $canv3 delete secsel
5342 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
5343 -tags secsel
-fill [$canv3 cget
-selectbackground]]
5347 proc selectline
{l isnew
} {
5348 global canv ctext commitinfo selectedline
5349 global canvy0 linespc parents children curview
5350 global currentid sha1entry
5351 global commentend idtags linknum
5352 global mergemax numcommits pending_select
5353 global cmitmode showneartags allcommits
5355 catch
{unset pending_select
}
5360 if {$l < 0 ||
$l >= $numcommits} return
5361 set y
[expr {$canvy0 + $l * $linespc}]
5362 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5363 set ytop
[expr {$y - $linespc - 1}]
5364 set ybot
[expr {$y + $linespc + 1}]
5365 set wnow
[$canv yview
]
5366 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5367 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
5368 set wh
[expr {$wbot - $wtop}]
5370 if {$ytop < $wtop} {
5371 if {$ybot < $wtop} {
5372 set newtop
[expr {$y - $wh / 2.0}]
5375 if {$newtop > $wtop - $linespc} {
5376 set newtop
[expr {$wtop - $linespc}]
5379 } elseif
{$ybot > $wbot} {
5380 if {$ytop > $wbot} {
5381 set newtop
[expr {$y - $wh / 2.0}]
5383 set newtop
[expr {$ybot - $wh}]
5384 if {$newtop < $wtop + $linespc} {
5385 set newtop
[expr {$wtop + $linespc}]
5389 if {$newtop != $wtop} {
5393 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5399 set id
[commitonrow
$l]
5401 addtohistory
[list selbyid
$id]
5406 $sha1entry delete
0 end
5407 $sha1entry insert
0 $id
5408 $sha1entry selection from
0
5409 $sha1entry selection to end
5412 $ctext conf
-state normal
5415 set info
$commitinfo($id)
5416 set date [formatdate
[lindex
$info 2]]
5417 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
5418 set date [formatdate
[lindex
$info 4]]
5419 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
5420 if {[info exists idtags
($id)]} {
5421 $ctext insert end
[mc
"Tags:"]
5422 foreach tag
$idtags($id) {
5423 $ctext insert end
" $tag"
5425 $ctext insert end
"\n"
5429 set olds
$parents($curview,$id)
5430 if {[llength
$olds] > 1} {
5433 if {$np >= $mergemax} {
5438 $ctext insert end
"[mc "Parent
"]: " $tag
5439 appendwithlinks
[commit_descriptor
$p] {}
5444 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
5448 foreach c
$children($curview,$id) {
5449 append headers
"[mc "Child
"]: [commit_descriptor $c]"
5452 # make anything that looks like a SHA1 ID be a clickable link
5453 appendwithlinks
$headers {}
5454 if {$showneartags} {
5455 if {![info exists allcommits
]} {
5458 $ctext insert end
"[mc "Branch
"]: "
5459 $ctext mark
set branch
"end -1c"
5460 $ctext mark gravity branch left
5461 $ctext insert end
"\n[mc "Follows
"]: "
5462 $ctext mark
set follows
"end -1c"
5463 $ctext mark gravity follows left
5464 $ctext insert end
"\n[mc "Precedes
"]: "
5465 $ctext mark
set precedes
"end -1c"
5466 $ctext mark gravity precedes left
5467 $ctext insert end
"\n"
5470 $ctext insert end
"\n"
5471 set comment
[lindex
$info 5]
5472 if {[string first
"\r" $comment] >= 0} {
5473 set comment
[string map
{"\r" "\n "} $comment]
5475 appendwithlinks
$comment {comment
}
5477 $ctext tag remove found
1.0 end
5478 $ctext conf
-state disabled
5479 set commentend
[$ctext index
"end - 1c"]
5481 init_flist
[mc
"Comments"]
5482 if {$cmitmode eq
"tree"} {
5484 } elseif
{[llength
$olds] <= 1} {
5491 proc selfirstline
{} {
5496 proc sellastline
{} {
5499 set l
[expr {$numcommits - 1}]
5503 proc selnextline
{dir
} {
5506 if {![info exists selectedline
]} return
5507 set l
[expr {$selectedline + $dir}]
5512 proc selnextpage
{dir
} {
5513 global canv linespc selectedline numcommits
5515 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
5519 allcanvs yview scroll
[expr {$dir * $lpp}] units
5521 if {![info exists selectedline
]} return
5522 set l
[expr {$selectedline + $dir * $lpp}]
5525 } elseif
{$l >= $numcommits} {
5526 set l
[expr $numcommits - 1]
5532 proc unselectline
{} {
5533 global selectedline currentid
5535 catch
{unset selectedline
}
5536 catch
{unset currentid
}
5537 allcanvs delete secsel
5541 proc reselectline
{} {
5544 if {[info exists selectedline
]} {
5545 selectline
$selectedline 0
5549 proc addtohistory
{cmd
} {
5550 global
history historyindex curview
5552 set elt
[list
$curview $cmd]
5553 if {$historyindex > 0
5554 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
5558 if {$historyindex < [llength
$history]} {
5559 set history [lreplace
$history $historyindex end
$elt]
5561 lappend
history $elt
5564 if {$historyindex > 1} {
5565 .tf.bar.leftbut conf
-state normal
5567 .tf.bar.leftbut conf
-state disabled
5569 .tf.bar.rightbut conf
-state disabled
5575 set view
[lindex
$elt 0]
5576 set cmd
[lindex
$elt 1]
5577 if {$curview != $view} {
5584 global
history historyindex
5587 if {$historyindex > 1} {
5588 incr historyindex
-1
5589 godo
[lindex
$history [expr {$historyindex - 1}]]
5590 .tf.bar.rightbut conf
-state normal
5592 if {$historyindex <= 1} {
5593 .tf.bar.leftbut conf
-state disabled
5598 global
history historyindex
5601 if {$historyindex < [llength
$history]} {
5602 set cmd
[lindex
$history $historyindex]
5605 .tf.bar.leftbut conf
-state normal
5607 if {$historyindex >= [llength
$history]} {
5608 .tf.bar.rightbut conf
-state disabled
5613 global treefilelist treeidlist diffids diffmergeid treepending
5614 global nullid nullid2
5617 catch
{unset diffmergeid
}
5618 if {![info exists treefilelist
($id)]} {
5619 if {![info exists treepending
]} {
5620 if {$id eq
$nullid} {
5621 set cmd
[list | git ls-files
]
5622 } elseif
{$id eq
$nullid2} {
5623 set cmd
[list | git ls-files
--stage -t]
5625 set cmd
[list | git ls-tree
-r $id]
5627 if {[catch
{set gtf
[open
$cmd r
]}]} {
5631 set treefilelist
($id) {}
5632 set treeidlist
($id) {}
5633 fconfigure
$gtf -blocking 0
5634 filerun
$gtf [list gettreeline
$gtf $id]
5641 proc gettreeline
{gtf id
} {
5642 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5645 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
5646 if {$diffids eq
$nullid} {
5649 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
5650 set i
[string first
"\t" $line]
5651 if {$i < 0} continue
5652 set sha1
[lindex
$line 2]
5653 set fname
[string range
$line [expr {$i+1}] end
]
5654 if {[string index
$fname 0] eq
"\""} {
5655 set fname
[lindex
$fname 0]
5657 lappend treeidlist
($id) $sha1
5659 lappend treefilelist
($id) $fname
5662 return [expr {$nl >= 1000?
2: 1}]
5666 if {$cmitmode ne
"tree"} {
5667 if {![info exists diffmergeid
]} {
5668 gettreediffs
$diffids
5670 } elseif
{$id ne
$diffids} {
5679 global treefilelist treeidlist diffids nullid nullid2
5680 global ctext commentend
5682 set i
[lsearch
-exact $treefilelist($diffids) $f]
5684 puts
"oops, $f not in list for id $diffids"
5687 if {$diffids eq
$nullid} {
5688 if {[catch
{set bf
[open
$f r
]} err
]} {
5689 puts
"oops, can't read $f: $err"
5693 set blob
[lindex
$treeidlist($diffids) $i]
5694 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5695 puts
"oops, error reading blob $blob: $err"
5699 fconfigure
$bf -blocking 0
5700 filerun
$bf [list getblobline
$bf $diffids]
5701 $ctext config
-state normal
5702 clear_ctext
$commentend
5703 $ctext insert end
"\n"
5704 $ctext insert end
"$f\n" filesep
5705 $ctext config
-state disabled
5706 $ctext yview
$commentend
5710 proc getblobline
{bf id
} {
5711 global diffids cmitmode ctext
5713 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5717 $ctext config
-state normal
5719 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5720 $ctext insert end
"$line\n"
5723 # delete last newline
5724 $ctext delete
"end - 2c" "end - 1c"
5728 $ctext config
-state disabled
5729 return [expr {$nl >= 1000?
2: 1}]
5732 proc mergediff
{id
} {
5733 global diffmergeid mdifffd
5736 global limitdiffs viewfiles curview
5740 # this doesn't seem to actually affect anything...
5741 set cmd
[concat | git diff-tree
--no-commit-id --cc $id]
5742 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5743 set cmd
[concat
$cmd -- $viewfiles($curview)]
5745 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5746 error_popup
"[mc "Error getting merge diffs
:"] $err"
5749 fconfigure
$mdf -blocking 0
5750 set mdifffd
($id) $mdf
5751 set np
[llength
$parents($curview,$id)]
5753 filerun
$mdf [list getmergediffline
$mdf $id $np]
5756 proc getmergediffline
{mdf id np
} {
5757 global diffmergeid ctext cflist mergemax
5758 global difffilestart mdifffd
5760 $ctext conf
-state normal
5762 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5763 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5764 ||
$mdf != $mdifffd($id)} {
5768 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5769 # start of a new file
5770 $ctext insert end
"\n"
5771 set here
[$ctext index
"end - 1c"]
5772 lappend difffilestart
$here
5773 add_flist
[list
$fname]
5774 set l
[expr {(78 - [string length
$fname]) / 2}]
5775 set pad
[string range
"----------------------------------------" 1 $l]
5776 $ctext insert end
"$pad $fname $pad\n" filesep
5777 } elseif
{[regexp
{^@@
} $line]} {
5778 $ctext insert end
"$line\n" hunksep
5779 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5782 # parse the prefix - one ' ', '-' or '+' for each parent
5787 for {set j
0} {$j < $np} {incr j
} {
5788 set c
[string range
$line $j $j]
5791 } elseif
{$c == "-"} {
5793 } elseif
{$c == "+"} {
5802 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5803 # line doesn't appear in result, parents in $minuses have the line
5804 set num
[lindex
$minuses 0]
5805 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5806 # line appears in result, parents in $pluses don't have the line
5807 lappend tags mresult
5808 set num
[lindex
$spaces 0]
5811 if {$num >= $mergemax} {
5816 $ctext insert end
"$line\n" $tags
5819 $ctext conf
-state disabled
5824 return [expr {$nr >= 1000?
2: 1}]
5827 proc startdiff
{ids
} {
5828 global treediffs diffids treepending diffmergeid nullid nullid2
5832 catch
{unset diffmergeid
}
5833 if {![info exists treediffs
($ids)] ||
5834 [lsearch
-exact $ids $nullid] >= 0 ||
5835 [lsearch
-exact $ids $nullid2] >= 0} {
5836 if {![info exists treepending
]} {
5844 proc path_filter
{filter name
} {
5846 set l
[string length
$p]
5847 if {[string index
$p end
] eq
"/"} {
5848 if {[string compare
-length $l $p $name] == 0} {
5852 if {[string compare
-length $l $p $name] == 0 &&
5853 ([string length
$name] == $l ||
5854 [string index
$name $l] eq
"/")} {
5862 proc addtocflist
{ids
} {
5865 add_flist
$treediffs($ids)
5869 proc diffcmd
{ids flags
} {
5870 global nullid nullid2
5872 set i
[lsearch
-exact $ids $nullid]
5873 set j
[lsearch
-exact $ids $nullid2]
5875 if {[llength
$ids] > 1 && $j < 0} {
5876 # comparing working directory with some specific revision
5877 set cmd
[concat | git diff-index
$flags]
5879 lappend cmd
-R [lindex
$ids 1]
5881 lappend cmd
[lindex
$ids 0]
5884 # comparing working directory with index
5885 set cmd
[concat | git diff-files
$flags]
5890 } elseif
{$j >= 0} {
5891 set cmd
[concat | git diff-index
--cached $flags]
5892 if {[llength
$ids] > 1} {
5893 # comparing index with specific revision
5895 lappend cmd
-R [lindex
$ids 1]
5897 lappend cmd
[lindex
$ids 0]
5900 # comparing index with HEAD
5904 set cmd
[concat | git diff-tree
-r $flags $ids]
5909 proc gettreediffs
{ids
} {
5910 global treediff treepending
5912 set treepending
$ids
5914 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5915 fconfigure
$gdtf -blocking 0
5916 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5919 proc gettreediffline
{gdtf ids
} {
5920 global treediff treediffs treepending diffids diffmergeid
5921 global cmitmode viewfiles curview limitdiffs
5924 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5925 set i
[string first
"\t" $line]
5927 set file [string range
$line [expr {$i+1}] end
]
5928 if {[string index
$file 0] eq
"\""} {
5929 set file [lindex
$file 0]
5931 lappend treediff
$file
5935 return [expr {$nr >= 1000?
2: 1}]
5938 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5940 foreach f
$treediff {
5941 if {[path_filter
$viewfiles($curview) $f]} {
5945 set treediffs
($ids) $flist
5947 set treediffs
($ids) $treediff
5950 if {$cmitmode eq
"tree"} {
5952 } elseif
{$ids != $diffids} {
5953 if {![info exists diffmergeid
]} {
5954 gettreediffs
$diffids
5962 # empty string or positive integer
5963 proc diffcontextvalidate
{v
} {
5964 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5967 proc diffcontextchange
{n1 n2 op
} {
5968 global diffcontextstring diffcontext
5970 if {[string is integer
-strict $diffcontextstring]} {
5971 if {$diffcontextstring > 0} {
5972 set diffcontext
$diffcontextstring
5978 proc getblobdiffs
{ids
} {
5979 global blobdifffd diffids env
5980 global diffinhdr treediffs
5982 global limitdiffs viewfiles curview
5984 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5985 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5986 set cmd
[concat
$cmd -- $viewfiles($curview)]
5988 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5989 puts
"error getting diffs: $err"
5993 fconfigure
$bdf -blocking 0
5994 set blobdifffd
($ids) $bdf
5995 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5998 proc setinlist
{var i val
} {
6001 while {[llength
[set $var]] < $i} {
6004 if {[llength
[set $var]] == $i} {
6011 proc makediffhdr
{fname ids
} {
6012 global ctext curdiffstart treediffs
6014 set i
[lsearch
-exact $treediffs($ids) $fname]
6016 setinlist difffilestart
$i $curdiffstart
6018 set l
[expr {(78 - [string length
$fname]) / 2}]
6019 set pad
[string range
"----------------------------------------" 1 $l]
6020 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
6023 proc getblobdiffline
{bdf ids
} {
6024 global diffids blobdifffd ctext curdiffstart
6025 global diffnexthead diffnextnote difffilestart
6026 global diffinhdr treediffs
6029 $ctext conf
-state normal
6030 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
6031 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
6035 if {![string compare
-length 11 "diff --git " $line]} {
6036 # trim off "diff --git "
6037 set line
[string range
$line 11 end
]
6039 # start of a new file
6040 $ctext insert end
"\n"
6041 set curdiffstart
[$ctext index
"end - 1c"]
6042 $ctext insert end
"\n" filesep
6043 # If the name hasn't changed the length will be odd,
6044 # the middle char will be a space, and the two bits either
6045 # side will be a/name and b/name, or "a/name" and "b/name".
6046 # If the name has changed we'll get "rename from" and
6047 # "rename to" or "copy from" and "copy to" lines following this,
6048 # and we'll use them to get the filenames.
6049 # This complexity is necessary because spaces in the filename(s)
6050 # don't get escaped.
6051 set l
[string length
$line]
6052 set i
[expr {$l / 2}]
6053 if {!(($l & 1) && [string index
$line $i] eq
" " &&
6054 [string range
$line 2 [expr {$i - 1}]] eq \
6055 [string range
$line [expr {$i + 3}] end
])} {
6058 # unescape if quoted and chop off the a/ from the front
6059 if {[string index
$line 0] eq
"\""} {
6060 set fname
[string range
[lindex
$line 0] 2 end
]
6062 set fname
[string range
$line 2 [expr {$i - 1}]]
6064 makediffhdr
$fname $ids
6066 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
6067 $line match f1l f1c f2l f2c rest
]} {
6068 $ctext insert end
"$line\n" hunksep
6071 } elseif
{$diffinhdr} {
6072 if {![string compare
-length 12 "rename from " $line]} {
6073 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
6074 if {[string index
$fname 0] eq
"\""} {
6075 set fname
[lindex
$fname 0]
6077 set i
[lsearch
-exact $treediffs($ids) $fname]
6079 setinlist difffilestart
$i $curdiffstart
6081 } elseif
{![string compare
-length 10 $line "rename to "] ||
6082 ![string compare
-length 8 $line "copy to "]} {
6083 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
6084 if {[string index
$fname 0] eq
"\""} {
6085 set fname
[lindex
$fname 0]
6087 makediffhdr
$fname $ids
6088 } elseif
{[string compare
-length 3 $line "---"] == 0} {
6091 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
6095 $ctext insert end
"$line\n" filesep
6098 set x
[string range
$line 0 0]
6099 if {$x == "-" ||
$x == "+"} {
6100 set tag
[expr {$x == "+"}]
6101 $ctext insert end
"$line\n" d
$tag
6102 } elseif
{$x == " "} {
6103 $ctext insert end
"$line\n"
6105 # "\ No newline at end of file",
6106 # or something else we don't recognize
6107 $ctext insert end
"$line\n" hunksep
6111 $ctext conf
-state disabled
6116 return [expr {$nr >= 1000?
2: 1}]
6119 proc changediffdisp
{} {
6120 global ctext diffelide
6122 $ctext tag conf d0
-elide [lindex
$diffelide 0]
6123 $ctext tag conf d1
-elide [lindex
$diffelide 1]
6127 global difffilestart ctext
6128 set prev
[lindex
$difffilestart 0]
6129 set here
[$ctext index @
0,0]
6130 foreach loc
$difffilestart {
6131 if {[$ctext compare
$loc >= $here]} {
6141 global difffilestart ctext
6142 set here
[$ctext index @
0,0]
6143 foreach loc
$difffilestart {
6144 if {[$ctext compare
$loc > $here]} {
6151 proc clear_ctext
{{first
1.0}} {
6152 global ctext smarktop smarkbot
6155 set l
[lindex
[split $first .
] 0]
6156 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
6159 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
6162 $ctext delete
$first end
6163 if {$first eq
"1.0"} {
6164 catch
{unset pendinglinks
}
6168 proc settabs
{{firstab
{}}} {
6169 global firsttabstop tabstop ctext have_tk85
6171 if {$firstab ne
{} && $have_tk85} {
6172 set firsttabstop
$firstab
6174 set w
[font measure textfont
"0"]
6175 if {$firsttabstop != 0} {
6176 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
6177 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6178 } elseif
{$have_tk85 ||
$tabstop != 8} {
6179 $ctext conf
-tabs [expr {$tabstop * $w}]
6181 $ctext conf
-tabs {}
6185 proc incrsearch
{name ix op
} {
6186 global ctext searchstring searchdirn
6188 $ctext tag remove found
1.0 end
6189 if {[catch
{$ctext index anchor
}]} {
6190 # no anchor set, use start of selection, or of visible area
6191 set sel
[$ctext tag ranges sel
]
6193 $ctext mark
set anchor
[lindex
$sel 0]
6194 } elseif
{$searchdirn eq
"-forwards"} {
6195 $ctext mark
set anchor @
0,0
6197 $ctext mark
set anchor @
0,[winfo height
$ctext]
6200 if {$searchstring ne
{}} {
6201 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
6210 global sstring ctext searchstring searchdirn
6213 $sstring icursor end
6214 set searchdirn
-forwards
6215 if {$searchstring ne
{}} {
6216 set sel
[$ctext tag ranges sel
]
6218 set start
"[lindex $sel 0] + 1c"
6219 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6222 set match
[$ctext search
-count mlen
-- $searchstring $start]
6223 $ctext tag remove sel
1.0 end
6229 set mend
"$match + $mlen c"
6230 $ctext tag add sel
$match $mend
6231 $ctext mark
unset anchor
6235 proc dosearchback
{} {
6236 global sstring ctext searchstring searchdirn
6239 $sstring icursor end
6240 set searchdirn
-backwards
6241 if {$searchstring ne
{}} {
6242 set sel
[$ctext tag ranges sel
]
6244 set start
[lindex
$sel 0]
6245 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6246 set start @
0,[winfo height
$ctext]
6248 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
6249 $ctext tag remove sel
1.0 end
6255 set mend
"$match + $ml c"
6256 $ctext tag add sel
$match $mend
6257 $ctext mark
unset anchor
6261 proc searchmark
{first last
} {
6262 global ctext searchstring
6266 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
6267 if {$match eq
{}} break
6268 set mend
"$match + $mlen c"
6269 $ctext tag add found
$match $mend
6273 proc searchmarkvisible
{doall
} {
6274 global ctext smarktop smarkbot
6276 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
6277 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
6278 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
6279 # no overlap with previous
6280 searchmark
$topline $botline
6281 set smarktop
$topline
6282 set smarkbot
$botline
6284 if {$topline < $smarktop} {
6285 searchmark
$topline [expr {$smarktop-1}]
6286 set smarktop
$topline
6288 if {$botline > $smarkbot} {
6289 searchmark
[expr {$smarkbot+1}] $botline
6290 set smarkbot
$botline
6295 proc scrolltext
{f0 f1
} {
6298 .bleft.sb
set $f0 $f1
6299 if {$searchstring ne
{}} {
6305 global linespc charspc canvx0 canvy0
6306 global xspc1 xspc2 lthickness
6308 set linespc
[font metrics mainfont
-linespace]
6309 set charspc
[font measure mainfont
"m"]
6310 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
6311 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
6312 set lthickness
[expr {int
($linespc / 9) + 1}]
6313 set xspc1
(0) $linespc
6321 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6322 if {$ymax eq
{} ||
$ymax == 0} return
6323 set span
[$canv yview
]
6326 allcanvs yview moveto
[lindex
$span 0]
6328 if {[info exists selectedline
]} {
6329 selectline
$selectedline 0
6330 allcanvs yview moveto
[lindex
$span 0]
6334 proc parsefont
{f n
} {
6337 set fontattr
($f,family
) [lindex
$n 0]
6339 if {$s eq
{} ||
$s == 0} {
6342 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
6344 set fontattr
($f,size
) $s
6345 set fontattr
($f,weight
) normal
6346 set fontattr
($f,slant
) roman
6347 foreach style
[lrange
$n 2 end
] {
6350 "bold" {set fontattr
($f,weight
) $style}
6352 "italic" {set fontattr
($f,slant
) $style}
6357 proc fontflags
{f
{isbold
0}} {
6360 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
6361 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
6362 -slant $fontattr($f,slant
)]
6368 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
6369 if {$fontattr($f,weight
) eq
"bold"} {
6372 if {$fontattr($f,slant
) eq
"italic"} {
6378 proc incrfont
{inc
} {
6379 global mainfont textfont ctext canv cflist showrefstop
6380 global stopped entries fontattr
6383 set s
$fontattr(mainfont
,size
)
6388 set fontattr
(mainfont
,size
) $s
6389 font config mainfont
-size $s
6390 font config mainfontbold
-size $s
6391 set mainfont
[fontname mainfont
]
6392 set s
$fontattr(textfont
,size
)
6397 set fontattr
(textfont
,size
) $s
6398 font config textfont
-size $s
6399 font config textfontbold
-size $s
6400 set textfont
[fontname textfont
]
6407 global sha1entry sha1string
6408 if {[string length
$sha1string] == 40} {
6409 $sha1entry delete
0 end
6413 proc sha1change
{n1 n2 op
} {
6414 global sha1string currentid sha1but
6415 if {$sha1string == {}
6416 ||
([info exists currentid
] && $sha1string == $currentid)} {
6421 if {[$sha1but cget
-state] == $state} return
6422 if {$state == "normal"} {
6423 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
6425 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
6429 proc gotocommit
{} {
6430 global sha1string tagids headids curview varcid
6432 if {$sha1string == {}
6433 ||
([info exists currentid
] && $sha1string == $currentid)} return
6434 if {[info exists tagids
($sha1string)]} {
6435 set id
$tagids($sha1string)
6436 } elseif
{[info exists headids
($sha1string)]} {
6437 set id
$headids($sha1string)
6439 set id
[string tolower
$sha1string]
6440 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
6441 set matches
[array names varcid
"$curview,$id*"]
6442 if {$matches ne
{}} {
6443 if {[llength
$matches] > 1} {
6444 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
6447 set id
[lindex
[split [lindex
$matches 0] ","] 1]
6451 if {[commitinview
$id $curview]} {
6452 selectline
[rowofcommit
$id] 1
6455 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
6456 set msg
[mc
"SHA1 id %s is not known" $sha1string]
6458 set msg
[mc
"Tag/Head %s is not known" $sha1string]
6463 proc lineenter
{x y id
} {
6464 global hoverx hovery hoverid hovertimer
6465 global commitinfo canv
6467 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6471 if {[info exists hovertimer
]} {
6472 after cancel
$hovertimer
6474 set hovertimer
[after
500 linehover
]
6478 proc linemotion
{x y id
} {
6479 global hoverx hovery hoverid hovertimer
6481 if {[info exists hoverid
] && $id == $hoverid} {
6484 if {[info exists hovertimer
]} {
6485 after cancel
$hovertimer
6487 set hovertimer
[after
500 linehover
]
6491 proc lineleave
{id
} {
6492 global hoverid hovertimer canv
6494 if {[info exists hoverid
] && $id == $hoverid} {
6496 if {[info exists hovertimer
]} {
6497 after cancel
$hovertimer
6505 global hoverx hovery hoverid hovertimer
6506 global canv linespc lthickness
6509 set text
[lindex
$commitinfo($hoverid) 0]
6510 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6511 if {$ymax == {}} return
6512 set yfrac
[lindex
[$canv yview
] 0]
6513 set x
[expr {$hoverx + 2 * $linespc}]
6514 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6515 set x0
[expr {$x - 2 * $lthickness}]
6516 set y0
[expr {$y - 2 * $lthickness}]
6517 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
6518 set y1
[expr {$y + $linespc + 2 * $lthickness}]
6519 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
6520 -fill \
#ffff80 -outline black -width 1 -tags hover]
6522 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
6527 proc clickisonarrow
{id y
} {
6530 set ranges
[rowranges
$id]
6531 set thresh
[expr {2 * $lthickness + 6}]
6532 set n
[expr {[llength
$ranges] - 1}]
6533 for {set i
1} {$i < $n} {incr i
} {
6534 set row
[lindex
$ranges $i]
6535 if {abs
([yc
$row] - $y) < $thresh} {
6542 proc arrowjump
{id n y
} {
6545 # 1 <-> 2, 3 <-> 4, etc...
6546 set n
[expr {(($n - 1) ^
1) + 1}]
6547 set row
[lindex
[rowranges
$id] $n]
6549 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6550 if {$ymax eq
{} ||
$ymax <= 0} return
6551 set view
[$canv yview
]
6552 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
6553 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
6557 allcanvs yview moveto
$yfrac
6560 proc lineclick
{x y id isnew
} {
6561 global ctext commitinfo children canv thickerline curview
6563 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6568 # draw this line thicker than normal
6572 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6573 if {$ymax eq
{}} return
6574 set yfrac
[lindex
[$canv yview
] 0]
6575 set y
[expr {$y + $yfrac * $ymax}]
6577 set dirn
[clickisonarrow
$id $y]
6579 arrowjump
$id $dirn $y
6584 addtohistory
[list lineclick
$x $y $id 0]
6586 # fill the details pane with info about this line
6587 $ctext conf
-state normal
6590 $ctext insert end
"[mc "Parent
"]:\t"
6591 $ctext insert end
$id link0
6593 set info
$commitinfo($id)
6594 $ctext insert end
"\n\t[lindex $info 0]\n"
6595 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
6596 set date [formatdate
[lindex
$info 2]]
6597 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
6598 set kids
$children($curview,$id)
6600 $ctext insert end
"\n[mc "Children
"]:"
6602 foreach child
$kids {
6604 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
6605 set info
$commitinfo($child)
6606 $ctext insert end
"\n\t"
6607 $ctext insert end
$child link
$i
6608 setlink
$child link
$i
6609 $ctext insert end
"\n\t[lindex $info 0]"
6610 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
6611 set date [formatdate
[lindex
$info 2]]
6612 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
6615 $ctext conf
-state disabled
6619 proc normalline
{} {
6621 if {[info exists thickerline
]} {
6630 if {[commitinview
$id $curview]} {
6631 selectline
[rowofcommit
$id] 1
6637 if {![info exists startmstime
]} {
6638 set startmstime
[clock clicks
-milliseconds]
6640 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
6643 proc rowmenu
{x y id
} {
6644 global rowctxmenu selectedline rowmenuid curview
6645 global nullid nullid2 fakerowmenu mainhead
6649 if {![info exists selectedline
]
6650 ||
[rowofcommit
$id] eq
$selectedline} {
6655 if {$id ne
$nullid && $id ne
$nullid2} {
6656 set menu
$rowctxmenu
6657 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6659 set menu
$fakerowmenu
6661 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6662 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6663 $menu entryconfigure
[mc
"Make patch"] -state $state
6664 tk_popup
$menu $x $y
6667 proc diffvssel
{dirn
} {
6668 global rowmenuid selectedline
6670 if {![info exists selectedline
]} return
6672 set oldid
[commitonrow
$selectedline]
6673 set newid
$rowmenuid
6675 set oldid
$rowmenuid
6676 set newid
[commitonrow
$selectedline]
6678 addtohistory
[list doseldiff
$oldid $newid]
6679 doseldiff
$oldid $newid
6682 proc doseldiff
{oldid newid
} {
6686 $ctext conf
-state normal
6688 init_flist
[mc
"Top"]
6689 $ctext insert end
"[mc "From
"] "
6690 $ctext insert end
$oldid link0
6691 setlink
$oldid link0
6692 $ctext insert end
"\n "
6693 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6694 $ctext insert end
"\n\n[mc "To
"] "
6695 $ctext insert end
$newid link1
6696 setlink
$newid link1
6697 $ctext insert end
"\n "
6698 $ctext insert end
[lindex
$commitinfo($newid) 0]
6699 $ctext insert end
"\n"
6700 $ctext conf
-state disabled
6701 $ctext tag remove found
1.0 end
6702 startdiff
[list
$oldid $newid]
6706 global rowmenuid currentid commitinfo patchtop patchnum
6708 if {![info exists currentid
]} return
6709 set oldid
$currentid
6710 set oldhead
[lindex
$commitinfo($oldid) 0]
6711 set newid
$rowmenuid
6712 set newhead
[lindex
$commitinfo($newid) 0]
6715 catch
{destroy
$top}
6717 label
$top.title
-text [mc
"Generate patch"]
6718 grid
$top.title
- -pady 10
6719 label
$top.from
-text [mc
"From:"]
6720 entry
$top.fromsha1
-width 40 -relief flat
6721 $top.fromsha1 insert
0 $oldid
6722 $top.fromsha1 conf
-state readonly
6723 grid
$top.from
$top.fromsha1
-sticky w
6724 entry
$top.fromhead
-width 60 -relief flat
6725 $top.fromhead insert
0 $oldhead
6726 $top.fromhead conf
-state readonly
6727 grid x
$top.fromhead
-sticky w
6728 label
$top.to
-text [mc
"To:"]
6729 entry
$top.tosha1
-width 40 -relief flat
6730 $top.tosha1 insert
0 $newid
6731 $top.tosha1 conf
-state readonly
6732 grid
$top.to
$top.tosha1
-sticky w
6733 entry
$top.tohead
-width 60 -relief flat
6734 $top.tohead insert
0 $newhead
6735 $top.tohead conf
-state readonly
6736 grid x
$top.tohead
-sticky w
6737 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6738 grid
$top.
rev x
-pady 10
6739 label
$top.flab
-text [mc
"Output file:"]
6740 entry
$top.fname
-width 60
6741 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6743 grid
$top.flab
$top.fname
-sticky w
6745 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6746 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6747 grid
$top.buts.gen
$top.buts.can
6748 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6749 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6750 grid
$top.buts
- -pady 10 -sticky ew
6754 proc mkpatchrev
{} {
6757 set oldid
[$patchtop.fromsha1 get
]
6758 set oldhead
[$patchtop.fromhead get
]
6759 set newid
[$patchtop.tosha1 get
]
6760 set newhead
[$patchtop.tohead get
]
6761 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6762 v
[list
$newid $newhead $oldid $oldhead] {
6763 $patchtop.
$e conf
-state normal
6764 $patchtop.
$e delete
0 end
6765 $patchtop.
$e insert
0 $v
6766 $patchtop.
$e conf
-state readonly
6771 global patchtop nullid nullid2
6773 set oldid
[$patchtop.fromsha1 get
]
6774 set newid
[$patchtop.tosha1 get
]
6775 set fname
[$patchtop.fname get
]
6776 set cmd
[diffcmd
[list
$oldid $newid] -p]
6777 # trim off the initial "|"
6778 set cmd
[lrange
$cmd 1 end
]
6779 lappend cmd
>$fname &
6780 if {[catch
{eval exec $cmd} err
]} {
6781 error_popup
"[mc "Error creating
patch:"] $err"
6783 catch
{destroy
$patchtop}
6787 proc mkpatchcan
{} {
6790 catch
{destroy
$patchtop}
6795 global rowmenuid mktagtop commitinfo
6799 catch
{destroy
$top}
6801 label
$top.title
-text [mc
"Create tag"]
6802 grid
$top.title
- -pady 10
6803 label
$top.id
-text [mc
"ID:"]
6804 entry
$top.sha1
-width 40 -relief flat
6805 $top.sha1 insert
0 $rowmenuid
6806 $top.sha1 conf
-state readonly
6807 grid
$top.id
$top.sha1
-sticky w
6808 entry
$top.
head -width 60 -relief flat
6809 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6810 $top.
head conf
-state readonly
6811 grid x
$top.
head -sticky w
6812 label
$top.tlab
-text [mc
"Tag name:"]
6813 entry
$top.tag
-width 60
6814 grid
$top.tlab
$top.tag
-sticky w
6816 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6817 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6818 grid
$top.buts.gen
$top.buts.can
6819 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6820 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6821 grid
$top.buts
- -pady 10 -sticky ew
6826 global mktagtop env tagids idtags
6828 set id
[$mktagtop.sha1 get
]
6829 set tag
[$mktagtop.tag get
]
6831 error_popup
[mc
"No tag name specified"]
6834 if {[info exists tagids
($tag)]} {
6835 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6840 set fname
[file join $dir "refs/tags" $tag]
6841 set f
[open
$fname w
]
6845 error_popup
"[mc "Error creating tag
:"] $err"
6849 set tagids
($tag) $id
6850 lappend idtags
($id) $tag
6857 proc redrawtags
{id
} {
6858 global canv linehtag idpos currentid curview
6859 global canvxmax iddrawn
6861 if {![commitinview
$id $curview]} return
6862 if {![info exists iddrawn
($id)]} return
6863 set row
[rowofcommit
$id]
6864 $canv delete tag.
$id
6865 set xt
[eval drawtags
$id $idpos($id)]
6866 $canv coords
$linehtag($row) $xt [lindex
$idpos($id) 2]
6867 set text
[$canv itemcget
$linehtag($row) -text]
6868 set font
[$canv itemcget
$linehtag($row) -font]
6869 set xr
[expr {$xt + [font measure
$font $text]}]
6870 if {$xr > $canvxmax} {
6874 if {[info exists currentid
] && $currentid == $id} {
6882 catch
{destroy
$mktagtop}
6891 proc writecommit
{} {
6892 global rowmenuid wrcomtop commitinfo wrcomcmd
6894 set top .writecommit
6896 catch
{destroy
$top}
6898 label
$top.title
-text [mc
"Write commit to file"]
6899 grid
$top.title
- -pady 10
6900 label
$top.id
-text [mc
"ID:"]
6901 entry
$top.sha1
-width 40 -relief flat
6902 $top.sha1 insert
0 $rowmenuid
6903 $top.sha1 conf
-state readonly
6904 grid
$top.id
$top.sha1
-sticky w
6905 entry
$top.
head -width 60 -relief flat
6906 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6907 $top.
head conf
-state readonly
6908 grid x
$top.
head -sticky w
6909 label
$top.clab
-text [mc
"Command:"]
6910 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6911 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6912 label
$top.flab
-text [mc
"Output file:"]
6913 entry
$top.fname
-width 60
6914 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6915 grid
$top.flab
$top.fname
-sticky w
6917 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6918 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6919 grid
$top.buts.gen
$top.buts.can
6920 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6921 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6922 grid
$top.buts
- -pady 10 -sticky ew
6929 set id
[$wrcomtop.sha1 get
]
6930 set cmd
"echo $id | [$wrcomtop.cmd get]"
6931 set fname
[$wrcomtop.fname get
]
6932 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6933 error_popup
"[mc "Error writing commit
:"] $err"
6935 catch
{destroy
$wrcomtop}
6942 catch
{destroy
$wrcomtop}
6947 global rowmenuid mkbrtop
6950 catch
{destroy
$top}
6952 label
$top.title
-text [mc
"Create new branch"]
6953 grid
$top.title
- -pady 10
6954 label
$top.id
-text [mc
"ID:"]
6955 entry
$top.sha1
-width 40 -relief flat
6956 $top.sha1 insert
0 $rowmenuid
6957 $top.sha1 conf
-state readonly
6958 grid
$top.id
$top.sha1
-sticky w
6959 label
$top.nlab
-text [mc
"Name:"]
6960 entry
$top.name
-width 40
6961 grid
$top.nlab
$top.name
-sticky w
6963 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6964 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6965 grid
$top.buts.go
$top.buts.can
6966 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6967 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6968 grid
$top.buts
- -pady 10 -sticky ew
6973 global headids idheads
6975 set name
[$top.name get
]
6976 set id
[$top.sha1 get
]
6978 error_popup
[mc
"Please specify a name for the new branch"]
6981 catch
{destroy
$top}
6985 exec git branch
$name $id
6990 set headids
($name) $id
6991 lappend idheads
($id) $name
7000 proc cherrypick
{} {
7001 global rowmenuid curview
7004 set oldhead
[exec git rev-parse HEAD
]
7005 set dheads
[descheads
$rowmenuid]
7006 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
7007 set ok
[confirm_popup
[mc
"Commit %s is already\
7008 included in branch %s -- really re-apply it?" \
7009 [string range
$rowmenuid 0 7] $mainhead]]
7012 nowbusy cherrypick
[mc
"Cherry-picking"]
7014 # Unfortunately git-cherry-pick writes stuff to stderr even when
7015 # no error occurs, and exec takes that as an indication of error...
7016 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
7021 set newhead
[exec git rev-parse HEAD
]
7022 if {$newhead eq
$oldhead} {
7024 error_popup
[mc
"No changes committed"]
7027 addnewchild
$newhead $oldhead
7028 if {[commitinview
$oldhead $curview]} {
7029 insertrow
$newhead $oldhead $curview
7030 if {$mainhead ne
{}} {
7031 movehead
$newhead $mainhead
7032 movedhead
$newhead $mainhead
7041 global mainheadid mainhead rowmenuid confirm_ok resettype
7044 set w
".confirmreset"
7047 wm title
$w [mc
"Confirm reset"]
7048 message
$w.m
-text \
7049 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
7050 -justify center
-aspect 1000
7051 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
7052 frame
$w.f
-relief sunken
-border 2
7053 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
7054 grid
$w.f.rt
-sticky w
7056 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
7057 -text [mc
"Soft: Leave working tree and index untouched"]
7058 grid
$w.f.soft
-sticky w
7059 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
7060 -text [mc
"Mixed: Leave working tree untouched, reset index"]
7061 grid
$w.f.mixed
-sticky w
7062 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
7063 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
7064 grid
$w.f.hard
-sticky w
7065 pack
$w.f
-side top
-fill x
7066 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
7067 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
7068 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
7069 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
7070 bind $w <Visibility
> "grab $w; focus $w"
7072 if {!$confirm_ok} return
7073 if {[catch
{set fd
[open \
7074 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
7078 filerun
$fd [list readresetstat
$fd]
7079 nowbusy
reset [mc
"Resetting"]
7083 proc readresetstat
{fd
} {
7084 global mainhead mainheadid showlocalchanges rprogcoord
7086 if {[gets
$fd line
] >= 0} {
7087 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
7088 set rprogcoord
[expr {1.0 * $m / $n}]
7096 if {[catch
{close
$fd} err
]} {
7099 set oldhead
$mainheadid
7100 set newhead
[exec git rev-parse HEAD
]
7101 if {$newhead ne
$oldhead} {
7102 movehead
$newhead $mainhead
7103 movedhead
$newhead $mainhead
7104 set mainheadid
$newhead
7108 if {$showlocalchanges} {
7114 # context menu for a head
7115 proc headmenu
{x y id
head} {
7116 global headmenuid headmenuhead headctxmenu mainhead
7120 set headmenuhead
$head
7122 if {$head eq
$mainhead} {
7125 $headctxmenu entryconfigure
0 -state $state
7126 $headctxmenu entryconfigure
1 -state $state
7127 tk_popup
$headctxmenu $x $y
7131 global headmenuid headmenuhead mainhead headids
7132 global showlocalchanges mainheadid
7134 # check the tree is clean first??
7135 set oldmainhead
$mainhead
7136 nowbusy checkout
[mc
"Checking out"]
7140 exec git checkout
-q $headmenuhead
7146 set mainhead
$headmenuhead
7147 set mainheadid
$headmenuid
7148 if {[info exists headids
($oldmainhead)]} {
7149 redrawtags
$headids($oldmainhead)
7151 redrawtags
$headmenuid
7153 if {$showlocalchanges} {
7159 global headmenuid headmenuhead mainhead
7162 set head $headmenuhead
7164 # this check shouldn't be needed any more...
7165 if {$head eq
$mainhead} {
7166 error_popup
[mc
"Cannot delete the currently checked-out branch"]
7169 set dheads
[descheads
$id]
7170 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
7171 # the stuff on this branch isn't on any other branch
7172 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
7173 branch.\nReally delete branch %s?" $head $head]]} return
7177 if {[catch
{exec git branch
-D $head} err
]} {
7182 removehead
$id $head
7183 removedhead
$id $head
7190 # Display a list of tags and heads
7192 global showrefstop bgcolor fgcolor selectbgcolor
7193 global bglist fglist reflistfilter reflist maincursor
7196 set showrefstop
$top
7197 if {[winfo exists
$top]} {
7203 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
7204 text
$top.list
-background $bgcolor -foreground $fgcolor \
7205 -selectbackground $selectbgcolor -font mainfont \
7206 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7207 -width 30 -height 20 -cursor $maincursor \
7208 -spacing1 1 -spacing3 1 -state disabled
7209 $top.list tag configure highlight
-background $selectbgcolor
7210 lappend bglist
$top.list
7211 lappend fglist
$top.list
7212 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
7213 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
7214 grid
$top.list
$top.ysb
-sticky nsew
7215 grid
$top.xsb x
-sticky ew
7217 label
$top.f.l
-text "[mc "Filter
"]: "
7218 entry
$top.f.e
-width 20 -textvariable reflistfilter
7219 set reflistfilter
"*"
7220 trace add variable reflistfilter
write reflistfilter_change
7221 pack
$top.f.e
-side right
-fill x
-expand 1
7222 pack
$top.f.l
-side left
7223 grid
$top.f
- -sticky ew
-pady 2
7224 button
$top.close
-command [list destroy
$top] -text [mc
"Close"]
7226 grid columnconfigure
$top 0 -weight 1
7227 grid rowconfigure
$top 0 -weight 1
7228 bind $top.list
<1> {break}
7229 bind $top.list
<B1-Motion
> {break}
7230 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
7235 proc sel_reflist
{w x y
} {
7236 global showrefstop reflist headids tagids otherrefids
7238 if {![winfo exists
$showrefstop]} return
7239 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
7240 set ref
[lindex
$reflist [expr {$l-1}]]
7241 set n
[lindex
$ref 0]
7242 switch
-- [lindex
$ref 1] {
7243 "H" {selbyid
$headids($n)}
7244 "T" {selbyid
$tagids($n)}
7245 "o" {selbyid
$otherrefids($n)}
7247 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
7250 proc unsel_reflist
{} {
7253 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7254 $showrefstop.list tag remove highlight
0.0 end
7257 proc reflistfilter_change
{n1 n2 op
} {
7258 global reflistfilter
7260 after cancel refill_reflist
7261 after
200 refill_reflist
7264 proc refill_reflist
{} {
7265 global reflist reflistfilter showrefstop headids tagids otherrefids
7266 global curview commitinterest
7268 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7270 foreach n
[array names headids
] {
7271 if {[string match
$reflistfilter $n]} {
7272 if {[commitinview
$headids($n) $curview]} {
7273 lappend refs
[list
$n H
]
7275 set commitinterest
($headids($n)) {run refill_reflist
}
7279 foreach n
[array names tagids
] {
7280 if {[string match
$reflistfilter $n]} {
7281 if {[commitinview
$tagids($n) $curview]} {
7282 lappend refs
[list
$n T
]
7284 set commitinterest
($tagids($n)) {run refill_reflist
}
7288 foreach n
[array names otherrefids
] {
7289 if {[string match
$reflistfilter $n]} {
7290 if {[commitinview
$otherrefids($n) $curview]} {
7291 lappend refs
[list
$n o
]
7293 set commitinterest
($otherrefids($n)) {run refill_reflist
}
7297 set refs
[lsort
-index 0 $refs]
7298 if {$refs eq
$reflist} return
7300 # Update the contents of $showrefstop.list according to the
7301 # differences between $reflist (old) and $refs (new)
7302 $showrefstop.list conf
-state normal
7303 $showrefstop.list insert end
"\n"
7306 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
7307 if {$i < [llength
$reflist]} {
7308 if {$j < [llength
$refs]} {
7309 set cmp [string compare
[lindex
$reflist $i 0] \
7310 [lindex
$refs $j 0]]
7312 set cmp [string compare
[lindex
$reflist $i 1] \
7313 [lindex
$refs $j 1]]
7323 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
7331 set l
[expr {$j + 1}]
7332 $showrefstop.list image create
$l.0 -align baseline \
7333 -image reficon-
[lindex
$refs $j 1] -padx 2
7334 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
7340 # delete last newline
7341 $showrefstop.list delete end-2c end-1c
7342 $showrefstop.list conf
-state disabled
7345 # Stuff for finding nearby tags
7346 proc getallcommits
{} {
7347 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7348 global idheads idtags idotherrefs allparents tagobjid
7350 if {![info exists allcommits
]} {
7356 set allccache
[file join [gitdir
] "gitk.cache"]
7358 set f
[open
$allccache r
]
7367 set cmd
[list | git rev-list
--parents]
7368 set allcupdate
[expr {$seeds ne
{}}]
7372 set refs
[concat
[array names idheads
] [array names idtags
] \
7373 [array names idotherrefs
]]
7376 foreach name
[array names tagobjid
] {
7377 lappend tagobjs
$tagobjid($name)
7379 foreach id
[lsort
-unique $refs] {
7380 if {![info exists allparents
($id)] &&
7381 [lsearch
-exact $tagobjs $id] < 0} {
7392 set fd
[open
[concat
$cmd $ids] r
]
7393 fconfigure
$fd -blocking 0
7396 filerun
$fd [list getallclines
$fd]
7402 # Since most commits have 1 parent and 1 child, we group strings of
7403 # such commits into "arcs" joining branch/merge points (BMPs), which
7404 # are commits that either don't have 1 parent or don't have 1 child.
7406 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7407 # arcout(id) - outgoing arcs for BMP
7408 # arcids(a) - list of IDs on arc including end but not start
7409 # arcstart(a) - BMP ID at start of arc
7410 # arcend(a) - BMP ID at end of arc
7411 # growing(a) - arc a is still growing
7412 # arctags(a) - IDs out of arcids (excluding end) that have tags
7413 # archeads(a) - IDs out of arcids (excluding end) that have heads
7414 # The start of an arc is at the descendent end, so "incoming" means
7415 # coming from descendents, and "outgoing" means going towards ancestors.
7417 proc getallclines
{fd
} {
7418 global allparents allchildren idtags idheads nextarc
7419 global arcnos arcids arctags arcout arcend arcstart archeads growing
7420 global seeds allcommits cachedarcs allcupdate
7423 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
7424 set id
[lindex
$line 0]
7425 if {[info exists allparents
($id)]} {
7430 set olds
[lrange
$line 1 end
]
7431 set allparents
($id) $olds
7432 if {![info exists allchildren
($id)]} {
7433 set allchildren
($id) {}
7438 if {[llength
$olds] == 1 && [llength
$a] == 1} {
7439 lappend arcids
($a) $id
7440 if {[info exists idtags
($id)]} {
7441 lappend arctags
($a) $id
7443 if {[info exists idheads
($id)]} {
7444 lappend archeads
($a) $id
7446 if {[info exists allparents
($olds)]} {
7447 # seen parent already
7448 if {![info exists arcout
($olds)]} {
7451 lappend arcids
($a) $olds
7452 set arcend
($a) $olds
7455 lappend allchildren
($olds) $id
7456 lappend arcnos
($olds) $a
7460 foreach a
$arcnos($id) {
7461 lappend arcids
($a) $id
7468 lappend allchildren
($p) $id
7469 set a
[incr nextarc
]
7470 set arcstart
($a) $id
7477 if {[info exists allparents
($p)]} {
7478 # seen it already, may need to make a new branch
7479 if {![info exists arcout
($p)]} {
7482 lappend arcids
($a) $p
7486 lappend arcnos
($p) $a
7491 global cached_dheads cached_dtags cached_atags
7492 catch
{unset cached_dheads
}
7493 catch
{unset cached_dtags
}
7494 catch
{unset cached_atags
}
7497 return [expr {$nid >= 1000?
2: 1}]
7501 fconfigure
$fd -blocking 1
7504 # got an error reading the list of commits
7505 # if we were updating, try rereading the whole thing again
7511 error_popup
"[mc "Error reading commit topology information
;\
7512 branch and preceding
/following tag information\
7513 will be incomplete.
"]\n($err)"
7516 if {[incr allcommits
-1] == 0} {
7526 proc recalcarc
{a
} {
7527 global arctags archeads arcids idtags idheads
7531 foreach id
[lrange
$arcids($a) 0 end-1
] {
7532 if {[info exists idtags
($id)]} {
7535 if {[info exists idheads
($id)]} {
7540 set archeads
($a) $ah
7544 global arcnos arcids nextarc arctags archeads idtags idheads
7545 global arcstart arcend arcout allparents growing
7548 if {[llength
$a] != 1} {
7549 puts
"oops splitarc called but [llength $a] arcs already"
7553 set i
[lsearch
-exact $arcids($a) $p]
7555 puts
"oops splitarc $p not in arc $a"
7558 set na
[incr nextarc
]
7559 if {[info exists arcend
($a)]} {
7560 set arcend
($na) $arcend($a)
7562 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
7563 set j
[lsearch
-exact $arcnos($l) $a]
7564 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
7566 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
7567 set arcids
($a) [lrange
$arcids($a) 0 $i]
7569 set arcstart
($na) $p
7571 set arcids
($na) $tail
7572 if {[info exists growing
($a)]} {
7578 if {[llength
$arcnos($id)] == 1} {
7581 set j
[lsearch
-exact $arcnos($id) $a]
7582 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
7586 # reconstruct tags and heads lists
7587 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
7592 set archeads
($na) {}
7596 # Update things for a new commit added that is a child of one
7597 # existing commit. Used when cherry-picking.
7598 proc addnewchild
{id p
} {
7599 global allparents allchildren idtags nextarc
7600 global arcnos arcids arctags arcout arcend arcstart archeads growing
7601 global seeds allcommits
7603 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
7604 set allparents
($id) [list
$p]
7605 set allchildren
($id) {}
7608 lappend allchildren
($p) $id
7609 set a
[incr nextarc
]
7610 set arcstart
($a) $id
7613 set arcids
($a) [list
$p]
7615 if {![info exists arcout
($p)]} {
7618 lappend arcnos
($p) $a
7619 set arcout
($id) [list
$a]
7622 # This implements a cache for the topology information.
7623 # The cache saves, for each arc, the start and end of the arc,
7624 # the ids on the arc, and the outgoing arcs from the end.
7625 proc readcache
{f
} {
7626 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7627 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7632 if {$lim - $a > 500} {
7633 set lim
[expr {$a + 500}]
7637 # finish reading the cache and setting up arctags, etc.
7639 if {$line ne
"1"} {error
"bad final version"}
7641 foreach id
[array names idtags
] {
7642 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7643 [llength
$allparents($id)] == 1} {
7644 set a
[lindex
$arcnos($id) 0]
7645 if {$arctags($a) eq
{}} {
7650 foreach id
[array names idheads
] {
7651 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7652 [llength
$allparents($id)] == 1} {
7653 set a
[lindex
$arcnos($id) 0]
7654 if {$archeads($a) eq
{}} {
7659 foreach id
[lsort
-unique $possible_seeds] {
7660 if {$arcnos($id) eq
{}} {
7666 while {[incr a
] <= $lim} {
7668 if {[llength
$line] != 3} {error
"bad line"}
7669 set s
[lindex
$line 0]
7671 lappend arcout
($s) $a
7672 if {![info exists arcnos
($s)]} {
7673 lappend possible_seeds
$s
7676 set e
[lindex
$line 1]
7681 if {![info exists arcout
($e)]} {
7685 set arcids
($a) [lindex
$line 2]
7686 foreach id
$arcids($a) {
7687 lappend allparents
($s) $id
7689 lappend arcnos
($id) $a
7691 if {![info exists allparents
($s)]} {
7692 set allparents
($s) {}
7697 set nextarc
[expr {$a - 1}]
7710 global nextarc cachedarcs possible_seeds
7714 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7715 # make sure it's an integer
7716 set cachedarcs
[expr {int
([lindex
$line 1])}]
7717 if {$cachedarcs < 0} {error
"bad number of arcs"}
7719 set possible_seeds
{}
7727 proc dropcache
{err
} {
7728 global allcwait nextarc cachedarcs seeds
7730 #puts "dropping cache ($err)"
7731 foreach v
{arcnos arcout arcids arcstart arcend growing \
7732 arctags archeads allparents allchildren
} {
7743 proc writecache
{f
} {
7744 global cachearc cachedarcs allccache
7745 global arcstart arcend arcnos arcids arcout
7749 if {$lim - $a > 1000} {
7750 set lim
[expr {$a + 1000}]
7753 while {[incr a
] <= $lim} {
7754 if {[info exists arcend
($a)]} {
7755 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7757 puts
$f [list
$arcstart($a) {} $arcids($a)]
7762 catch
{file delete
$allccache}
7763 #puts "writing cache failed ($err)"
7766 set cachearc
[expr {$a - 1}]
7767 if {$a > $cachedarcs} {
7776 global nextarc cachedarcs cachearc allccache
7778 if {$nextarc == $cachedarcs} return
7780 set cachedarcs
$nextarc
7782 set f
[open
$allccache w
]
7783 puts
$f [list
1 $cachedarcs]
7788 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7789 # or 0 if neither is true.
7790 proc anc_or_desc
{a b
} {
7791 global arcout arcstart arcend arcnos cached_isanc
7793 if {$arcnos($a) eq
$arcnos($b)} {
7794 # Both are on the same arc(s); either both are the same BMP,
7795 # or if one is not a BMP, the other is also not a BMP or is
7796 # the BMP at end of the arc (and it only has 1 incoming arc).
7797 # Or both can be BMPs with no incoming arcs.
7798 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7801 # assert {[llength $arcnos($a)] == 1}
7802 set arc
[lindex
$arcnos($a) 0]
7803 set i
[lsearch
-exact $arcids($arc) $a]
7804 set j
[lsearch
-exact $arcids($arc) $b]
7805 if {$i < 0 ||
$i > $j} {
7812 if {![info exists arcout
($a)]} {
7813 set arc
[lindex
$arcnos($a) 0]
7814 if {[info exists arcend
($arc)]} {
7815 set aend
$arcend($arc)
7819 set a
$arcstart($arc)
7823 if {![info exists arcout
($b)]} {
7824 set arc
[lindex
$arcnos($b) 0]
7825 if {[info exists arcend
($arc)]} {
7826 set bend
$arcend($arc)
7830 set b
$arcstart($arc)
7840 if {[info exists cached_isanc
($a,$bend)]} {
7841 if {$cached_isanc($a,$bend)} {
7845 if {[info exists cached_isanc
($b,$aend)]} {
7846 if {$cached_isanc($b,$aend)} {
7849 if {[info exists cached_isanc
($a,$bend)]} {
7854 set todo
[list
$a $b]
7857 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7858 set x
[lindex
$todo $i]
7859 if {$anc($x) eq
{}} {
7862 foreach arc
$arcnos($x) {
7863 set xd
$arcstart($arc)
7865 set cached_isanc
($a,$bend) 1
7866 set cached_isanc
($b,$aend) 0
7868 } elseif
{$xd eq
$aend} {
7869 set cached_isanc
($b,$aend) 1
7870 set cached_isanc
($a,$bend) 0
7873 if {![info exists anc
($xd)]} {
7874 set anc
($xd) $anc($x)
7876 } elseif
{$anc($xd) ne
$anc($x)} {
7881 set cached_isanc
($a,$bend) 0
7882 set cached_isanc
($b,$aend) 0
7886 # This identifies whether $desc has an ancestor that is
7887 # a growing tip of the graph and which is not an ancestor of $anc
7888 # and returns 0 if so and 1 if not.
7889 # If we subsequently discover a tag on such a growing tip, and that
7890 # turns out to be a descendent of $anc (which it could, since we
7891 # don't necessarily see children before parents), then $desc
7892 # isn't a good choice to display as a descendent tag of
7893 # $anc (since it is the descendent of another tag which is
7894 # a descendent of $anc). Similarly, $anc isn't a good choice to
7895 # display as a ancestor tag of $desc.
7897 proc is_certain
{desc anc
} {
7898 global arcnos arcout arcstart arcend growing problems
7901 if {[llength
$arcnos($anc)] == 1} {
7902 # tags on the same arc are certain
7903 if {$arcnos($desc) eq
$arcnos($anc)} {
7906 if {![info exists arcout
($anc)]} {
7907 # if $anc is partway along an arc, use the start of the arc instead
7908 set a
[lindex
$arcnos($anc) 0]
7909 set anc
$arcstart($a)
7912 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7915 set a
[lindex
$arcnos($desc) 0]
7921 set anclist
[list
$x]
7925 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7926 set x
[lindex
$anclist $i]
7931 foreach a
$arcout($x) {
7932 if {[info exists growing
($a)]} {
7933 if {![info exists growanc
($x)] && $dl($x)} {
7939 if {[info exists dl
($y)]} {
7943 if {![info exists
done($y)]} {
7946 if {[info exists growanc
($x)]} {
7950 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7951 set z
[lindex
$xl $k]
7952 foreach c
$arcout($z) {
7953 if {[info exists arcend
($c)]} {
7955 if {[info exists dl
($v)] && $dl($v)} {
7957 if {![info exists
done($v)]} {
7960 if {[info exists growanc
($v)]} {
7970 } elseif
{$y eq
$anc ||
!$dl($x)} {
7981 foreach x
[array names growanc
] {
7990 proc validate_arctags
{a
} {
7991 global arctags idtags
7995 foreach id
$arctags($a) {
7997 if {![info exists idtags
($id)]} {
7998 set na
[lreplace
$na $i $i]
8005 proc validate_archeads
{a
} {
8006 global archeads idheads
8009 set na
$archeads($a)
8010 foreach id
$archeads($a) {
8012 if {![info exists idheads
($id)]} {
8013 set na
[lreplace
$na $i $i]
8017 set archeads
($a) $na
8020 # Return the list of IDs that have tags that are descendents of id,
8021 # ignoring IDs that are descendents of IDs already reported.
8022 proc desctags
{id
} {
8023 global arcnos arcstart arcids arctags idtags allparents
8024 global growing cached_dtags
8026 if {![info exists allparents
($id)]} {
8029 set t1
[clock clicks
-milliseconds]
8031 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8032 # part-way along an arc; check that arc first
8033 set a
[lindex
$arcnos($id) 0]
8034 if {$arctags($a) ne
{}} {
8036 set i
[lsearch
-exact $arcids($a) $id]
8038 foreach t
$arctags($a) {
8039 set j
[lsearch
-exact $arcids($a) $t]
8047 set id
$arcstart($a)
8048 if {[info exists idtags
($id)]} {
8052 if {[info exists cached_dtags
($id)]} {
8053 return $cached_dtags($id)
8060 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8061 set id
[lindex
$todo $i]
8063 set ta
[info exists hastaggedancestor
($id)]
8067 # ignore tags on starting node
8068 if {!$ta && $i > 0} {
8069 if {[info exists idtags
($id)]} {
8072 } elseif
{[info exists cached_dtags
($id)]} {
8073 set tagloc
($id) $cached_dtags($id)
8077 foreach a
$arcnos($id) {
8079 if {!$ta && $arctags($a) ne
{}} {
8081 if {$arctags($a) ne
{}} {
8082 lappend tagloc
($id) [lindex
$arctags($a) end
]
8085 if {$ta ||
$arctags($a) ne
{}} {
8086 set tomark
[list
$d]
8087 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8088 set dd [lindex
$tomark $j]
8089 if {![info exists hastaggedancestor
($dd)]} {
8090 if {[info exists
done($dd)]} {
8091 foreach b
$arcnos($dd) {
8092 lappend tomark
$arcstart($b)
8094 if {[info exists tagloc
($dd)]} {
8097 } elseif
{[info exists queued
($dd)]} {
8100 set hastaggedancestor
($dd) 1
8104 if {![info exists queued
($d)]} {
8107 if {![info exists hastaggedancestor
($d)]} {
8114 foreach id
[array names tagloc
] {
8115 if {![info exists hastaggedancestor
($id)]} {
8116 foreach t
$tagloc($id) {
8117 if {[lsearch
-exact $tags $t] < 0} {
8123 set t2
[clock clicks
-milliseconds]
8126 # remove tags that are descendents of other tags
8127 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8128 set a
[lindex
$tags $i]
8129 for {set j
0} {$j < $i} {incr j
} {
8130 set b
[lindex
$tags $j]
8131 set r
[anc_or_desc
$a $b]
8133 set tags
[lreplace
$tags $j $j]
8136 } elseif
{$r == -1} {
8137 set tags
[lreplace
$tags $i $i]
8144 if {[array names growing
] ne
{}} {
8145 # graph isn't finished, need to check if any tag could get
8146 # eclipsed by another tag coming later. Simply ignore any
8147 # tags that could later get eclipsed.
8150 if {[is_certain
$t $origid]} {
8154 if {$tags eq
$ctags} {
8155 set cached_dtags
($origid) $tags
8160 set cached_dtags
($origid) $tags
8162 set t3
[clock clicks
-milliseconds]
8163 if {0 && $t3 - $t1 >= 100} {
8164 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
8165 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8171 global arcnos arcids arcout arcend arctags idtags allparents
8172 global growing cached_atags
8174 if {![info exists allparents
($id)]} {
8177 set t1
[clock clicks
-milliseconds]
8179 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8180 # part-way along an arc; check that arc first
8181 set a
[lindex
$arcnos($id) 0]
8182 if {$arctags($a) ne
{}} {
8184 set i
[lsearch
-exact $arcids($a) $id]
8185 foreach t
$arctags($a) {
8186 set j
[lsearch
-exact $arcids($a) $t]
8192 if {![info exists arcend
($a)]} {
8196 if {[info exists idtags
($id)]} {
8200 if {[info exists cached_atags
($id)]} {
8201 return $cached_atags($id)
8209 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8210 set id
[lindex
$todo $i]
8212 set td
[info exists hastaggeddescendent
($id)]
8216 # ignore tags on starting node
8217 if {!$td && $i > 0} {
8218 if {[info exists idtags
($id)]} {
8221 } elseif
{[info exists cached_atags
($id)]} {
8222 set tagloc
($id) $cached_atags($id)
8226 foreach a
$arcout($id) {
8227 if {!$td && $arctags($a) ne
{}} {
8229 if {$arctags($a) ne
{}} {
8230 lappend tagloc
($id) [lindex
$arctags($a) 0]
8233 if {![info exists arcend
($a)]} continue
8235 if {$td ||
$arctags($a) ne
{}} {
8236 set tomark
[list
$d]
8237 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8238 set dd [lindex
$tomark $j]
8239 if {![info exists hastaggeddescendent
($dd)]} {
8240 if {[info exists
done($dd)]} {
8241 foreach b
$arcout($dd) {
8242 if {[info exists arcend
($b)]} {
8243 lappend tomark
$arcend($b)
8246 if {[info exists tagloc
($dd)]} {
8249 } elseif
{[info exists queued
($dd)]} {
8252 set hastaggeddescendent
($dd) 1
8256 if {![info exists queued
($d)]} {
8259 if {![info exists hastaggeddescendent
($d)]} {
8265 set t2
[clock clicks
-milliseconds]
8268 foreach id
[array names tagloc
] {
8269 if {![info exists hastaggeddescendent
($id)]} {
8270 foreach t
$tagloc($id) {
8271 if {[lsearch
-exact $tags $t] < 0} {
8278 # remove tags that are ancestors of other tags
8279 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8280 set a
[lindex
$tags $i]
8281 for {set j
0} {$j < $i} {incr j
} {
8282 set b
[lindex
$tags $j]
8283 set r
[anc_or_desc
$a $b]
8285 set tags
[lreplace
$tags $j $j]
8288 } elseif
{$r == 1} {
8289 set tags
[lreplace
$tags $i $i]
8296 if {[array names growing
] ne
{}} {
8297 # graph isn't finished, need to check if any tag could get
8298 # eclipsed by another tag coming later. Simply ignore any
8299 # tags that could later get eclipsed.
8302 if {[is_certain
$origid $t]} {
8306 if {$tags eq
$ctags} {
8307 set cached_atags
($origid) $tags
8312 set cached_atags
($origid) $tags
8314 set t3
[clock clicks
-milliseconds]
8315 if {0 && $t3 - $t1 >= 100} {
8316 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
8317 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8322 # Return the list of IDs that have heads that are descendents of id,
8323 # including id itself if it has a head.
8324 proc descheads
{id
} {
8325 global arcnos arcstart arcids archeads idheads cached_dheads
8328 if {![info exists allparents
($id)]} {
8332 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8333 # part-way along an arc; check it first
8334 set a
[lindex
$arcnos($id) 0]
8335 if {$archeads($a) ne
{}} {
8336 validate_archeads
$a
8337 set i
[lsearch
-exact $arcids($a) $id]
8338 foreach t
$archeads($a) {
8339 set j
[lsearch
-exact $arcids($a) $t]
8344 set id
$arcstart($a)
8350 for {set i
0} {$i < [llength
$todo]} {incr i
} {
8351 set id
[lindex
$todo $i]
8352 if {[info exists cached_dheads
($id)]} {
8353 set ret
[concat
$ret $cached_dheads($id)]
8355 if {[info exists idheads
($id)]} {
8358 foreach a
$arcnos($id) {
8359 if {$archeads($a) ne
{}} {
8360 validate_archeads
$a
8361 if {$archeads($a) ne
{}} {
8362 set ret
[concat
$ret $archeads($a)]
8366 if {![info exists seen
($d)]} {
8373 set ret
[lsort
-unique $ret]
8374 set cached_dheads
($origid) $ret
8375 return [concat
$ret $aret]
8378 proc addedtag
{id
} {
8379 global arcnos arcout cached_dtags cached_atags
8381 if {![info exists arcnos
($id)]} return
8382 if {![info exists arcout
($id)]} {
8383 recalcarc
[lindex
$arcnos($id) 0]
8385 catch
{unset cached_dtags
}
8386 catch
{unset cached_atags
}
8389 proc addedhead
{hid
head} {
8390 global arcnos arcout cached_dheads
8392 if {![info exists arcnos
($hid)]} return
8393 if {![info exists arcout
($hid)]} {
8394 recalcarc
[lindex
$arcnos($hid) 0]
8396 catch
{unset cached_dheads
}
8399 proc removedhead
{hid
head} {
8400 global cached_dheads
8402 catch
{unset cached_dheads
}
8405 proc movedhead
{hid
head} {
8406 global arcnos arcout cached_dheads
8408 if {![info exists arcnos
($hid)]} return
8409 if {![info exists arcout
($hid)]} {
8410 recalcarc
[lindex
$arcnos($hid) 0]
8412 catch
{unset cached_dheads
}
8415 proc changedrefs
{} {
8416 global cached_dheads cached_dtags cached_atags
8417 global arctags archeads arcnos arcout idheads idtags
8419 foreach id
[concat
[array names idheads
] [array names idtags
]] {
8420 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
8421 set a
[lindex
$arcnos($id) 0]
8422 if {![info exists donearc
($a)]} {
8428 catch
{unset cached_dtags
}
8429 catch
{unset cached_atags
}
8430 catch
{unset cached_dheads
}
8433 proc rereadrefs
{} {
8434 global idtags idheads idotherrefs mainheadid
8436 set refids
[concat
[array names idtags
] \
8437 [array names idheads
] [array names idotherrefs
]]
8438 foreach id
$refids {
8439 if {![info exists ref
($id)]} {
8440 set ref
($id) [listrefs
$id]
8443 set oldmainhead
$mainheadid
8446 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
8447 [array names idheads
] [array names idotherrefs
]]]
8448 foreach id
$refids {
8449 set v
[listrefs
$id]
8450 if {![info exists ref
($id)] ||
$ref($id) != $v ||
8451 ($id eq
$oldmainhead && $id ne
$mainheadid) ||
8452 ($id eq
$mainheadid && $id ne
$oldmainhead)} {
8459 proc listrefs
{id
} {
8460 global idtags idheads idotherrefs
8463 if {[info exists idtags
($id)]} {
8467 if {[info exists idheads
($id)]} {
8471 if {[info exists idotherrefs
($id)]} {
8472 set z
$idotherrefs($id)
8474 return [list
$x $y $z]
8477 proc showtag
{tag isnew
} {
8478 global ctext tagcontents tagids linknum tagobjid
8481 addtohistory
[list showtag
$tag 0]
8483 $ctext conf
-state normal
8487 if {![info exists tagcontents
($tag)]} {
8489 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
8492 if {[info exists tagcontents
($tag)]} {
8493 set text
$tagcontents($tag)
8495 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
8497 appendwithlinks
$text {}
8498 $ctext conf
-state disabled
8509 proc mkfontdisp
{font top
which} {
8510 global fontattr fontpref
$font
8512 set fontpref
($font) [set $font]
8513 button
$top.
${font}but
-text $which -font optionfont \
8514 -command [list choosefont
$font $which]
8515 label
$top.
$font -relief flat
-font $font \
8516 -text $fontattr($font,family
) -justify left
8517 grid x
$top.
${font}but
$top.
$font -sticky w
8520 proc choosefont
{font
which} {
8521 global fontparam fontlist fonttop fontattr
8523 set fontparam
(which) $which
8524 set fontparam
(font
) $font
8525 set fontparam
(family
) [font actual
$font -family]
8526 set fontparam
(size
) $fontattr($font,size
)
8527 set fontparam
(weight
) $fontattr($font,weight
)
8528 set fontparam
(slant
) $fontattr($font,slant
)
8531 if {![winfo exists
$top]} {
8533 eval font config sample
[font actual
$font]
8535 wm title
$top [mc
"Gitk font chooser"]
8536 label
$top.l
-textvariable fontparam
(which)
8537 pack
$top.l
-side top
8538 set fontlist
[lsort
[font families
]]
8540 listbox
$top.f.fam
-listvariable fontlist \
8541 -yscrollcommand [list
$top.f.sb
set]
8542 bind $top.f.fam
<<ListboxSelect>> selfontfam
8543 scrollbar $top.f.sb -command [list $top.f.fam yview]
8544 pack $top.f.sb -side right -fill y
8545 pack $top.f.fam -side left -fill both -expand 1
8546 pack $top.f -side top -fill both -expand 1
8548 spinbox $top.g.size -from 4 -to 40 -width 4 \
8549 -textvariable fontparam(size) \
8550 -validatecommand {string is integer -strict %s}
8551 checkbutton $top.g.bold -padx 5 \
8552 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8553 -variable fontparam(weight) -onvalue bold -offvalue normal
8554 checkbutton $top.g.ital -padx 5 \
8555 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8556 -variable fontparam(slant) -onvalue italic -offvalue roman
8557 pack $top.g.size $top.g.bold $top.g.ital -side left
8558 pack $top.g -side top
8559 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8561 $top.c create text 100 25 -anchor center -text $which -font sample \
8562 -fill black -tags text
8563 bind $top.c <Configure> [list centertext $top.c]
8564 pack $top.c -side top -fill x
8566 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8567 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8568 grid $top.buts.ok $top.buts.can
8569 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8570 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8571 pack $top.buts -side bottom -fill x
8572 trace add variable fontparam write chg_fontparam
8575 $top.c itemconf text -text $which
8577 set i [lsearch -exact $fontlist $fontparam(family)]
8579 $top.f.fam selection set $i
8584 proc centertext {w} {
8585 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8589 global fontparam fontpref prefstop
8591 set f $fontparam(font)
8592 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8593 if {$fontparam(weight) eq "bold"} {
8594 lappend fontpref($f) "bold"
8596 if {$fontparam(slant) eq "italic"} {
8597 lappend fontpref($f) "italic"
8600 $w conf -text $fontparam(family) -font $fontpref($f)
8606 global fonttop fontparam
8608 if {[info exists fonttop]} {
8609 catch {destroy $fonttop}
8610 catch {font delete sample}
8616 proc selfontfam {} {
8617 global fonttop fontparam
8619 set i [$fonttop.f.fam curselection]
8621 set fontparam(family) [$fonttop.f.fam get $i]
8625 proc chg_fontparam {v sub op} {
8628 font config sample -$sub $fontparam($sub)
8632 global maxwidth maxgraphpct
8633 global oldprefs prefstop showneartags showlocalchanges
8634 global bgcolor fgcolor ctext diffcolors selectbgcolor
8635 global tabstop limitdiffs
8639 if {[winfo exists $top]} {
8643 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8644 limitdiffs tabstop} {
8645 set oldprefs($v) [set $v]
8648 wm title $top [mc "Gitk preferences"]
8649 label $top.ldisp -text [mc "Commit list display options"]
8650 grid $top.ldisp - -sticky w -pady 10
8651 label $top.spacer -text " "
8652 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8654 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8655 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8656 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8658 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8659 grid x $top.maxpctl $top.maxpct -sticky w
8660 frame $top.showlocal
8661 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8662 checkbutton $top.showlocal.b -variable showlocalchanges
8663 pack $top.showlocal.b $top.showlocal.l -side left
8664 grid x $top.showlocal -sticky w
8666 label $top.ddisp -text [mc "Diff display options"]
8667 grid $top.ddisp - -sticky w -pady 10
8668 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8669 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8670 grid x $top.tabstopl $top.tabstop -sticky w
8672 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8673 checkbutton $top.ntag.b -variable showneartags
8674 pack $top.ntag.b $top.ntag.l -side left
8675 grid x $top.ntag -sticky w
8677 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8678 checkbutton $top.ldiff.b -variable limitdiffs
8679 pack $top.ldiff.b $top.ldiff.l -side left
8680 grid x $top.ldiff -sticky w
8682 label $top.cdisp -text [mc "Colors: press to choose"]
8683 grid $top.cdisp - -sticky w -pady 10
8684 label $top.bg -padx 40 -relief sunk -background $bgcolor
8685 button $top.bgbut -text [mc "Background"] -font optionfont \
8686 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8687 grid x $top.bgbut $top.bg -sticky w
8688 label $top.fg -padx 40 -relief sunk -background $fgcolor
8689 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8690 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8691 grid x $top.fgbut $top.fg -sticky w
8692 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8693 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8694 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8695 [list $ctext tag conf d0 -foreground]]
8696 grid x $top.diffoldbut $top.diffold -sticky w
8697 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8698 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8699 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8700 [list $ctext tag conf d1 -foreground]]
8701 grid x $top.diffnewbut $top.diffnew -sticky w
8702 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8703 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8704 -command [list choosecolor diffcolors 2 $top.hunksep \
8705 "diff hunk header" \
8706 [list $ctext tag conf hunksep -foreground]]
8707 grid x $top.hunksepbut $top.hunksep -sticky w
8708 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8709 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8710 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8711 grid x $top.selbgbut $top.selbgsep -sticky w
8713 label $top.cfont -text [mc "Fonts: press to choose"]
8714 grid $top.cfont - -sticky w -pady 10
8715 mkfontdisp mainfont $top [mc "Main font"]
8716 mkfontdisp textfont $top [mc "Diff display font"]
8717 mkfontdisp uifont $top [mc "User interface font"]
8720 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8721 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8722 grid $top.buts.ok $top.buts.can
8723 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8724 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8725 grid $top.buts - - -pady 10 -sticky ew
8726 bind $top <Visibility> "focus $top.buts.ok"
8729 proc choosecolor {v vi w x cmd} {
8732 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8733 -title [mc "Gitk: choose color for %s" $x]]
8734 if {$c eq {}} return
8735 $w conf -background $c
8741 global bglist cflist
8743 $w configure -selectbackground $c
8745 $cflist tag configure highlight \
8746 -background [$cflist cget -selectbackground]
8747 allcanvs itemconf secsel -fill $c
8754 $w conf -background $c
8762 $w conf -foreground $c
8764 allcanvs itemconf text -fill $c
8765 $canv itemconf circle -outline $c
8769 global oldprefs prefstop
8771 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8772 limitdiffs tabstop} {
8774 set $v $oldprefs($v)
8776 catch {destroy $prefstop}
8782 global maxwidth maxgraphpct
8783 global oldprefs prefstop showneartags showlocalchanges
8784 global fontpref mainfont textfont uifont
8785 global limitdiffs treediffs
8787 catch {destroy $prefstop}
8791 if {$mainfont ne $fontpref(mainfont)} {
8792 set mainfont $fontpref(mainfont)
8793 parsefont mainfont $mainfont
8794 eval font configure mainfont [fontflags mainfont]
8795 eval font configure mainfontbold [fontflags mainfont 1]
8799 if {$textfont ne $fontpref(textfont)} {
8800 set textfont $fontpref(textfont)
8801 parsefont textfont $textfont
8802 eval font configure textfont [fontflags textfont]
8803 eval font configure textfontbold [fontflags textfont 1]
8805 if {$uifont ne $fontpref(uifont)} {
8806 set uifont $fontpref(uifont)
8807 parsefont uifont $uifont
8808 eval font configure uifont [fontflags uifont]
8811 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8812 if {$showlocalchanges} {
8818 if {$limitdiffs != $oldprefs(limitdiffs)} {
8819 # treediffs elements are limited by path
8820 catch {unset treediffs}
8822 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8823 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8825 } elseif {$showneartags != $oldprefs(showneartags) ||
8826 $limitdiffs != $oldprefs(limitdiffs)} {
8831 proc formatdate {d} {
8832 global datetimeformat
8834 set d [clock format $d -format $datetimeformat]
8839 # This list of encoding names and aliases is distilled from
8840 # http://www.iana.org/assignments/character-sets.
8841 # Not all of them are supported by Tcl.
8842 set encoding_aliases {
8843 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8844 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8845 { ISO-10646-UTF-1 csISO10646UTF1 }
8846 { ISO_646.basic:1983 ref csISO646basic1983 }
8847 { INVARIANT csINVARIANT }
8848 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8849 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8850 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8851 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8852 { NATS-DANO iso-ir-9-1 csNATSDANO }
8853 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8854 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8855 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8856 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8857 { ISO-2022-KR csISO2022KR }
8859 { ISO-2022-JP csISO2022JP }
8860 { ISO-2022-JP-2 csISO2022JP2 }
8861 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8863 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8864 { IT iso-ir-15 ISO646-IT csISO15Italian }
8865 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8866 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8867 { greek7-old iso-ir-18 csISO18Greek7Old }
8868 { latin-greek iso-ir-19 csISO19LatinGreek }
8869 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8870 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8871 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8872 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8873 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8874 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8875 { INIS iso-ir-49 csISO49INIS }
8876 { INIS-8 iso-ir-50 csISO50INIS8 }
8877 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8878 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8879 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8880 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8881 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8882 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8884 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8885 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8886 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8887 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8888 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8889 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8890 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8891 { greek7 iso-ir-88 csISO88Greek7 }
8892 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8893 { iso-ir-90 csISO90 }
8894 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8895 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8896 csISO92JISC62991984b }
8897 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8898 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8899 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8900 csISO95JIS62291984handadd }
8901 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8902 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8903 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8904 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8906 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8907 { T.61-7bit iso-ir-102 csISO102T617bit }
8908 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8909 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8910 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8911 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8912 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8913 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8914 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8915 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8916 arabic csISOLatinArabic }
8917 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8918 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8919 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8920 greek greek8 csISOLatinGreek }
8921 { T.101-G2 iso-ir-128 csISO128T101G2 }
8922 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8924 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8925 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8926 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8927 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8928 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8929 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8930 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8931 csISOLatinCyrillic }
8932 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8933 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8934 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8935 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8936 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8937 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8938 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8939 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8940 { ISO_10367-box iso-ir-155 csISO10367Box }
8941 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8942 { latin-lap lap iso-ir-158 csISO158Lap }
8943 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8944 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8947 { JIS_X0201 X0201 csHalfWidthKatakana }
8948 { KSC5636 ISO646-KR csKSC5636 }
8949 { ISO-10646-UCS-2 csUnicode }
8950 { ISO-10646-UCS-4 csUCS4 }
8951 { DEC-MCS dec csDECMCS }
8952 { hp-roman8 roman8 r8 csHPRoman8 }
8953 { macintosh mac csMacintosh }
8954 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8956 { IBM038 EBCDIC-INT cp038 csIBM038 }
8957 { IBM273 CP273 csIBM273 }
8958 { IBM274 EBCDIC-BE CP274 csIBM274 }
8959 { IBM275 EBCDIC-BR cp275 csIBM275 }
8960 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8961 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8962 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8963 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8964 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8965 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8966 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8967 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8968 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8969 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8970 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8971 { IBM437 cp437 437 csPC8CodePage437 }
8972 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8973 { IBM775 cp775 csPC775Baltic }
8974 { IBM850 cp850 850 csPC850Multilingual }
8975 { IBM851 cp851 851 csIBM851 }
8976 { IBM852 cp852 852 csPCp852 }
8977 { IBM855 cp855 855 csIBM855 }
8978 { IBM857 cp857 857 csIBM857 }
8979 { IBM860 cp860 860 csIBM860 }
8980 { IBM861 cp861 861 cp-is csIBM861 }
8981 { IBM862 cp862 862 csPC862LatinHebrew }
8982 { IBM863 cp863 863 csIBM863 }
8983 { IBM864 cp864 csIBM864 }
8984 { IBM865 cp865 865 csIBM865 }
8985 { IBM866 cp866 866 csIBM866 }
8986 { IBM868 CP868 cp-ar csIBM868 }
8987 { IBM869 cp869 869 cp-gr csIBM869 }
8988 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8989 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8990 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8991 { IBM891 cp891 csIBM891 }
8992 { IBM903 cp903 csIBM903 }
8993 { IBM904 cp904 904 csIBBM904 }
8994 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8995 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8996 { IBM1026 CP1026 csIBM1026 }
8997 { EBCDIC-AT-DE csIBMEBCDICATDE }
8998 { EBCDIC-AT-DE-A csEBCDICATDEA }
8999 { EBCDIC-CA-FR csEBCDICCAFR }
9000 { EBCDIC-DK-NO csEBCDICDKNO }
9001 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9002 { EBCDIC-FI-SE csEBCDICFISE }
9003 { EBCDIC-FI-SE-A csEBCDICFISEA }
9004 { EBCDIC-FR csEBCDICFR }
9005 { EBCDIC-IT csEBCDICIT }
9006 { EBCDIC-PT csEBCDICPT }
9007 { EBCDIC-ES csEBCDICES }
9008 { EBCDIC-ES-A csEBCDICESA }
9009 { EBCDIC-ES-S csEBCDICESS }
9010 { EBCDIC-UK csEBCDICUK }
9011 { EBCDIC-US csEBCDICUS }
9012 { UNKNOWN-8BIT csUnknown8BiT }
9013 { MNEMONIC csMnemonic }
9018 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9019 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9020 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9021 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9022 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9023 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9024 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9025 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9026 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9027 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9028 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9029 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9030 { IBM1047 IBM-1047 }
9031 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9032 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9033 { UNICODE-1-1 csUnicode11 }
9036 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9037 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9039 { ISO-8859-15 ISO_8859-15 Latin-9 }
9040 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9041 { GBK CP936 MS936 windows-936 }
9042 { JIS_Encoding csJISEncoding }
9043 { Shift_JIS MS_Kanji csShiftJIS }
9044 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9046 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9047 { ISO-10646-UCS-Basic csUnicodeASCII }
9048 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9049 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9050 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9051 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9052 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9053 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9054 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9055 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9056 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9057 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9058 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9059 { Ventura-US csVenturaUS }
9060 { Ventura-International csVenturaInternational }
9061 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9062 { PC8-Turkish csPC8Turkish }
9063 { IBM-Symbols csIBMSymbols }
9064 { IBM-Thai csIBMThai }
9065 { HP-Legal csHPLegal }
9066 { HP-Pi-font csHPPiFont }
9067 { HP-Math8 csHPMath8 }
9068 { Adobe-Symbol-Encoding csHPPSMath }
9069 { HP-DeskTop csHPDesktop }
9070 { Ventura-Math csVenturaMath }
9071 { Microsoft-Publishing csMicrosoftPublishing }
9072 { Windows-31J csWindows31J }
9077 proc tcl_encoding {enc} {
9078 global encoding_aliases
9079 set names [encoding names]
9080 set lcnames [string tolower $names]
9081 set enc [string tolower $enc]
9082 set i [lsearch -exact $lcnames $enc]
9084 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9085 if {[regsub {^iso[-_]} $enc iso encx]} {
9086 set i [lsearch -exact $lcnames $encx]
9090 foreach l $encoding_aliases {
9091 set ll [string tolower $l]
9092 if {[lsearch -exact $ll $enc] < 0} continue
9093 # look through the aliases for one that tcl knows about
9095 set i [lsearch -exact $lcnames $e]
9097 if {[regsub {^iso[-_]} $e iso ex]} {
9098 set i [lsearch -exact $lcnames $ex]
9107 return [lindex $names $i]
9112 # First check that Tcl/Tk is recent enough
9113 if {[catch {package require Tk 8.4} err]} {
9114 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9115 Gitk requires at least Tcl/Tk 8.4."]
9121 set wrcomcmd "git diff-tree --stdin -p --pretty"
9125 set gitencoding [exec git config --get i18n.commitencoding]
9127 if {$gitencoding == ""} {
9128 set gitencoding "utf-8"
9130 set tclencoding [tcl_encoding $gitencoding]
9131 if {$tclencoding == {}} {
9132 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9135 set mainfont {Helvetica 9}
9136 set textfont {Courier 9}
9137 set uifont {Helvetica 9 bold}
9139 set findmergefiles 0
9147 set cmitmode "patch"
9148 set wrapcomment "none"
9152 set showlocalchanges 1
9154 set datetimeformat "%Y-%m-%d %H:%M:%S"
9156 set colors {green red blue magenta darkgrey brown orange}
9159 set diffcolors {red "#00a000" blue}
9161 set selectbgcolor gray85
9163 ## For msgcat loading, first locate the installation location.
9164 if { [info exists ::env(GITK_MSGSDIR)] } {
9165 ## Msgsdir was manually set in the environment.
9166 set gitk_msgsdir $::env(GITK_MSGSDIR)
9168 ## Let's guess the prefix from argv0.
9169 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9170 set gitk_libdir [file join $gitk_prefix share gitk lib]
9171 set gitk_msgsdir [file join $gitk_libdir msgs]
9175 ## Internationalization (i18n) through msgcat and gettext. See
9176 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9177 package require msgcat
9178 namespace import ::msgcat::mc
9179 ## And eventually load the actual message catalog
9180 ::msgcat::mcload $gitk_msgsdir
9182 catch {source ~/.gitk}
9184 font create optionfont -family sans-serif -size -12
9186 parsefont mainfont $mainfont
9187 eval font create mainfont [fontflags mainfont]
9188 eval font create mainfontbold [fontflags mainfont 1]
9190 parsefont textfont $textfont
9191 eval font create textfont [fontflags textfont]
9192 eval font create textfontbold [fontflags textfont 1]
9194 parsefont uifont $uifont
9195 eval font create uifont [fontflags uifont]
9199 # check that we can find a .git directory somewhere...
9200 if {[catch {set gitdir [gitdir]}]} {
9201 show_error {} . [mc "Cannot find a git repository here."]
9204 if {![file isdirectory $gitdir]} {
9205 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9211 set cmdline_files {}
9216 "-d" { set datemode 1 }
9219 lappend revtreeargs $arg
9222 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9226 lappend revtreeargs $arg
9232 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9233 # no -- on command line, but some arguments (other than -d)
9235 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9236 set cmdline_files [split $f "\n"]
9237 set n [llength $cmdline_files]
9238 set revtreeargs [lrange $revtreeargs 0 end-$n]
9239 # Unfortunately git rev-parse doesn't produce an error when
9240 # something is both a revision and a filename. To be consistent
9241 # with git log and git rev-list, check revtreeargs for filenames.
9242 foreach arg $revtreeargs {
9243 if {[file exists $arg]} {
9244 show_error {} . [mc "Ambiguous argument '%s': both revision\
9250 # unfortunately we get both stdout and stderr in $err,
9251 # so look for "fatal:".
9252 set i [string first "fatal:" $err]
9254 set err [string range $err [expr {$i + 6}] end]
9256 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9262 # find the list of unmerged files
9266 set fd [open "| git ls-files -u" r]
9268 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9271 while {[gets $fd line] >= 0} {
9272 set i [string first "\t" $line]
9273 if {$i < 0} continue
9274 set fname [string range $line [expr {$i+1}] end]
9275 if {[lsearch -exact $mlist $fname] >= 0} continue
9277 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9278 lappend mlist $fname
9283 if {$nr_unmerged == 0} {
9284 show_error {} . [mc "No files selected: --merge specified but\
9285 no files are unmerged."]
9287 show_error {} . [mc "No files selected: --merge specified but\
9288 no unmerged files are within file limit."]
9292 set cmdline_files $mlist
9295 set nullid "0000000000000000000000000000000000000000"
9296 set nullid2 "0000000000000000000000000000000000000001"
9298 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9305 set highlight_paths {}
9307 set searchdirn -forwards
9311 set markingmatches 0
9312 set linkentercount 0
9313 set need_redisplay 0
9320 set selectedhlview [mc "None"]
9321 set highlight_related [mc "None"]
9322 set highlight_files {}
9335 # wait for the window to become visible
9337 wm title . "[file tail $argv0]: [file tail [pwd]]"
9340 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9341 # create a view for the files/dirs specified on the command line
9345 set viewname(1) [mc "Command line"]
9346 set viewfiles(1) $cmdline_files
9347 set viewargs(1) $revtreeargs
9350 .bar.view entryconf [mc "Edit view..."] -state normal
9351 .bar.view entryconf [mc "Delete view"] -state normal
9354 if {[info exists permviews]} {
9355 foreach v $permviews {
9358 set viewname($n) [lindex $v 0]
9359 set viewfiles($n) [lindex $v 1]
9360 set viewargs($n) [lindex $v 2]