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 {![string match
"^*" $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 \
191 if {[string match
"^*" $c]} {
194 if {!([info exists varcid
($view,$c)] ||
195 [lsearch
-exact $viewincl($view) $c] >= 0)} {
203 foreach id
$viewincl($view) {
206 set viewincl
($view) [concat
$viewincl($view) $pos]
208 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
209 --boundary $pos $neg "--" $viewfiles($view)] r
]
211 error_popup
"Error executing git log: $err"
214 if {$viewactive($view) == 0} {
215 set startmsecs
[clock clicks
-milliseconds]
217 set i
[incr loginstance
]
218 lappend viewinstances
($view) $i
221 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
222 if {$tclencoding != {}} {
223 fconfigure
$fd -encoding $tclencoding
225 filerun
$fd [list getcommitlines
$fd $i $view]
226 incr viewactive
($view)
227 set viewcomplete
($view) 0
228 nowbusy
$view "Reading"
234 proc reloadcommits
{} {
235 global curview viewcomplete selectedline currentid thickerline
236 global showneartags treediffs commitinterest cached_commitrow
237 global progresscoords targetid
239 if {!$viewcomplete($curview)} {
240 stop_rev_list
$curview
241 set progresscoords
{0 0}
245 catch
{unset selectedline
}
246 catch
{unset currentid
}
247 catch
{unset thickerline
}
248 catch
{unset treediffs
}
255 catch
{unset commitinterest
}
256 catch
{unset cached_commitrow
}
257 catch
{unset targetid
}
262 # This makes a string representation of a positive integer which
263 # sorts as a string in numerical order
266 return [format
"%x" $n]
267 } elseif
{$n < 256} {
268 return [format
"x%.2x" $n]
269 } elseif
{$n < 65536} {
270 return [format
"y%.4x" $n]
272 return [format
"z%.8x" $n]
275 # Procedures used in reordering commits from git log (without
276 # --topo-order) into the order for display.
278 proc varcinit
{view
} {
279 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
280 global vtokmod varcmod vrowmod varcix vlastins
282 set varcstart
($view) {{}}
283 set vupptr
($view) {0}
284 set vdownptr
($view) {0}
285 set vleftptr
($view) {0}
286 set vbackptr
($view) {0}
287 set varctok
($view) {{}}
288 set varcrow
($view) {{}}
289 set vtokmod
($view) {}
292 set varcix
($view) {{}}
293 set vlastins
($view) {0}
296 proc resetvarcs
{view
} {
297 global varcid varccommits parents children vseedcount ordertok
299 foreach vid
[array names varcid
$view,*] {
304 # some commits might have children but haven't been seen yet
305 foreach vid
[array names children
$view,*] {
308 foreach va
[array names varccommits
$view,*] {
309 unset varccommits
($va)
311 foreach vd
[array names vseedcount
$view,*] {
312 unset vseedcount
($vd)
314 catch
{unset ordertok
}
317 proc newvarc
{view id
} {
318 global varcid varctok parents children datemode
319 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
320 global commitdata commitinfo vseedcount varccommits vlastins
322 set a
[llength
$varctok($view)]
324 if {[llength
$children($vid)] == 0 ||
$datemode} {
325 if {![info exists commitinfo
($id)]} {
326 parsecommit
$id $commitdata($id) 1
328 set cdate
[lindex
$commitinfo($id) 4]
329 if {![string is integer
-strict $cdate]} {
332 if {![info exists vseedcount
($view,$cdate)]} {
333 set vseedcount
($view,$cdate) -1
335 set c
[incr vseedcount
($view,$cdate)]
336 set cdate
[expr {$cdate ^
0xffffffff}]
337 set tok
"s[strrep $cdate][strrep $c]"
342 if {[llength
$children($vid)] > 0} {
343 set kid
[lindex
$children($vid) end
]
344 set k
$varcid($view,$kid)
345 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
348 set tok
[lindex
$varctok($view) $k]
352 set i
[lsearch
-exact $parents($view,$ki) $id]
353 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
354 append tok
[strrep
$j]
356 set c
[lindex
$vlastins($view) $ka]
357 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
359 set b
[lindex
$vdownptr($view) $ka]
361 set b
[lindex
$vleftptr($view) $c]
363 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
365 set b
[lindex
$vleftptr($view) $c]
368 lset vdownptr
($view) $ka $a
369 lappend vbackptr
($view) 0
371 lset vleftptr
($view) $c $a
372 lappend vbackptr
($view) $c
374 lset vlastins
($view) $ka $a
375 lappend vupptr
($view) $ka
376 lappend vleftptr
($view) $b
378 lset vbackptr
($view) $b $a
380 lappend varctok
($view) $tok
381 lappend varcstart
($view) $id
382 lappend vdownptr
($view) 0
383 lappend varcrow
($view) {}
384 lappend varcix
($view) {}
385 set varccommits
($view,$a) {}
386 lappend vlastins
($view) 0
390 proc splitvarc
{p v
} {
391 global varcid varcstart varccommits varctok
392 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
394 set oa
$varcid($v,$p)
395 set ac
$varccommits($v,$oa)
396 set i
[lsearch
-exact $varccommits($v,$oa) $p]
398 set na
[llength
$varctok($v)]
399 # "%" sorts before "0"...
400 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
401 lappend varctok
($v) $tok
402 lappend varcrow
($v) {}
403 lappend varcix
($v) {}
404 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
405 set varccommits
($v,$na) [lrange
$ac $i end
]
406 lappend varcstart
($v) $p
407 foreach id
$varccommits($v,$na) {
408 set varcid
($v,$id) $na
410 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
411 lset vdownptr
($v) $oa $na
412 lappend vupptr
($v) $oa
413 lappend vleftptr
($v) 0
414 lappend vbackptr
($v) 0
415 lappend vlastins
($v) 0
416 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
417 lset vupptr
($v) $b $na
421 proc renumbervarc
{a v
} {
422 global parents children varctok varcstart varccommits
423 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
425 set t1
[clock clicks
-milliseconds]
431 if {[info exists isrelated
($a)]} {
433 set id
[lindex
$varccommits($v,$a) end
]
434 foreach p
$parents($v,$id) {
435 if {[info exists varcid
($v,$p)]} {
436 set isrelated
($varcid($v,$p)) 1
441 set b
[lindex
$vdownptr($v) $a]
444 set b
[lindex
$vleftptr($v) $a]
446 set a
[lindex
$vupptr($v) $a]
452 if {![info exists kidchanged
($a)]} continue
453 set id
[lindex
$varcstart($v) $a]
454 if {[llength
$children($v,$id)] > 1} {
455 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
458 set oldtok
[lindex
$varctok($v) $a]
465 set kid
[last_real_child
$v,$id]
467 set k
$varcid($v,$kid)
468 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
471 set tok
[lindex
$varctok($v) $k]
475 set i
[lsearch
-exact $parents($v,$ki) $id]
476 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
477 append tok
[strrep
$j]
479 if {$tok eq
$oldtok} {
482 set id
[lindex
$varccommits($v,$a) end
]
483 foreach p
$parents($v,$id) {
484 if {[info exists varcid
($v,$p)]} {
485 set kidchanged
($varcid($v,$p)) 1
490 lset varctok
($v) $a $tok
491 set b
[lindex
$vupptr($v) $a]
493 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
496 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
499 set c
[lindex
$vbackptr($v) $a]
500 set d
[lindex
$vleftptr($v) $a]
502 lset vdownptr
($v) $b $d
504 lset vleftptr
($v) $c $d
507 lset vbackptr
($v) $d $c
509 lset vupptr
($v) $a $ka
510 set c
[lindex
$vlastins($v) $ka]
512 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
514 set b
[lindex
$vdownptr($v) $ka]
516 set b
[lindex
$vleftptr($v) $c]
519 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
521 set b
[lindex
$vleftptr($v) $c]
524 lset vdownptr
($v) $ka $a
525 lset vbackptr
($v) $a 0
527 lset vleftptr
($v) $c $a
528 lset vbackptr
($v) $a $c
530 lset vleftptr
($v) $a $b
532 lset vbackptr
($v) $b $a
534 lset vlastins
($v) $ka $a
537 foreach id
[array names sortkids
] {
538 if {[llength
$children($v,$id)] > 1} {
539 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
543 set t2
[clock clicks
-milliseconds]
544 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
547 proc fix_reversal
{p a v
} {
548 global varcid varcstart varctok vupptr
550 set pa
$varcid($v,$p)
551 if {$p ne
[lindex
$varcstart($v) $pa]} {
553 set pa
$varcid($v,$p)
555 # seeds always need to be renumbered
556 if {[lindex
$vupptr($v) $pa] == 0 ||
557 [string compare
[lindex
$varctok($v) $a] \
558 [lindex
$varctok($v) $pa]] > 0} {
563 proc insertrow
{id p v
} {
564 global varcid varccommits parents children cmitlisted
565 global commitidx varctok vtokmod targetid targetrow
568 set i
[lsearch
-exact $varccommits($v,$a) $p]
570 puts
"oops: insertrow can't find [shortids $p] on arc $a"
573 set children
($v,$id) {}
574 set parents
($v,$id) [list
$p]
575 set varcid
($v,$id) $a
576 lappend children
($v,$p) $id
577 set cmitlisted
($v,$id) 1
579 # note we deliberately don't update varcstart($v) even if $i == 0
580 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
581 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
584 if {[info exists targetid
]} {
585 if {![comes_before
$targetid $p]} {
592 proc removerow
{id v
} {
593 global varcid varccommits parents children commitidx
594 global varctok vtokmod cmitlisted currentid selectedline
597 if {[llength
$parents($v,$id)] != 1} {
598 puts
"oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
601 set p
[lindex
$parents($v,$id) 0]
602 set a
$varcid($v,$id)
603 set i
[lsearch
-exact $varccommits($v,$a) $id]
605 puts
"oops: removerow can't find [shortids $id] on arc $a"
609 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
610 unset parents
($v,$id)
611 unset children
($v,$id)
612 unset cmitlisted
($v,$id)
613 incr commitidx
($v) -1
614 set j
[lsearch
-exact $children($v,$p) $id]
616 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
618 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
621 if {[info exist currentid
] && $id eq
$currentid} {
625 if {[info exists targetid
] && $targetid eq
$id} {
631 proc first_real_child
{vp
} {
632 global children nullid nullid2
634 foreach id
$children($vp) {
635 if {$id ne
$nullid && $id ne
$nullid2} {
642 proc last_real_child
{vp
} {
643 global children nullid nullid2
645 set kids
$children($vp)
646 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
647 set id
[lindex
$kids $i]
648 if {$id ne
$nullid && $id ne
$nullid2} {
655 proc vtokcmp
{v a b
} {
656 global varctok varcid
658 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
659 [lindex
$varctok($v) $varcid($v,$b)]]
662 proc modify_arc
{v a
{lim
{}}} {
663 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
665 set vtokmod
($v) [lindex
$varctok($v) $a]
667 if {$v == $curview} {
668 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
669 set a
[lindex
$vupptr($v) $a]
675 set lim
[llength
$varccommits($v,$a)]
677 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
684 proc update_arcrows
{v
} {
685 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
686 global varcid vrownum varcorder varcix varccommits
687 global vupptr vdownptr vleftptr varctok
688 global displayorder parentlist curview cached_commitrow
690 set narctot
[expr {[llength
$varctok($v)] - 1}]
692 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
693 # go up the tree until we find something that has a row number,
694 # or we get to a seed
695 set a
[lindex
$vupptr($v) $a]
698 set a
[lindex
$vdownptr($v) 0]
701 set varcorder
($v) [list
$a]
703 lset varcrow
($v) $a 0
707 set arcn
[lindex
$varcix($v) $a]
708 # see if a is the last arc; if so, nothing to do
709 if {$arcn == $narctot - 1} {
712 if {[llength
$vrownum($v)] > $arcn + 1} {
713 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
714 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
716 set row
[lindex
$varcrow($v) $a]
718 if {$v == $curview} {
719 if {[llength
$displayorder] > $vrowmod($v)} {
720 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
721 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
723 catch
{unset cached_commitrow
}
727 incr row
[llength
$varccommits($v,$a)]
728 # go down if possible
729 set b
[lindex
$vdownptr($v) $a]
731 # if not, go left, or go up until we can go left
733 set b
[lindex
$vleftptr($v) $a]
735 set a
[lindex
$vupptr($v) $a]
741 lappend vrownum
($v) $row
742 lappend varcorder
($v) $a
743 lset varcix
($v) $a $arcn
744 lset varcrow
($v) $a $row
746 set vtokmod
($v) [lindex
$varctok($v) $p]
749 if {[info exists currentid
]} {
750 set selectedline
[rowofcommit
$currentid]
754 # Test whether view $v contains commit $id
755 proc commitinview
{id v
} {
758 return [info exists varcid
($v,$id)]
761 # Return the row number for commit $id in the current view
762 proc rowofcommit
{id
} {
763 global varcid varccommits varcrow curview cached_commitrow
764 global varctok vtokmod
767 if {![info exists varcid
($v,$id)]} {
768 puts
"oops rowofcommit no arc for [shortids $id]"
771 set a
$varcid($v,$id)
772 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
775 if {[info exists cached_commitrow
($id)]} {
776 return $cached_commitrow($id)
778 set i
[lsearch
-exact $varccommits($v,$a) $id]
780 puts
"oops didn't find commit [shortids $id] in arc $a"
783 incr i
[lindex
$varcrow($v) $a]
784 set cached_commitrow
($id) $i
788 # Returns 1 if a is on an earlier row than b, otherwise 0
789 proc comes_before
{a b
} {
790 global varcid varctok curview
793 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
794 ![info exists varcid
($v,$b)]} {
797 if {$varcid($v,$a) != $varcid($v,$b)} {
798 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
799 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
801 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
804 proc bsearch
{l elt
} {
805 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
810 while {$hi - $lo > 1} {
811 set mid
[expr {int
(($lo + $hi) / 2)}]
812 set t
[lindex
$l $mid]
815 } elseif
{$elt > $t} {
824 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
825 proc make_disporder
{start end
} {
826 global vrownum curview commitidx displayorder parentlist
827 global varccommits varcorder parents vrowmod varcrow
828 global d_valid_start d_valid_end
830 if {$end > $vrowmod($curview)} {
831 update_arcrows
$curview
833 set ai
[bsearch
$vrownum($curview) $start]
834 set start
[lindex
$vrownum($curview) $ai]
835 set narc
[llength
$vrownum($curview)]
836 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
837 set a
[lindex
$varcorder($curview) $ai]
838 set l
[llength
$displayorder]
839 set al
[llength
$varccommits($curview,$a)]
842 set pad
[ntimes
[expr {$r - $l}] {}]
843 set displayorder
[concat
$displayorder $pad]
844 set parentlist
[concat
$parentlist $pad]
846 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
847 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
849 foreach id
$varccommits($curview,$a) {
850 lappend displayorder
$id
851 lappend parentlist
$parents($curview,$id)
853 } elseif
{[lindex
$displayorder $r] eq
{}} {
855 foreach id
$varccommits($curview,$a) {
856 lset displayorder
$i $id
857 lset parentlist
$i $parents($curview,$id)
865 proc commitonrow
{row
} {
868 set id
[lindex
$displayorder $row]
870 make_disporder
$row [expr {$row + 1}]
871 set id
[lindex
$displayorder $row]
876 proc closevarcs
{v
} {
877 global varctok varccommits varcid parents children
878 global cmitlisted commitidx commitinterest vtokmod
880 set missing_parents
0
882 set narcs
[llength
$varctok($v)]
883 for {set a
1} {$a < $narcs} {incr a
} {
884 set id
[lindex
$varccommits($v,$a) end
]
885 foreach p
$parents($v,$id) {
886 if {[info exists varcid
($v,$p)]} continue
887 # add p as a new commit
889 set cmitlisted
($v,$p) 0
890 set parents
($v,$p) {}
891 if {[llength
$children($v,$p)] == 1 &&
892 [llength
$parents($v,$id)] == 1} {
895 set b
[newvarc
$v $p]
898 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
901 lappend varccommits
($v,$b) $p
903 if {[info exists commitinterest
($p)]} {
904 foreach
script $commitinterest($p) {
905 lappend scripts
[string map
[list
"%I" $p] $script]
907 unset commitinterest
($id)
911 if {$missing_parents > 0} {
918 proc getcommitlines
{fd inst view
} {
919 global cmitlisted commitinterest leftover
920 global commitidx commitdata datemode
921 global parents children curview hlview
922 global vnextroot idpending ordertok
923 global varccommits varcid varctok vtokmod
925 set stuff
[read $fd 500000]
926 # git log doesn't terminate the last commit with a null...
927 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
934 global commfd viewcomplete viewactive viewname progresscoords
937 set i
[lsearch
-exact $viewinstances($view) $inst]
939 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
941 # set it blocking so we wait for the process to terminate
942 fconfigure
$fd -blocking 1
943 if {[catch
{close
$fd} err
]} {
945 if {$view != $curview} {
946 set fv
" for the \"$viewname($view)\" view"
948 if {[string range
$err 0 4] == "usage"} {
949 set err
"Gitk: error reading commits$fv:\
950 bad arguments to git rev-list."
951 if {$viewname($view) eq
"Command line"} {
953 " (Note: arguments to gitk are passed to git rev-list\
954 to allow selection of commits to be displayed.)"
957 set err
"Error reading commits$fv: $err"
961 if {[incr viewactive
($view) -1] <= 0} {
962 set viewcomplete
($view) 1
963 # Check if we have seen any ids listed as parents that haven't
964 # appeared in the list
967 set progresscoords
{0 0}
970 if {$view == $curview} {
971 run chewcommits
$view
979 set i
[string first
"\0" $stuff $start]
981 append leftover
($inst) [string range
$stuff $start end
]
985 set cmit
$leftover($inst)
986 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
987 set leftover
($inst) {}
989 set cmit
[string range
$stuff $start [expr {$i - 1}]]
991 set start
[expr {$i + 1}]
992 set j
[string first
"\n" $cmit]
995 if {$j >= 0 && [string match
"commit *" $cmit]} {
996 set ids
[string range
$cmit 7 [expr {$j - 1}]]
997 if {[string match
{[-<>]*} $ids]} {
998 switch
-- [string index
$ids 0] {
1003 set ids
[string range
$ids 1 end
]
1007 if {[string length
$id] != 40} {
1015 if {[string length
$shortcmit] > 80} {
1016 set shortcmit
"[string range $shortcmit 0 80]..."
1018 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1021 set id [lindex $ids 0]
1023 if {!$listed && [info exists parents($vid)]} continue
1025 set olds [lrange $ids 1 end]
1029 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1030 set cmitlisted($vid) $listed
1031 set parents($vid) $olds
1033 if {![info exists children($vid)]} {
1034 set children($vid) {}
1035 } elseif {[llength $children($vid)] == 1} {
1036 set k [lindex $children($vid) 0]
1037 if {[llength $parents($view,$k)] == 1 &&
1039 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1040 set a $varcid($view,$k)
1045 set a [newvarc $view $id]
1048 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1051 lappend varccommits($view,$a) $id
1055 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1057 if {[llength [lappend children($vp) $id]] > 1 &&
1058 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1059 set children($vp) [lsort -command [list vtokcmp $view] \
1061 catch {unset ordertok}
1063 if {[info exists varcid($view,$p)]} {
1064 fix_reversal $p $a $view
1070 incr commitidx($view)
1071 if {[info exists commitinterest($id)]} {
1072 foreach script $commitinterest($id) {
1073 lappend scripts [string map [list "%I" $id] $script]
1075 unset commitinterest($id)
1080 run chewcommits $view
1081 foreach s $scripts {
1084 if {$view == $curview} {
1085 # update progress bar
1086 global progressdirn progresscoords proglastnc
1087 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1088 set proglastnc $commitidx($view)
1089 set l [lindex $progresscoords 0]
1090 set r [lindex $progresscoords 1]
1091 if {$progressdirn} {
1092 set r [expr {$r + $inc}]
1098 set l [expr {$r - 0.2}]
1101 set l [expr {$l - $inc}]
1106 set r [expr {$l + 0.2}]
1108 set progresscoords [list $l $r]
1115 proc chewcommits {view} {
1116 global curview hlview viewcomplete
1117 global pending_select
1119 if {$view == $curview} {
1121 if {$viewcomplete($view)} {
1122 global commitidx varctok
1123 global numcommits startmsecs
1124 global mainheadid commitinfo nullid
1126 if {[info exists pending_select]} {
1127 set row [first_real_row]
1130 if {$commitidx($curview) > 0} {
1131 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1132 #puts "overall $ms ms for $numcommits commits"
1133 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1135 show_status [mc "No commits selected"]
1140 if {[info exists hlview] && $view == $hlview} {
1146 proc readcommit {id} {
1147 if {[catch {set contents [exec git cat-file commit $id]}]} return
1148 parsecommit $id $contents 0
1151 proc parsecommit {id contents listed} {
1152 global commitinfo cdate
1161 set hdrend [string first "\n\n" $contents]
1163 # should never happen...
1164 set hdrend [string length $contents]
1166 set header [string range $contents 0 [expr {$hdrend - 1}]]
1167 set comment [string range $contents [expr {$hdrend + 2}] end]
1168 foreach line [split $header "\n"] {
1169 set tag [lindex $line 0]
1170 if {$tag == "author"} {
1171 set audate [lindex $line end-1]
1172 set auname [lrange $line 1 end-2]
1173 } elseif {$tag == "committer"} {
1174 set comdate [lindex $line end-1]
1175 set comname [lrange $line 1 end-2]
1179 # take the first non-blank line of the comment as the headline
1180 set headline [string trimleft $comment]
1181 set i [string first "\n" $headline]
1183 set headline [string range $headline 0 $i]
1185 set headline [string trimright $headline]
1186 set i [string first "\r" $headline]
1188 set headline [string trimright [string range $headline 0 $i]]
1191 # git rev-list indents the comment by 4 spaces;
1192 # if we got this via git cat-file, add the indentation
1194 foreach line [split $comment "\n"] {
1195 append newcomment " "
1196 append newcomment $line
1197 append newcomment "\n"
1199 set comment $newcomment
1201 if {$comdate != {}} {
1202 set cdate($id) $comdate
1204 set commitinfo($id) [list $headline $auname $audate \
1205 $comname $comdate $comment]
1208 proc getcommit {id} {
1209 global commitdata commitinfo
1211 if {[info exists commitdata($id)]} {
1212 parsecommit $id $commitdata($id) 1
1215 if {![info exists commitinfo($id)]} {
1216 set commitinfo($id) [list [mc "No commit information available"]]
1223 global tagids idtags headids idheads tagobjid
1224 global otherrefids idotherrefs mainhead mainheadid
1226 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1229 set refd [open [list | git show-ref -d] r]
1230 while {[gets $refd line] >= 0} {
1231 if {[string index $line 40] ne " "} continue
1232 set id [string range $line 0 39]
1233 set ref [string range $line 41 end]
1234 if {![string match "refs/*" $ref]} continue
1235 set name [string range $ref 5 end]
1236 if {[string match "remotes/*" $name]} {
1237 if {![string match "*/HEAD" $name]} {
1238 set headids($name) $id
1239 lappend idheads($id) $name
1241 } elseif {[string match "heads/*" $name]} {
1242 set name [string range $name 6 end]
1243 set headids($name) $id
1244 lappend idheads($id) $name
1245 } elseif {[string match "tags/*" $name]} {
1246 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1247 # which is what we want since the former is the commit ID
1248 set name [string range $name 5 end]
1249 if {[string match "*^{}" $name]} {
1250 set name [string range $name 0 end-3]
1252 set tagobjid($name) $id
1254 set tagids($name) $id
1255 lappend idtags($id) $name
1257 set otherrefids($name) $id
1258 lappend idotherrefs($id) $name
1265 set thehead [exec git symbolic-ref HEAD]
1266 if {[string match "refs/heads/*" $thehead]} {
1267 set mainhead [string range $thehead 11 end]
1268 if {[info exists headids($mainhead)]} {
1269 set mainheadid $headids($mainhead)
1275 # skip over fake commits
1276 proc first_real_row {} {
1277 global nullid nullid2 numcommits
1279 for {set row 0} {$row < $numcommits} {incr row} {
1280 set id [commitonrow $row]
1281 if {$id ne $nullid && $id ne $nullid2} {
1288 # update things for a head moved to a child of its previous location
1289 proc movehead {id name} {
1290 global headids idheads
1292 removehead $headids($name) $name
1293 set headids($name) $id
1294 lappend idheads($id) $name
1297 # update things when a head has been removed
1298 proc removehead {id name} {
1299 global headids idheads
1301 if {$idheads($id) eq $name} {
1304 set i [lsearch -exact $idheads($id) $name]
1306 set idheads($id) [lreplace $idheads($id) $i $i]
1309 unset headids($name)
1312 proc show_error {w top msg} {
1313 message $w.m -text $msg -justify center -aspect 400
1314 pack $w.m -side top -fill x -padx 20 -pady 20
1315 button $w.ok -text [mc OK] -command "destroy $top"
1316 pack $w.ok -side bottom -fill x
1317 bind $top <Visibility> "grab $top; focus $top"
1318 bind $top <Key-Return> "destroy $top"
1322 proc error_popup msg {
1326 show_error $w $w $msg
1329 proc confirm_popup msg {
1335 message $w.m -text $msg -justify center -aspect 400
1336 pack $w.m -side top -fill x -padx 20 -pady 20
1337 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1338 pack $w.ok -side left -fill x
1339 button $w.cancel -text [mc Cancel] -command "destroy $w"
1340 pack $w.cancel -side right -fill x
1341 bind $w <Visibility> "grab $w; focus $w"
1346 proc setoptions {} {
1347 option add *Panedwindow.showHandle 1 startupFile
1348 option add *Panedwindow.sashRelief raised startupFile
1349 option add *Button.font uifont startupFile
1350 option add *Checkbutton.font uifont startupFile
1351 option add *Radiobutton.font uifont startupFile
1352 option add *Menu.font uifont startupFile
1353 option add *Menubutton.font uifont startupFile
1354 option add *Label.font uifont startupFile
1355 option add *Message.font uifont startupFile
1356 option add *Entry.font uifont startupFile
1359 proc makewindow {} {
1360 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1362 global findtype findtypemenu findloc findstring fstring geometry
1363 global entries sha1entry sha1string sha1but
1364 global diffcontextstring diffcontext
1365 global maincursor textcursor curtextcursor
1366 global rowctxmenu fakerowmenu mergemax wrapcomment
1367 global highlight_files gdttype
1368 global searchstring sstring
1369 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1370 global headctxmenu progresscanv progressitem progresscoords statusw
1371 global fprogitem fprogcoord lastprogupdate progupdatepending
1372 global rprogitem rprogcoord
1376 .bar add cascade -label [mc "File"] -menu .bar.file
1378 .bar.file add command -label [mc "Update"] -command updatecommits
1379 .bar.file add command -label [mc "Reload"] -command reloadcommits
1380 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1381 .bar.file add command -label [mc "List references"] -command showrefs
1382 .bar.file add command -label [mc "Quit"] -command doquit
1384 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1385 .bar.edit add command -label [mc "Preferences"] -command doprefs
1388 .bar add cascade -label [mc "View"] -menu .bar.view
1389 .bar.view add command -label [mc "New view..."] -command {newview 0}
1390 .bar.view add command -label [mc "Edit view..."] -command editview \
1392 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1393 .bar.view add separator
1394 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1395 -variable selectedview -value 0
1398 .bar add cascade -label [mc "Help"] -menu .bar.help
1399 .bar.help add command -label [mc "About gitk"] -command about
1400 .bar.help add command -label [mc "Key bindings"] -command keys
1402 . configure -menu .bar
1404 # the gui has upper and lower half, parts of a paned window.
1405 panedwindow .ctop -orient vertical
1407 # possibly use assumed geometry
1408 if {![info exists geometry(pwsash0)]} {
1409 set geometry(topheight) [expr {15 * $linespc}]
1410 set geometry(topwidth) [expr {80 * $charspc}]
1411 set geometry(botheight) [expr {15 * $linespc}]
1412 set geometry(botwidth) [expr {50 * $charspc}]
1413 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1414 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1417 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1418 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1420 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1422 # create three canvases
1423 set cscroll .tf.histframe.csb
1424 set canv .tf.histframe.pwclist.canv
1426 -selectbackground $selectbgcolor \
1427 -background $bgcolor -bd 0 \
1428 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1429 .tf.histframe.pwclist add $canv
1430 set canv2 .tf.histframe.pwclist.canv2
1432 -selectbackground $selectbgcolor \
1433 -background $bgcolor -bd 0 -yscrollincr $linespc
1434 .tf.histframe.pwclist add $canv2
1435 set canv3 .tf.histframe.pwclist.canv3
1437 -selectbackground $selectbgcolor \
1438 -background $bgcolor -bd 0 -yscrollincr $linespc
1439 .tf.histframe.pwclist add $canv3
1440 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1441 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1443 # a scroll bar to rule them
1444 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1445 pack $cscroll -side right -fill y
1446 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1447 lappend bglist $canv $canv2 $canv3
1448 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1450 # we have two button bars at bottom of top frame. Bar 1
1452 frame .tf.lbar -height 15
1454 set sha1entry .tf.bar.sha1
1455 set entries $sha1entry
1456 set sha1but .tf.bar.sha1label
1457 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1458 -command gotocommit -width 8
1459 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1460 pack .tf.bar.sha1label -side left
1461 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1462 trace add variable sha1string write sha1change
1463 pack $sha1entry -side left -pady 2
1465 image create bitmap bm-left -data {
1466 #define left_width 16
1467 #define left_height 16
1468 static unsigned char left_bits[] = {
1469 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1470 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1471 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1473 image create bitmap bm-right -data {
1474 #define right_width 16
1475 #define right_height 16
1476 static unsigned char right_bits[] = {
1477 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1478 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1479 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1481 button .tf.bar.leftbut -image bm-left -command goback \
1482 -state disabled -width 26
1483 pack .tf.bar.leftbut -side left -fill y
1484 button .tf.bar.rightbut -image bm-right -command goforw \
1485 -state disabled -width 26
1486 pack .tf.bar.rightbut -side left -fill y
1488 # Status label and progress bar
1489 set statusw .tf.bar.status
1490 label $statusw -width 15 -relief sunken
1491 pack $statusw -side left -padx 5
1492 set h [expr {[font metrics uifont -linespace] + 2}]
1493 set progresscanv .tf.bar.progress
1494 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1495 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1496 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1497 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1498 pack $progresscanv -side right -expand 1 -fill x
1499 set progresscoords {0 0}
1502 bind $progresscanv <Configure> adjustprogress
1503 set lastprogupdate [clock clicks -milliseconds]
1504 set progupdatepending 0
1506 # build up the bottom bar of upper window
1507 label .tf.lbar.flabel -text "[mc "Find"] "
1508 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1509 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1510 label .tf.lbar.flab2 -text " [mc "commit"] "
1511 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1513 set gdttype [mc "containing:"]
1514 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1515 [mc "containing:"] \
1516 [mc "touching paths:"] \
1517 [mc "adding/removing string:"]]
1518 trace add variable gdttype write gdttype_change
1519 pack .tf.lbar.gdttype -side left -fill y
1522 set fstring .tf.lbar.findstring
1523 lappend entries $fstring
1524 entry $fstring -width 30 -font textfont -textvariable findstring
1525 trace add variable findstring write find_change
1526 set findtype [mc "Exact"]
1527 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1528 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1529 trace add variable findtype write findcom_change
1530 set findloc [mc "All fields"]
1531 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1532 [mc "Comments"] [mc "Author"] [mc "Committer"]
1533 trace add variable findloc write find_change
1534 pack .tf.lbar.findloc -side right
1535 pack .tf.lbar.findtype -side right
1536 pack $fstring -side left -expand 1 -fill x
1538 # Finish putting the upper half of the viewer together
1539 pack .tf.lbar -in .tf -side bottom -fill x
1540 pack .tf.bar -in .tf -side bottom -fill x
1541 pack .tf.histframe -fill both -side top -expand 1
1543 .ctop paneconfigure .tf -height $geometry(topheight)
1544 .ctop paneconfigure .tf -width $geometry(topwidth)
1546 # now build up the bottom
1547 panedwindow .pwbottom -orient horizontal
1549 # lower left, a text box over search bar, scroll bar to the right
1550 # if we know window height, then that will set the lower text height, otherwise
1551 # we set lower text height which will drive window height
1552 if {[info exists geometry(main)]} {
1553 frame .bleft -width $geometry(botwidth)
1555 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1560 button .bleft.top.search -text [mc "Search"] -command dosearch
1561 pack .bleft.top.search -side left -padx 5
1562 set sstring .bleft.top.sstring
1563 entry $sstring -width 20 -font textfont -textvariable searchstring
1564 lappend entries $sstring
1565 trace add variable searchstring write incrsearch
1566 pack $sstring -side left -expand 1 -fill x
1567 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1568 -command changediffdisp -variable diffelide -value {0 0}
1569 radiobutton .bleft.mid.old -text [mc "Old version"] \
1570 -command changediffdisp -variable diffelide -value {0 1}
1571 radiobutton .bleft.mid.new -text [mc "New version"] \
1572 -command changediffdisp -variable diffelide -value {1 0}
1573 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1574 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1575 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1576 -from 1 -increment 1 -to 10000000 \
1577 -validate all -validatecommand "diffcontextvalidate %P" \
1578 -textvariable diffcontextstring
1579 .bleft.mid.diffcontext set $diffcontext
1580 trace add variable diffcontextstring write diffcontextchange
1581 lappend entries .bleft.mid.diffcontext
1582 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1583 set ctext .bleft.ctext
1584 text $ctext -background $bgcolor -foreground $fgcolor \
1585 -state disabled -font textfont \
1586 -yscrollcommand scrolltext -wrap none
1588 $ctext conf -tabstyle wordprocessor
1590 scrollbar .bleft.sb -command "$ctext yview"
1591 pack .bleft.top -side top -fill x
1592 pack .bleft.mid -side top -fill x
1593 pack .bleft.sb -side right -fill y
1594 pack $ctext -side left -fill both -expand 1
1595 lappend bglist $ctext
1596 lappend fglist $ctext
1598 $ctext tag conf comment -wrap $wrapcomment
1599 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1600 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1601 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1602 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1603 $ctext tag conf m0 -fore red
1604 $ctext tag conf m1 -fore blue
1605 $ctext tag conf m2 -fore green
1606 $ctext tag conf m3 -fore purple
1607 $ctext tag conf m4 -fore brown
1608 $ctext tag conf m5 -fore "#009090"
1609 $ctext tag conf m6 -fore magenta
1610 $ctext tag conf m7 -fore "#808000"
1611 $ctext tag conf m8 -fore "#009000"
1612 $ctext tag conf m9 -fore "#ff0080"
1613 $ctext tag conf m10 -fore cyan
1614 $ctext tag conf m11 -fore "#b07070"
1615 $ctext tag conf m12 -fore "#70b0f0"
1616 $ctext tag conf m13 -fore "#70f0b0"
1617 $ctext tag conf m14 -fore "#f0b070"
1618 $ctext tag conf m15 -fore "#ff70b0"
1619 $ctext tag conf mmax -fore darkgrey
1621 $ctext tag conf mresult -font textfontbold
1622 $ctext tag conf msep -font textfontbold
1623 $ctext tag conf found -back yellow
1625 .pwbottom add .bleft
1626 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1631 radiobutton .bright.mode.patch -text [mc "Patch"] \
1632 -command reselectline -variable cmitmode -value "patch"
1633 radiobutton .bright.mode.tree -text [mc "Tree"] \
1634 -command reselectline -variable cmitmode -value "tree"
1635 grid .bright.mode.patch .bright.mode.tree -sticky ew
1636 pack .bright.mode -side top -fill x
1637 set cflist .bright.cfiles
1638 set indent [font measure mainfont "nn"]
1640 -selectbackground $selectbgcolor \
1641 -background $bgcolor -foreground $fgcolor \
1643 -tabs [list $indent [expr {2 * $indent}]] \
1644 -yscrollcommand ".bright.sb set" \
1645 -cursor [. cget -cursor] \
1646 -spacing1 1 -spacing3 1
1647 lappend bglist $cflist
1648 lappend fglist $cflist
1649 scrollbar .bright.sb -command "$cflist yview"
1650 pack .bright.sb -side right -fill y
1651 pack $cflist -side left -fill both -expand 1
1652 $cflist tag configure highlight \
1653 -background [$cflist cget -selectbackground]
1654 $cflist tag configure bold -font mainfontbold
1656 .pwbottom add .bright
1659 # restore window position if known
1660 if {[info exists geometry(main)]} {
1661 wm geometry . "$geometry(main)"
1664 if {[tk windowingsystem] eq {aqua}} {
1670 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1671 pack .ctop -fill both -expand 1
1672 bindall <1> {selcanvline %W %x %y}
1673 #bindall <B1-Motion> {selcanvline %W %x %y}
1674 if {[tk windowingsystem] == "win32"} {
1675 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1676 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1678 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1679 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1680 if {[tk windowingsystem] eq "aqua"} {
1681 bindall <MouseWheel> {
1682 set delta [expr {- (%D)}]
1683 allcanvs yview scroll $delta units
1687 bindall <2> "canvscan mark %W %x %y"
1688 bindall <B2-Motion> "canvscan dragto %W %x %y"
1689 bindkey <Home> selfirstline
1690 bindkey <End> sellastline
1691 bind . <Key-Up> "selnextline -1"
1692 bind . <Key-Down> "selnextline 1"
1693 bind . <Shift-Key-Up> "dofind -1 0"
1694 bind . <Shift-Key-Down> "dofind 1 0"
1695 bindkey <Key-Right> "goforw"
1696 bindkey <Key-Left> "goback"
1697 bind . <Key-Prior> "selnextpage -1"
1698 bind . <Key-Next> "selnextpage 1"
1699 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1700 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1701 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1702 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1703 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1704 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1705 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1706 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1707 bindkey <Key-space> "$ctext yview scroll 1 pages"
1708 bindkey p "selnextline -1"
1709 bindkey n "selnextline 1"
1712 bindkey i "selnextline -1"
1713 bindkey k "selnextline 1"
1716 bindkey b "$ctext yview scroll -1 pages"
1717 bindkey d "$ctext yview scroll 18 units"
1718 bindkey u "$ctext yview scroll -18 units"
1719 bindkey / {dofind 1 1}
1720 bindkey <Key-Return> {dofind 1 1}
1721 bindkey ? {dofind -1 1}
1723 bindkey <F5> updatecommits
1724 bind . <$M1B-q> doquit
1725 bind . <$M1B-f> {dofind 1 1}
1726 bind . <$M1B-g> {dofind 1 0}
1727 bind . <$M1B-r> dosearchback
1728 bind . <$M1B-s> dosearch
1729 bind . <$M1B-equal> {incrfont 1}
1730 bind . <$M1B-KP_Add> {incrfont 1}
1731 bind . <$M1B-minus> {incrfont -1}
1732 bind . <$M1B-KP_Subtract> {incrfont -1}
1733 wm protocol . WM_DELETE_WINDOW doquit
1734 bind . <Button-1> "click %W"
1735 bind $fstring <Key-Return> {dofind 1 1}
1736 bind $sha1entry <Key-Return> gotocommit
1737 bind $sha1entry <<PasteSelection>> clearsha1
1738 bind $cflist <1> {sel_flist %W %x %y; break}
1739 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1740 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1741 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1743 set maincursor [. cget -cursor]
1744 set textcursor [$ctext cget -cursor]
1745 set curtextcursor $textcursor
1747 set rowctxmenu .rowctxmenu
1748 menu $rowctxmenu -tearoff 0
1749 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1750 -command {diffvssel 0}
1751 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1752 -command {diffvssel 1}
1753 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1754 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1755 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1756 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1757 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1759 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1762 set fakerowmenu .fakerowmenu
1763 menu $fakerowmenu -tearoff 0
1764 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1765 -command {diffvssel 0}
1766 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1767 -command {diffvssel 1}
1768 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1769 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1770 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1771 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1773 set headctxmenu .headctxmenu
1774 menu $headctxmenu -tearoff 0
1775 $headctxmenu add command -label [mc "Check out this branch"] \
1777 $headctxmenu add command -label [mc "Remove this branch"] \
1781 set flist_menu .flistctxmenu
1782 menu $flist_menu -tearoff 0
1783 $flist_menu add command -label [mc "Highlight this too"] \
1784 -command {flist_hl 0}
1785 $flist_menu add command -label [mc "Highlight this only"] \
1786 -command {flist_hl 1}
1789 # Windows sends all mouse wheel events to the current focused window, not
1790 # the one where the mouse hovers, so bind those events here and redirect
1791 # to the correct window
1792 proc windows_mousewheel_redirector {W X Y D} {
1793 global canv canv2 canv3
1794 set w [winfo containing -displayof $W $X $Y]
1796 set u [expr {$D < 0 ? 5 : -5}]
1797 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1798 allcanvs yview scroll $u units
1801 $w yview scroll $u units
1807 # mouse-2 makes all windows scan vertically, but only the one
1808 # the cursor is in scans horizontally
1809 proc canvscan {op w x y} {
1810 global canv canv2 canv3
1811 foreach c [list $canv $canv2 $canv3] {
1820 proc scrollcanv {cscroll f0 f1} {
1821 $cscroll set $f0 $f1
1826 # when we make a key binding for the toplevel, make sure
1827 # it doesn't get triggered when that key is pressed
in the
1828 # find string entry widget.
1829 proc bindkey
{ev
script} {
1832 set escript
[bind Entry
$ev]
1833 if {$escript == {}} {
1834 set escript
[bind Entry
<Key
>]
1836 foreach e
$entries {
1837 bind $e $ev "$escript; break"
1841 # set the focus back to the toplevel for any click outside
1844 global ctext entries
1845 foreach e
[concat
$entries $ctext] {
1846 if {$w == $e} return
1851 # Adjust the progress bar for a change in requested extent or canvas size
1852 proc adjustprogress
{} {
1853 global progresscanv progressitem progresscoords
1854 global fprogitem fprogcoord lastprogupdate progupdatepending
1855 global rprogitem rprogcoord
1857 set w
[expr {[winfo width
$progresscanv] - 4}]
1858 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1859 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1860 set h
[winfo height
$progresscanv]
1861 $progresscanv coords
$progressitem $x0 0 $x1 $h
1862 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1863 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1864 set now
[clock clicks
-milliseconds]
1865 if {$now >= $lastprogupdate + 100} {
1866 set progupdatepending
0
1868 } elseif
{!$progupdatepending} {
1869 set progupdatepending
1
1870 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1874 proc doprogupdate
{} {
1875 global lastprogupdate progupdatepending
1877 if {$progupdatepending} {
1878 set progupdatepending
0
1879 set lastprogupdate
[clock clicks
-milliseconds]
1884 proc savestuff
{w
} {
1885 global canv canv2 canv3 mainfont textfont uifont tabstop
1886 global stuffsaved findmergefiles maxgraphpct
1887 global maxwidth showneartags showlocalchanges
1888 global viewname viewfiles viewargs viewperm nextviewnum
1889 global cmitmode wrapcomment datetimeformat limitdiffs
1890 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1892 if {$stuffsaved} return
1893 if {![winfo viewable .
]} return
1895 set f
[open
"~/.gitk-new" w
]
1896 puts
$f [list
set mainfont
$mainfont]
1897 puts
$f [list
set textfont
$textfont]
1898 puts
$f [list
set uifont
$uifont]
1899 puts
$f [list
set tabstop
$tabstop]
1900 puts
$f [list
set findmergefiles
$findmergefiles]
1901 puts
$f [list
set maxgraphpct
$maxgraphpct]
1902 puts
$f [list
set maxwidth
$maxwidth]
1903 puts
$f [list
set cmitmode
$cmitmode]
1904 puts
$f [list
set wrapcomment
$wrapcomment]
1905 puts
$f [list
set showneartags
$showneartags]
1906 puts
$f [list
set showlocalchanges
$showlocalchanges]
1907 puts
$f [list
set datetimeformat
$datetimeformat]
1908 puts
$f [list
set limitdiffs
$limitdiffs]
1909 puts
$f [list
set bgcolor
$bgcolor]
1910 puts
$f [list
set fgcolor
$fgcolor]
1911 puts
$f [list
set colors
$colors]
1912 puts
$f [list
set diffcolors
$diffcolors]
1913 puts
$f [list
set diffcontext
$diffcontext]
1914 puts
$f [list
set selectbgcolor
$selectbgcolor]
1916 puts
$f "set geometry(main) [wm geometry .]"
1917 puts
$f "set geometry(topwidth) [winfo width .tf]"
1918 puts
$f "set geometry(topheight) [winfo height .tf]"
1919 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1920 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1921 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1922 puts
$f "set geometry(botheight) [winfo height .bleft]"
1924 puts
-nonewline $f "set permviews {"
1925 for {set v
0} {$v < $nextviewnum} {incr v
} {
1926 if {$viewperm($v)} {
1927 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1932 file rename
-force "~/.gitk-new" "~/.gitk"
1937 proc resizeclistpanes
{win w
} {
1939 if {[info exists oldwidth
($win)]} {
1940 set s0
[$win sash coord
0]
1941 set s1
[$win sash coord
1]
1943 set sash0
[expr {int
($w/2 - 2)}]
1944 set sash1
[expr {int
($w*5/6 - 2)}]
1946 set factor [expr {1.0 * $w / $oldwidth($win)}]
1947 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1948 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1952 if {$sash1 < $sash0 + 20} {
1953 set sash1
[expr {$sash0 + 20}]
1955 if {$sash1 > $w - 10} {
1956 set sash1
[expr {$w - 10}]
1957 if {$sash0 > $sash1 - 20} {
1958 set sash0
[expr {$sash1 - 20}]
1962 $win sash place
0 $sash0 [lindex
$s0 1]
1963 $win sash place
1 $sash1 [lindex
$s1 1]
1965 set oldwidth
($win) $w
1968 proc resizecdetpanes
{win w
} {
1970 if {[info exists oldwidth
($win)]} {
1971 set s0
[$win sash coord
0]
1973 set sash0
[expr {int
($w*3/4 - 2)}]
1975 set factor [expr {1.0 * $w / $oldwidth($win)}]
1976 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1980 if {$sash0 > $w - 15} {
1981 set sash0
[expr {$w - 15}]
1984 $win sash place
0 $sash0 [lindex
$s0 1]
1986 set oldwidth
($win) $w
1989 proc allcanvs args
{
1990 global canv canv2 canv3
1996 proc bindall
{event action
} {
1997 global canv canv2 canv3
1998 bind $canv $event $action
1999 bind $canv2 $event $action
2000 bind $canv3 $event $action
2006 if {[winfo exists
$w]} {
2011 wm title
$w [mc
"About gitk"]
2012 message
$w.m
-text [mc
"
2013 Gitk - a commit viewer for git
2015 Copyright © 2005-2006 Paul Mackerras
2017 Use and redistribute under the terms of the GNU General Public License"] \
2018 -justify center
-aspect 400 -border 2 -bg white
-relief groove
2019 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
2020 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2021 pack
$w.ok
-side bottom
2022 bind $w <Visibility
> "focus $w.ok"
2023 bind $w <Key-Escape
> "destroy $w"
2024 bind $w <Key-Return
> "destroy $w"
2029 if {[winfo exists
$w]} {
2033 if {[tk windowingsystem
] eq
{aqua
}} {
2039 wm title
$w [mc
"Gitk key bindings"]
2040 message
$w.m
-text [mc
"
2044 <Home> Move to first commit
2045 <End> Move to last commit
2046 <Up>, p, i Move up one commit
2047 <Down>, n, k Move down one commit
2048 <Left>, z, j Go back in history list
2049 <Right>, x, l Go forward in history list
2050 <PageUp> Move up one page in commit list
2051 <PageDown> Move down one page in commit list
2052 <$M1T-Home> Scroll to top of commit list
2053 <$M1T-End> Scroll to bottom of commit list
2054 <$M1T-Up> Scroll commit list up one line
2055 <$M1T-Down> Scroll commit list down one line
2056 <$M1T-PageUp> Scroll commit list up one page
2057 <$M1T-PageDown> Scroll commit list down one page
2058 <Shift-Up> Find backwards (upwards, later commits)
2059 <Shift-Down> Find forwards (downwards, earlier commits)
2060 <Delete>, b Scroll diff view up one page
2061 <Backspace> Scroll diff view up one page
2062 <Space> Scroll diff view down one page
2063 u Scroll diff view up 18 lines
2064 d Scroll diff view down 18 lines
2066 <$M1T-G> Move to next find hit
2067 <Return> Move to next find hit
2068 / Move to next find hit, or redo find
2069 ? Move to previous find hit
2070 f Scroll diff view to next file
2071 <$M1T-S> Search for next hit in diff view
2072 <$M1T-R> Search for previous hit in diff view
2073 <$M1T-KP+> Increase font size
2074 <$M1T-plus> Increase font size
2075 <$M1T-KP-> Decrease font size
2076 <$M1T-minus> Decrease font size
2079 -justify left
-bg white
-border 2 -relief groove
2080 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
2081 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2082 pack
$w.ok
-side bottom
2083 bind $w <Visibility
> "focus $w.ok"
2084 bind $w <Key-Escape
> "destroy $w"
2085 bind $w <Key-Return
> "destroy $w"
2088 # Procedures for manipulating the file list window at the
2089 # bottom right of the overall window.
2091 proc treeview
{w l openlevs
} {
2092 global treecontents treediropen treeheight treeparent treeindex
2102 set treecontents
() {}
2103 $w conf
-state normal
2105 while {[string range
$f 0 $prefixend] ne
$prefix} {
2106 if {$lev <= $openlevs} {
2107 $w mark
set e
:$treeindex($prefix) "end -1c"
2108 $w mark gravity e
:$treeindex($prefix) left
2110 set treeheight
($prefix) $ht
2111 incr ht
[lindex
$htstack end
]
2112 set htstack
[lreplace
$htstack end end
]
2113 set prefixend
[lindex
$prefendstack end
]
2114 set prefendstack
[lreplace
$prefendstack end end
]
2115 set prefix
[string range
$prefix 0 $prefixend]
2118 set tail [string range
$f [expr {$prefixend+1}] end
]
2119 while {[set slash
[string first
"/" $tail]] >= 0} {
2122 lappend prefendstack
$prefixend
2123 incr prefixend
[expr {$slash + 1}]
2124 set d
[string range
$tail 0 $slash]
2125 lappend treecontents
($prefix) $d
2126 set oldprefix
$prefix
2128 set treecontents
($prefix) {}
2129 set treeindex
($prefix) [incr ix
]
2130 set treeparent
($prefix) $oldprefix
2131 set tail [string range
$tail [expr {$slash+1}] end
]
2132 if {$lev <= $openlevs} {
2134 set treediropen
($prefix) [expr {$lev < $openlevs}]
2135 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
2136 $w mark
set d
:$ix "end -1c"
2137 $w mark gravity d
:$ix left
2139 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2141 $w image create end
-align center
-image $bm -padx 1 \
2143 $w insert end
$d [highlight_tag
$prefix]
2144 $w mark
set s
:$ix "end -1c"
2145 $w mark gravity s
:$ix left
2150 if {$lev <= $openlevs} {
2153 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2155 $w insert end
$tail [highlight_tag
$f]
2157 lappend treecontents
($prefix) $tail
2160 while {$htstack ne
{}} {
2161 set treeheight
($prefix) $ht
2162 incr ht
[lindex
$htstack end
]
2163 set htstack
[lreplace
$htstack end end
]
2164 set prefixend
[lindex
$prefendstack end
]
2165 set prefendstack
[lreplace
$prefendstack end end
]
2166 set prefix
[string range
$prefix 0 $prefixend]
2168 $w conf
-state disabled
2171 proc linetoelt
{l
} {
2172 global treeheight treecontents
2177 foreach e
$treecontents($prefix) {
2182 if {[string index
$e end
] eq
"/"} {
2183 set n
$treeheight($prefix$e)
2195 proc highlight_tree
{y prefix
} {
2196 global treeheight treecontents cflist
2198 foreach e
$treecontents($prefix) {
2200 if {[highlight_tag
$path] ne
{}} {
2201 $cflist tag add bold
$y.0 "$y.0 lineend"
2204 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
2205 set y
[highlight_tree
$y $path]
2211 proc treeclosedir
{w dir
} {
2212 global treediropen treeheight treeparent treeindex
2214 set ix
$treeindex($dir)
2215 $w conf
-state normal
2216 $w delete s
:$ix e
:$ix
2217 set treediropen
($dir) 0
2218 $w image configure a
:$ix -image tri-rt
2219 $w conf
-state disabled
2220 set n
[expr {1 - $treeheight($dir)}]
2221 while {$dir ne
{}} {
2222 incr treeheight
($dir) $n
2223 set dir
$treeparent($dir)
2227 proc treeopendir
{w dir
} {
2228 global treediropen treeheight treeparent treecontents treeindex
2230 set ix
$treeindex($dir)
2231 $w conf
-state normal
2232 $w image configure a
:$ix -image tri-dn
2233 $w mark
set e
:$ix s
:$ix
2234 $w mark gravity e
:$ix right
2237 set n
[llength
$treecontents($dir)]
2238 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
2241 incr treeheight
($x) $n
2243 foreach e
$treecontents($dir) {
2245 if {[string index
$e end
] eq
"/"} {
2246 set iy
$treeindex($de)
2247 $w mark
set d
:$iy e
:$ix
2248 $w mark gravity d
:$iy left
2249 $w insert e
:$ix $str
2250 set treediropen
($de) 0
2251 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
2253 $w insert e
:$ix $e [highlight_tag
$de]
2254 $w mark
set s
:$iy e
:$ix
2255 $w mark gravity s
:$iy left
2256 set treeheight
($de) 1
2258 $w insert e
:$ix $str
2259 $w insert e
:$ix $e [highlight_tag
$de]
2262 $w mark gravity e
:$ix left
2263 $w conf
-state disabled
2264 set treediropen
($dir) 1
2265 set top
[lindex
[split [$w index @
0,0] .
] 0]
2266 set ht
[$w cget
-height]
2267 set l
[lindex
[split [$w index s
:$ix] .
] 0]
2270 } elseif
{$l + $n + 1 > $top + $ht} {
2271 set top
[expr {$l + $n + 2 - $ht}]
2279 proc treeclick
{w x y
} {
2280 global treediropen cmitmode ctext cflist cflist_top
2282 if {$cmitmode ne
"tree"} return
2283 if {![info exists cflist_top
]} return
2284 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2285 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2286 $cflist tag add highlight
$l.0 "$l.0 lineend"
2292 set e
[linetoelt
$l]
2293 if {[string index
$e end
] ne
"/"} {
2295 } elseif
{$treediropen($e)} {
2302 proc setfilelist
{id
} {
2303 global treefilelist cflist
2305 treeview
$cflist $treefilelist($id) 0
2308 image create bitmap tri-rt
-background black
-foreground blue
-data {
2309 #define tri-rt_width 13
2310 #define tri-rt_height 13
2311 static unsigned char tri-rt_bits
[] = {
2312 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2313 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2316 #define tri-rt-mask_width 13
2317 #define tri-rt-mask_height 13
2318 static unsigned char tri-rt-mask_bits
[] = {
2319 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2320 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2323 image create bitmap tri-dn
-background black
-foreground blue
-data {
2324 #define tri-dn_width 13
2325 #define tri-dn_height 13
2326 static unsigned char tri-dn_bits
[] = {
2327 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2328 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2331 #define tri-dn-mask_width 13
2332 #define tri-dn-mask_height 13
2333 static unsigned char tri-dn-mask_bits
[] = {
2334 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2335 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2339 image create bitmap reficon-T
-background black
-foreground yellow
-data {
2340 #define tagicon_width 13
2341 #define tagicon_height 9
2342 static unsigned char tagicon_bits
[] = {
2343 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2344 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2346 #define tagicon-mask_width 13
2347 #define tagicon-mask_height 9
2348 static unsigned char tagicon-mask_bits
[] = {
2349 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2350 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2353 #define headicon_width 13
2354 #define headicon_height 9
2355 static unsigned char headicon_bits
[] = {
2356 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2357 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2360 #define headicon-mask_width 13
2361 #define headicon-mask_height 9
2362 static unsigned char headicon-mask_bits
[] = {
2363 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2364 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2366 image create bitmap reficon-H
-background black
-foreground green \
2367 -data $rectdata -maskdata $rectmask
2368 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
2369 -data $rectdata -maskdata $rectmask
2371 proc init_flist
{first
} {
2372 global cflist cflist_top difffilestart
2374 $cflist conf
-state normal
2375 $cflist delete
0.0 end
2377 $cflist insert end
$first
2379 $cflist tag add highlight
1.0 "1.0 lineend"
2381 catch
{unset cflist_top
}
2383 $cflist conf
-state disabled
2384 set difffilestart
{}
2387 proc highlight_tag
{f
} {
2388 global highlight_paths
2390 foreach p
$highlight_paths {
2391 if {[string match
$p $f]} {
2398 proc highlight_filelist
{} {
2399 global cmitmode cflist
2401 $cflist conf
-state normal
2402 if {$cmitmode ne
"tree"} {
2403 set end
[lindex
[split [$cflist index end
] .
] 0]
2404 for {set l
2} {$l < $end} {incr l
} {
2405 set line
[$cflist get
$l.0 "$l.0 lineend"]
2406 if {[highlight_tag
$line] ne
{}} {
2407 $cflist tag add bold
$l.0 "$l.0 lineend"
2413 $cflist conf
-state disabled
2416 proc unhighlight_filelist
{} {
2419 $cflist conf
-state normal
2420 $cflist tag remove bold
1.0 end
2421 $cflist conf
-state disabled
2424 proc add_flist
{fl
} {
2427 $cflist conf
-state normal
2429 $cflist insert end
"\n"
2430 $cflist insert end
$f [highlight_tag
$f]
2432 $cflist conf
-state disabled
2435 proc sel_flist
{w x y
} {
2436 global ctext difffilestart cflist cflist_top cmitmode
2438 if {$cmitmode eq
"tree"} return
2439 if {![info exists cflist_top
]} return
2440 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2441 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2442 $cflist tag add highlight
$l.0 "$l.0 lineend"
2447 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
2451 proc pop_flist_menu
{w X Y x y
} {
2452 global ctext cflist cmitmode flist_menu flist_menu_file
2453 global treediffs diffids
2456 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2458 if {$cmitmode eq
"tree"} {
2459 set e
[linetoelt
$l]
2460 if {[string index
$e end
] eq
"/"} return
2462 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
2464 set flist_menu_file
$e
2465 tk_popup
$flist_menu $X $Y
2468 proc flist_hl
{only
} {
2469 global flist_menu_file findstring gdttype
2471 set x
[shellquote
$flist_menu_file]
2472 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
2475 append findstring
" " $x
2477 set gdttype
[mc
"touching paths:"]
2480 # Functions for adding and removing shell-type quoting
2482 proc shellquote
{str
} {
2483 if {![string match
"*\['\"\\ \t]*" $str]} {
2486 if {![string match
"*\['\"\\]*" $str]} {
2489 if {![string match
"*'*" $str]} {
2492 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2495 proc shellarglist
{l
} {
2501 append str
[shellquote
$a]
2506 proc shelldequote
{str
} {
2511 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
2512 append ret
[string range
$str $used end
]
2513 set used
[string length
$str]
2516 set first
[lindex
$first 0]
2517 set ch
[string index
$str $first]
2518 if {$first > $used} {
2519 append ret
[string range
$str $used [expr {$first - 1}]]
2522 if {$ch eq
" " ||
$ch eq
"\t"} break
2525 set first
[string first
"'" $str $used]
2527 error
"unmatched single-quote"
2529 append ret
[string range
$str $used [expr {$first - 1}]]
2534 if {$used >= [string length
$str]} {
2535 error
"trailing backslash"
2537 append ret
[string index
$str $used]
2542 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
2543 error
"unmatched double-quote"
2545 set first
[lindex
$first 0]
2546 set ch
[string index
$str $first]
2547 if {$first > $used} {
2548 append ret
[string range
$str $used [expr {$first - 1}]]
2551 if {$ch eq
"\""} break
2553 append ret
[string index
$str $used]
2557 return [list
$used $ret]
2560 proc shellsplit
{str
} {
2563 set str
[string trimleft
$str]
2564 if {$str eq
{}} break
2565 set dq
[shelldequote
$str]
2566 set n
[lindex
$dq 0]
2567 set word
[lindex
$dq 1]
2568 set str
[string range
$str $n end
]
2574 # Code to implement multiple views
2576 proc newview
{ishighlight
} {
2577 global nextviewnum newviewname newviewperm newishighlight
2578 global newviewargs revtreeargs
2580 set newishighlight
$ishighlight
2582 if {[winfo exists
$top]} {
2586 set newviewname
($nextviewnum) "View $nextviewnum"
2587 set newviewperm
($nextviewnum) 0
2588 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
2589 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
2594 global viewname viewperm newviewname newviewperm
2595 global viewargs newviewargs
2597 set top .gitkvedit-
$curview
2598 if {[winfo exists
$top]} {
2602 set newviewname
($curview) $viewname($curview)
2603 set newviewperm
($curview) $viewperm($curview)
2604 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
2605 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
2608 proc vieweditor
{top n title
} {
2609 global newviewname newviewperm viewfiles bgcolor
2612 wm title
$top $title
2613 label
$top.
nl -text [mc
"Name"]
2614 entry
$top.name
-width 20 -textvariable newviewname
($n)
2615 grid
$top.
nl $top.name
-sticky w
-pady 5
2616 checkbutton
$top.perm
-text [mc
"Remember this view"] \
2617 -variable newviewperm
($n)
2618 grid
$top.perm
- -pady 5 -sticky w
2619 message
$top.al
-aspect 1000 \
2620 -text [mc
"Commits to include (arguments to git rev-list):"]
2621 grid
$top.al
- -sticky w
-pady 5
2622 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
2623 -background $bgcolor
2624 grid
$top.args
- -sticky ew
-padx 5
2625 message
$top.l
-aspect 1000 \
2626 -text [mc
"Enter files and directories to include, one per line:"]
2627 grid
$top.l
- -sticky w
2628 text
$top.t
-width 40 -height 10 -background $bgcolor -font uifont
2629 if {[info exists viewfiles
($n)]} {
2630 foreach f
$viewfiles($n) {
2631 $top.t insert end
$f
2632 $top.t insert end
"\n"
2634 $top.t delete
{end
- 1c
} end
2635 $top.t mark
set insert
0.0
2637 grid
$top.t
- -sticky ew
-padx 5
2639 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n]
2640 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top]
2641 grid
$top.buts.ok
$top.buts.can
2642 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
2643 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
2644 grid
$top.buts
- -pady 10 -sticky ew
2648 proc doviewmenu
{m first cmd op argv
} {
2649 set nmenu
[$m index end
]
2650 for {set i
$first} {$i <= $nmenu} {incr i
} {
2651 if {[$m entrycget
$i -command] eq
$cmd} {
2652 eval $m $op $i $argv
2658 proc allviewmenus
{n op args
} {
2661 doviewmenu .bar.view
5 [list showview
$n] $op $args
2662 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2665 proc newviewok
{top n
} {
2666 global nextviewnum newviewperm newviewname newishighlight
2667 global viewname viewfiles viewperm selectedview curview
2668 global viewargs newviewargs viewhlmenu
2671 set newargs
[shellsplit
$newviewargs($n)]
2673 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
2679 foreach f
[split [$top.t get
0.0 end
] "\n"] {
2680 set ft
[string trim
$f]
2685 if {![info exists viewfiles
($n)]} {
2686 # creating a new view
2688 set viewname
($n) $newviewname($n)
2689 set viewperm
($n) $newviewperm($n)
2690 set viewfiles
($n) $files
2691 set viewargs
($n) $newargs
2693 if {!$newishighlight} {
2696 run addvhighlight
$n
2699 # editing an existing view
2700 set viewperm
($n) $newviewperm($n)
2701 if {$newviewname($n) ne
$viewname($n)} {
2702 set viewname
($n) $newviewname($n)
2703 doviewmenu .bar.view
5 [list showview
$n] \
2704 entryconf
[list
-label $viewname($n)]
2705 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2706 # entryconf [list -label $viewname($n) -value $viewname($n)]
2708 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n)} {
2709 set viewfiles
($n) $files
2710 set viewargs
($n) $newargs
2711 if {$curview == $n} {
2716 catch
{destroy
$top}
2720 global curview viewperm hlview selectedhlview
2722 if {$curview == 0} return
2723 if {[info exists hlview
] && $hlview == $curview} {
2724 set selectedhlview
[mc
"None"]
2727 allviewmenus
$curview delete
2728 set viewperm
($curview) 0
2732 proc addviewmenu
{n
} {
2733 global viewname viewhlmenu
2735 .bar.view add radiobutton
-label $viewname($n) \
2736 -command [list showview
$n] -variable selectedview
-value $n
2737 #$viewhlmenu add radiobutton -label $viewname($n) \
2738 # -command [list addvhighlight $n] -variable selectedhlview
2742 global curview viewfiles cached_commitrow ordertok
2743 global displayorder parentlist rowidlist rowisopt rowfinal
2744 global colormap rowtextx nextcolor canvxmax
2745 global numcommits viewcomplete
2746 global selectedline currentid canv canvy0
2748 global pending_select
2750 global selectedview selectfirst
2751 global hlview selectedhlview commitinterest
2753 if {$n == $curview} return
2755 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2756 set span
[$canv yview
]
2757 set ytop
[expr {[lindex
$span 0] * $ymax}]
2758 set ybot
[expr {[lindex
$span 1] * $ymax}]
2759 set yscreen
[expr {($ybot - $ytop) / 2}]
2760 if {[info exists selectedline
]} {
2761 set selid
$currentid
2762 set y
[yc
$selectedline]
2763 if {$ytop < $y && $y < $ybot} {
2764 set yscreen
[expr {$y - $ytop}]
2766 } elseif
{[info exists pending_select
]} {
2767 set selid
$pending_select
2768 unset pending_select
2772 catch
{unset treediffs
}
2774 if {[info exists hlview
] && $hlview == $n} {
2776 set selectedhlview
[mc
"None"]
2778 catch
{unset commitinterest
}
2779 catch
{unset cached_commitrow
}
2780 catch
{unset ordertok
}
2784 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2785 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2788 if {![info exists viewcomplete
($n)]} {
2790 set pending_select
$selid
2801 set numcommits
$commitidx($n)
2803 catch
{unset colormap
}
2804 catch
{unset rowtextx
}
2806 set canvxmax
[$canv cget
-width]
2813 if {$selid ne
{} && [commitinview
$selid $n]} {
2814 set row
[rowofcommit
$selid]
2815 # try to get the selected row in the same position on the screen
2816 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2817 set ytop
[expr {[yc
$row] - $yscreen}]
2821 set yf
[expr {$ytop * 1.0 / $ymax}]
2823 allcanvs yview moveto
$yf
2827 } elseif
{$selid ne
{}} {
2828 set pending_select
$selid
2830 set row
[first_real_row
]
2831 if {$row < $numcommits} {
2837 if {!$viewcomplete($n)} {
2838 if {$numcommits == 0} {
2839 show_status
[mc
"Reading commits..."]
2841 } elseif
{$numcommits == 0} {
2842 show_status
[mc
"No commits selected"]
2846 # Stuff relating to the highlighting facility
2848 proc ishighlighted
{id
} {
2849 global vhighlights fhighlights nhighlights rhighlights
2851 if {[info exists nhighlights
($id)] && $nhighlights($id) > 0} {
2852 return $nhighlights($id)
2854 if {[info exists vhighlights
($id)] && $vhighlights($id) > 0} {
2855 return $vhighlights($id)
2857 if {[info exists fhighlights
($id)] && $fhighlights($id) > 0} {
2858 return $fhighlights($id)
2860 if {[info exists rhighlights
($id)] && $rhighlights($id) > 0} {
2861 return $rhighlights($id)
2866 proc bolden
{row font
} {
2867 global canv linehtag selectedline boldrows
2869 lappend boldrows
$row
2870 $canv itemconf
$linehtag($row) -font $font
2871 if {[info exists selectedline
] && $row == $selectedline} {
2873 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2874 -outline {{}} -tags secsel \
2875 -fill [$canv cget
-selectbackground]]
2880 proc bolden_name
{row font
} {
2881 global canv2 linentag selectedline boldnamerows
2883 lappend boldnamerows
$row
2884 $canv2 itemconf
$linentag($row) -font $font
2885 if {[info exists selectedline
] && $row == $selectedline} {
2886 $canv2 delete secsel
2887 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2888 -outline {{}} -tags secsel \
2889 -fill [$canv2 cget
-selectbackground]]
2898 foreach row
$boldrows {
2899 if {![ishighlighted
[commitonrow
$row]]} {
2900 bolden
$row mainfont
2902 lappend stillbold
$row
2905 set boldrows
$stillbold
2908 proc addvhighlight
{n
} {
2909 global hlview viewcomplete curview vhl_done commitidx
2911 if {[info exists hlview
]} {
2915 if {$n != $curview && ![info exists viewcomplete
($n)]} {
2918 set vhl_done
$commitidx($hlview)
2919 if {$vhl_done > 0} {
2924 proc delvhighlight
{} {
2925 global hlview vhighlights
2927 if {![info exists hlview
]} return
2929 catch
{unset vhighlights
}
2933 proc vhighlightmore
{} {
2934 global hlview vhl_done commitidx vhighlights curview
2936 set max
$commitidx($hlview)
2937 set vr
[visiblerows
]
2938 set r0
[lindex
$vr 0]
2939 set r1
[lindex
$vr 1]
2940 for {set i
$vhl_done} {$i < $max} {incr i
} {
2941 set id
[commitonrow
$i $hlview]
2942 if {[commitinview
$id $curview]} {
2943 set row
[rowofcommit
$id]
2944 if {$r0 <= $row && $row <= $r1} {
2945 if {![highlighted
$row]} {
2946 bolden
$row mainfontbold
2948 set vhighlights
($id) 1
2955 proc askvhighlight
{row id
} {
2956 global hlview vhighlights iddrawn
2958 if {[commitinview
$id $hlview]} {
2959 if {[info exists iddrawn
($id)] && ![ishighlighted
$id]} {
2960 bolden
$row mainfontbold
2962 set vhighlights
($id) 1
2964 set vhighlights
($id) 0
2968 proc hfiles_change
{} {
2969 global highlight_files filehighlight fhighlights fh_serial
2970 global highlight_paths gdttype
2972 if {[info exists filehighlight
]} {
2973 # delete previous highlights
2974 catch
{close
$filehighlight}
2976 catch
{unset fhighlights
}
2978 unhighlight_filelist
2980 set highlight_paths
{}
2981 after cancel do_file_hl
$fh_serial
2983 if {$highlight_files ne
{}} {
2984 after
300 do_file_hl
$fh_serial
2988 proc gdttype_change
{name ix op
} {
2989 global gdttype highlight_files findstring findpattern
2992 if {$findstring ne
{}} {
2993 if {$gdttype eq
[mc
"containing:"]} {
2994 if {$highlight_files ne
{}} {
2995 set highlight_files
{}
3000 if {$findpattern ne
{}} {
3004 set highlight_files
$findstring
3009 # enable/disable findtype/findloc menus too
3012 proc find_change
{name ix op
} {
3013 global gdttype findstring highlight_files
3016 if {$gdttype eq
[mc
"containing:"]} {
3019 if {$highlight_files ne
$findstring} {
3020 set highlight_files
$findstring
3027 proc findcom_change args
{
3028 global nhighlights boldnamerows
3029 global findpattern findtype findstring gdttype
3032 # delete previous highlights, if any
3033 foreach row
$boldnamerows {
3034 bolden_name
$row mainfont
3037 catch
{unset nhighlights
}
3040 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
3042 } elseif
{$findtype eq
[mc
"Regexp"]} {
3043 set findpattern
$findstring
3045 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3047 set findpattern
"*$e*"
3051 proc makepatterns
{l
} {
3054 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3055 if {[string index
$ee end
] eq
"/"} {
3065 proc do_file_hl
{serial
} {
3066 global highlight_files filehighlight highlight_paths gdttype fhl_list
3068 if {$gdttype eq
[mc
"touching paths:"]} {
3069 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
3070 set highlight_paths
[makepatterns
$paths]
3072 set gdtargs
[concat
-- $paths]
3073 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
3074 set gdtargs
[list
"-S$highlight_files"]
3076 # must be "containing:", i.e. we're searching commit info
3079 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
3080 set filehighlight
[open
$cmd r
+]
3081 fconfigure
$filehighlight -blocking 0
3082 filerun
$filehighlight readfhighlight
3088 proc flushhighlights
{} {
3089 global filehighlight fhl_list
3091 if {[info exists filehighlight
]} {
3093 puts
$filehighlight ""
3094 flush
$filehighlight
3098 proc askfilehighlight
{row id
} {
3099 global filehighlight fhighlights fhl_list
3101 lappend fhl_list
$id
3102 set fhighlights
($id) -1
3103 puts
$filehighlight $id
3106 proc readfhighlight
{} {
3107 global filehighlight fhighlights curview iddrawn
3108 global fhl_list find_dirn
3110 if {![info exists filehighlight
]} {
3114 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
3115 set line
[string trim
$line]
3116 set i
[lsearch
-exact $fhl_list $line]
3117 if {$i < 0} continue
3118 for {set j
0} {$j < $i} {incr j
} {
3119 set id
[lindex
$fhl_list $j]
3120 set fhighlights
($id) 0
3122 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
3123 if {$line eq
{}} continue
3124 if {![commitinview
$line $curview]} continue
3125 set row
[rowofcommit
$line]
3126 if {[info exists iddrawn
($line)] && ![ishighlighted
$line]} {
3127 bolden
$row mainfontbold
3129 set fhighlights
($line) 1
3131 if {[eof
$filehighlight]} {
3133 puts
"oops, git diff-tree died"
3134 catch
{close
$filehighlight}
3138 if {[info exists find_dirn
]} {
3144 proc doesmatch
{f
} {
3145 global findtype findpattern
3147 if {$findtype eq
[mc
"Regexp"]} {
3148 return [regexp
$findpattern $f]
3149 } elseif
{$findtype eq
[mc
"IgnCase"]} {
3150 return [string match
-nocase $findpattern $f]
3152 return [string match
$findpattern $f]
3156 proc askfindhighlight
{row id
} {
3157 global nhighlights commitinfo iddrawn
3159 global markingmatches
3161 if {![info exists commitinfo
($id)]} {
3164 set info
$commitinfo($id)
3166 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
3167 foreach f
$info ty
$fldtypes {
3168 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
3170 if {$ty eq
[mc
"Author"]} {
3177 if {$isbold && [info exists iddrawn
($id)]} {
3178 if {![ishighlighted
$id]} {
3179 bolden
$row mainfontbold
3181 bolden_name
$row mainfontbold
3184 if {$markingmatches} {
3185 markrowmatches
$row $id
3188 set nhighlights
($id) $isbold
3191 proc markrowmatches
{row id
} {
3192 global canv canv2 linehtag linentag commitinfo findloc
3194 set headline
[lindex
$commitinfo($id) 0]
3195 set author
[lindex
$commitinfo($id) 1]
3196 $canv delete match
$row
3197 $canv2 delete match
$row
3198 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
3199 set m
[findmatches
$headline]
3201 markmatches
$canv $row $headline $linehtag($row) $m \
3202 [$canv itemcget
$linehtag($row) -font] $row
3205 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
3206 set m
[findmatches
$author]
3208 markmatches
$canv2 $row $author $linentag($row) $m \
3209 [$canv2 itemcget
$linentag($row) -font] $row
3214 proc vrel_change
{name ix op
} {
3215 global highlight_related
3218 if {$highlight_related ne
[mc
"None"]} {
3223 # prepare for testing whether commits are descendents or ancestors of a
3224 proc rhighlight_sel
{a
} {
3225 global descendent desc_todo ancestor anc_todo
3226 global highlight_related
3228 catch
{unset descendent
}
3229 set desc_todo
[list
$a]
3230 catch
{unset ancestor
}
3231 set anc_todo
[list
$a]
3232 if {$highlight_related ne
[mc
"None"]} {
3238 proc rhighlight_none
{} {
3241 catch
{unset rhighlights
}
3245 proc is_descendent
{a
} {
3246 global curview children descendent desc_todo
3249 set la
[rowofcommit
$a]
3253 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3254 set do [lindex
$todo $i]
3255 if {[rowofcommit
$do] < $la} {
3256 lappend leftover
$do
3259 foreach nk
$children($v,$do) {
3260 if {![info exists descendent
($nk)]} {
3261 set descendent
($nk) 1
3269 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3273 set descendent
($a) 0
3274 set desc_todo
$leftover
3277 proc is_ancestor
{a
} {
3278 global curview parents ancestor anc_todo
3281 set la
[rowofcommit
$a]
3285 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3286 set do [lindex
$todo $i]
3287 if {![commitinview
$do $v] ||
[rowofcommit
$do] > $la} {
3288 lappend leftover
$do
3291 foreach np
$parents($v,$do) {
3292 if {![info exists ancestor
($np)]} {
3301 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3306 set anc_todo
$leftover
3309 proc askrelhighlight
{row id
} {
3310 global descendent highlight_related iddrawn rhighlights
3311 global selectedline ancestor
3313 if {![info exists selectedline
]} return
3315 if {$highlight_related eq
[mc
"Descendent"] ||
3316 $highlight_related eq
[mc
"Not descendent"]} {
3317 if {![info exists descendent
($id)]} {
3320 if {$descendent($id) == ($highlight_related eq
[mc
"Descendent"])} {
3323 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
3324 $highlight_related eq
[mc
"Not ancestor"]} {
3325 if {![info exists ancestor
($id)]} {
3328 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
3332 if {[info exists iddrawn
($id)]} {
3333 if {$isbold && ![ishighlighted
$id]} {
3334 bolden
$row mainfontbold
3337 set rhighlights
($id) $isbold
3340 # Graph layout functions
3342 proc shortids
{ids
} {
3345 if {[llength
$id] > 1} {
3346 lappend res
[shortids
$id]
3347 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
3348 lappend res
[string range
$id 0 7]
3359 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
3360 if {($n & $mask) != 0} {
3361 set ret
[concat
$ret $o]
3363 set o
[concat
$o $o]
3368 proc ordertoken
{id
} {
3369 global ordertok curview varcid varcstart varctok curview parents children
3370 global nullid nullid2
3372 if {[info exists ordertok
($id)]} {
3373 return $ordertok($id)
3378 if {[info exists varcid
($curview,$id)]} {
3379 set a
$varcid($curview,$id)
3380 set p
[lindex
$varcstart($curview) $a]
3382 set p
[lindex
$children($curview,$id) 0]
3384 if {[info exists ordertok
($p)]} {
3385 set tok
$ordertok($p)
3388 set id
[first_real_child
$curview,$p]
3391 set tok
[lindex
$varctok($curview) $a]
3394 if {[llength
$parents($curview,$id)] == 1} {
3395 lappend todo
[list
$p {}]
3397 set j
[lsearch
-exact $parents($curview,$id) $p]
3399 puts
"oops didn't find [shortids $p] in parents of [shortids $id]"
3401 lappend todo
[list
$p [strrep
$j]]
3404 for {set i
[llength
$todo]} {[incr i
-1] >= 0} {} {
3405 set p
[lindex
$todo $i 0]
3406 append tok
[lindex
$todo $i 1]
3407 set ordertok
($p) $tok
3409 set ordertok
($origid) $tok
3413 # Work out where id should go in idlist so that order-token
3414 # values increase from left to right
3415 proc idcol
{idlist id
{i
0}} {
3416 set t
[ordertoken
$id]
3420 if {$i >= [llength
$idlist] ||
$t < [ordertoken
[lindex
$idlist $i]]} {
3421 if {$i > [llength
$idlist]} {
3422 set i
[llength
$idlist]
3424 while {[incr i
-1] >= 0 && $t < [ordertoken
[lindex
$idlist $i]]} {}
3427 if {$t > [ordertoken
[lindex
$idlist $i]]} {
3428 while {[incr i
] < [llength
$idlist] &&
3429 $t >= [ordertoken
[lindex
$idlist $i]]} {}
3435 proc initlayout
{} {
3436 global rowidlist rowisopt rowfinal displayorder parentlist
3437 global numcommits canvxmax canv
3439 global colormap rowtextx
3449 set canvxmax
[$canv cget
-width]
3450 catch
{unset colormap
}
3451 catch
{unset rowtextx
}
3455 proc setcanvscroll
{} {
3456 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3458 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3459 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
3460 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
3461 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
3464 proc visiblerows
{} {
3465 global canv numcommits linespc
3467 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3468 if {$ymax eq
{} ||
$ymax == 0} return
3470 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
3471 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
3475 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
3476 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
3477 if {$r1 >= $numcommits} {
3478 set r1
[expr {$numcommits - 1}]
3480 return [list
$r0 $r1]
3483 proc layoutmore
{} {
3484 global commitidx viewcomplete curview
3485 global numcommits pending_select selectedline curview
3486 global selectfirst lastscrollset commitinterest
3488 set canshow
$commitidx($curview)
3489 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3490 if {$numcommits == 0} {
3494 set prev
$numcommits
3495 set numcommits
$canshow
3496 set t
[clock clicks
-milliseconds]
3497 if {$prev < 100 ||
$viewcomplete($curview) ||
$t - $lastscrollset > 500} {
3498 set lastscrollset
$t
3501 set rows
[visiblerows
]
3502 set r1
[lindex
$rows 1]
3503 if {$r1 >= $canshow} {
3504 set r1
[expr {$canshow - 1}]
3509 if {[info exists pending_select
] &&
3510 [commitinview
$pending_select $curview]} {
3511 selectline
[rowofcommit
$pending_select] 1
3514 if {[info exists selectedline
] ||
[info exists pending_select
]} {
3517 set l
[first_real_row
]
3524 proc doshowlocalchanges
{} {
3525 global curview mainheadid
3527 if {[commitinview
$mainheadid $curview]} {
3530 lappend commitinterest
($mainheadid) {dodiffindex
}
3534 proc dohidelocalchanges
{} {
3535 global nullid nullid2 lserial curview
3537 if {[commitinview
$nullid $curview]} {
3538 removerow
$nullid $curview
3540 if {[commitinview
$nullid2 $curview]} {
3541 removerow
$nullid2 $curview
3546 # spawn off a process to do git diff-index --cached HEAD
3547 proc dodiffindex
{} {
3548 global lserial showlocalchanges
3550 if {!$showlocalchanges} return
3552 set fd
[open
"|git diff-index --cached HEAD" r
]
3553 fconfigure
$fd -blocking 0
3554 filerun
$fd [list readdiffindex
$fd $lserial]
3557 proc readdiffindex
{fd serial
} {
3558 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3561 if {[gets
$fd line
] < 0} {
3567 # we only need to see one line and we don't really care what it says...
3570 if {$serial != $lserial} {
3574 # now see if there are any local changes not checked in to the index
3575 set fd
[open
"|git diff-files" r
]
3576 fconfigure
$fd -blocking 0
3577 filerun
$fd [list readdifffiles
$fd $serial]
3579 if {$isdiff && ![commitinview
$nullid2 $curview]} {
3580 # add the line for the changes in the index to the graph
3581 set hl
[mc
"Local changes checked in to index but not committed"]
3582 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
3583 set commitdata
($nullid2) "\n $hl\n"
3584 if {[commitinview
$nullid $curview]} {
3585 removerow
$nullid $curview
3587 insertrow
$nullid2 $mainheadid $curview
3588 } elseif
{!$isdiff && [commitinview
$nullid2 $curview]} {
3589 removerow
$nullid2 $curview
3594 proc readdifffiles
{fd serial
} {
3595 global mainheadid nullid nullid2 curview
3596 global commitinfo commitdata lserial
3599 if {[gets
$fd line
] < 0} {
3605 # we only need to see one line and we don't really care what it says...
3608 if {$serial != $lserial} {
3612 if {$isdiff && ![commitinview
$nullid $curview]} {
3613 # add the line for the local diff to the graph
3614 set hl
[mc
"Local uncommitted changes, not checked in to index"]
3615 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
3616 set commitdata
($nullid) "\n $hl\n"
3617 if {[commitinview
$nullid2 $curview]} {
3622 insertrow
$nullid $p $curview
3623 } elseif
{!$isdiff && [commitinview
$nullid $curview]} {
3624 removerow
$nullid $curview
3629 proc nextuse
{id row
} {
3630 global curview children
3632 if {[info exists children
($curview,$id)]} {
3633 foreach kid
$children($curview,$id) {
3634 if {![commitinview
$kid $curview]} {
3637 if {[rowofcommit
$kid] > $row} {
3638 return [rowofcommit
$kid]
3642 if {[commitinview
$id $curview]} {
3643 return [rowofcommit
$id]
3648 proc prevuse
{id row
} {
3649 global curview children
3652 if {[info exists children
($curview,$id)]} {
3653 foreach kid
$children($curview,$id) {
3654 if {![commitinview
$kid $curview]} break
3655 if {[rowofcommit
$kid] < $row} {
3656 set ret
[rowofcommit
$kid]
3663 proc make_idlist
{row
} {
3664 global displayorder parentlist uparrowlen downarrowlen mingaplen
3665 global commitidx curview children
3667 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
3671 set ra
[expr {$row - $downarrowlen}]
3675 set rb
[expr {$row + $uparrowlen}]
3676 if {$rb > $commitidx($curview)} {
3677 set rb
$commitidx($curview)
3679 make_disporder
$r [expr {$rb + 1}]
3681 for {} {$r < $ra} {incr r
} {
3682 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3683 foreach p
[lindex
$parentlist $r] {
3684 if {$p eq
$nextid} continue
3685 set rn
[nextuse
$p $r]
3687 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3688 lappend ids
[list
[ordertoken
$p] $p]
3692 for {} {$r < $row} {incr r
} {
3693 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3694 foreach p
[lindex
$parentlist $r] {
3695 if {$p eq
$nextid} continue
3696 set rn
[nextuse
$p $r]
3697 if {$rn < 0 ||
$rn >= $row} {
3698 lappend ids
[list
[ordertoken
$p] $p]
3702 set id
[lindex
$displayorder $row]
3703 lappend ids
[list
[ordertoken
$id] $id]
3705 foreach p
[lindex
$parentlist $r] {
3706 set firstkid
[lindex
$children($curview,$p) 0]
3707 if {[rowofcommit
$firstkid] < $row} {
3708 lappend ids
[list
[ordertoken
$p] $p]
3712 set id
[lindex
$displayorder $r]
3714 set firstkid
[lindex
$children($curview,$id) 0]
3715 if {$firstkid ne
{} && [rowofcommit
$firstkid] < $row} {
3716 lappend ids
[list
[ordertoken
$id] $id]
3721 foreach idx
[lsort
-unique $ids] {
3722 lappend idlist
[lindex
$idx 1]
3727 proc rowsequal
{a b
} {
3728 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3729 set a
[lreplace
$a $i $i]
3731 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3732 set b
[lreplace
$b $i $i]
3734 return [expr {$a eq
$b}]
3737 proc makeupline
{id row rend
col} {
3738 global rowidlist uparrowlen downarrowlen mingaplen
3740 for {set r
$rend} {1} {set r
$rstart} {
3741 set rstart
[prevuse
$id $r]
3742 if {$rstart < 0} return
3743 if {$rstart < $row} break
3745 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3746 set rstart
[expr {$rend - $uparrowlen - 1}]
3748 for {set r
$rstart} {[incr r
] <= $row} {} {
3749 set idlist
[lindex
$rowidlist $r]
3750 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3751 set col [idcol
$idlist $id $col]
3752 lset rowidlist
$r [linsert
$idlist $col $id]
3758 proc layoutrows
{row endrow
} {
3759 global rowidlist rowisopt rowfinal displayorder
3760 global uparrowlen downarrowlen maxwidth mingaplen
3761 global children parentlist
3762 global commitidx viewcomplete curview
3764 make_disporder
[expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3767 set rm1
[expr {$row - 1}]
3768 foreach id
[lindex
$rowidlist $rm1] {
3773 set final
[lindex
$rowfinal $rm1]
3775 for {} {$row < $endrow} {incr row
} {
3776 set rm1
[expr {$row - 1}]
3777 if {$rm1 < 0 ||
$idlist eq
{}} {
3778 set idlist
[make_idlist
$row]
3781 set id
[lindex
$displayorder $rm1]
3782 set col [lsearch
-exact $idlist $id]
3783 set idlist
[lreplace
$idlist $col $col]
3784 foreach p
[lindex
$parentlist $rm1] {
3785 if {[lsearch
-exact $idlist $p] < 0} {
3786 set col [idcol
$idlist $p $col]
3787 set idlist
[linsert
$idlist $col $p]
3788 # if not the first child, we have to insert a line going up
3789 if {$id ne
[lindex
$children($curview,$p) 0]} {
3790 makeupline
$p $rm1 $row $col
3794 set id
[lindex
$displayorder $row]
3795 if {$row > $downarrowlen} {
3796 set termrow
[expr {$row - $downarrowlen - 1}]
3797 foreach p
[lindex
$parentlist $termrow] {
3798 set i
[lsearch
-exact $idlist $p]
3799 if {$i < 0} continue
3800 set nr
[nextuse
$p $termrow]
3801 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3802 set idlist
[lreplace
$idlist $i $i]
3806 set col [lsearch
-exact $idlist $id]
3808 set col [idcol
$idlist $id]
3809 set idlist
[linsert
$idlist $col $id]
3810 if {$children($curview,$id) ne
{}} {
3811 makeupline
$id $rm1 $row $col
3814 set r
[expr {$row + $uparrowlen - 1}]
3815 if {$r < $commitidx($curview)} {
3817 foreach p
[lindex
$parentlist $r] {
3818 if {[lsearch
-exact $idlist $p] >= 0} continue
3819 set fk
[lindex
$children($curview,$p) 0]
3820 if {[rowofcommit
$fk] < $row} {
3821 set x
[idcol
$idlist $p $x]
3822 set idlist
[linsert
$idlist $x $p]
3825 if {[incr r
] < $commitidx($curview)} {
3826 set p
[lindex
$displayorder $r]
3827 if {[lsearch
-exact $idlist $p] < 0} {
3828 set fk
[lindex
$children($curview,$p) 0]
3829 if {$fk ne
{} && [rowofcommit
$fk] < $row} {
3830 set x
[idcol
$idlist $p $x]
3831 set idlist
[linsert
$idlist $x $p]
3837 if {$final && !$viewcomplete($curview) &&
3838 $row + $uparrowlen + $mingaplen + $downarrowlen
3839 >= $commitidx($curview)} {
3842 set l
[llength
$rowidlist]
3844 lappend rowidlist
$idlist
3846 lappend rowfinal
$final
3847 } elseif
{$row < $l} {
3848 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3849 lset rowidlist
$row $idlist
3852 lset rowfinal
$row $final
3854 set pad
[ntimes
[expr {$row - $l}] {}]
3855 set rowidlist
[concat
$rowidlist $pad]
3856 lappend rowidlist
$idlist
3857 set rowfinal
[concat
$rowfinal $pad]
3858 lappend rowfinal
$final
3859 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3865 proc changedrow
{row
} {
3866 global displayorder iddrawn rowisopt need_redisplay
3868 set l
[llength
$rowisopt]
3870 lset rowisopt
$row 0
3871 if {$row + 1 < $l} {
3872 lset rowisopt
[expr {$row + 1}] 0
3873 if {$row + 2 < $l} {
3874 lset rowisopt
[expr {$row + 2}] 0
3878 set id
[lindex
$displayorder $row]
3879 if {[info exists iddrawn
($id)]} {
3880 set need_redisplay
1
3884 proc insert_pad
{row
col npad
} {
3887 set pad
[ntimes
$npad {}]
3888 set idlist
[lindex
$rowidlist $row]
3889 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3890 set aft
[lrange
$idlist $col end
]
3891 set i
[lsearch
-exact $aft {}]
3893 set aft
[lreplace
$aft $i $i]
3895 lset rowidlist
$row [concat
$bef $pad $aft]
3899 proc optimize_rows
{row
col endrow
} {
3900 global rowidlist rowisopt displayorder curview children
3905 for {} {$row < $endrow} {incr row
; set col 0} {
3906 if {[lindex
$rowisopt $row]} continue
3908 set y0
[expr {$row - 1}]
3909 set ym
[expr {$row - 2}]
3910 set idlist
[lindex
$rowidlist $row]
3911 set previdlist
[lindex
$rowidlist $y0]
3912 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3914 set pprevidlist
[lindex
$rowidlist $ym]
3915 if {$pprevidlist eq
{}} continue
3921 for {} {$col < [llength
$idlist]} {incr
col} {
3922 set id
[lindex
$idlist $col]
3923 if {[lindex
$previdlist $col] eq
$id} continue
3928 set x0
[lsearch
-exact $previdlist $id]
3929 if {$x0 < 0} continue
3930 set z
[expr {$x0 - $col}]
3934 set xm
[lsearch
-exact $pprevidlist $id]
3936 set z0
[expr {$xm - $x0}]
3940 # if row y0 is the first child of $id then it's not an arrow
3941 if {[lindex
$children($curview,$id) 0] ne
3942 [lindex
$displayorder $y0]} {
3946 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3947 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3950 # Looking at lines from this row to the previous row,
3951 # make them go straight up if they end in an arrow on
3952 # the previous row; otherwise make them go straight up
3954 if {$z < -1 ||
($z < 0 && $isarrow)} {
3955 # Line currently goes left too much;
3956 # insert pads in the previous row, then optimize it
3957 set npad
[expr {-1 - $z + $isarrow}]
3958 insert_pad
$y0 $x0 $npad
3960 optimize_rows
$y0 $x0 $row
3962 set previdlist
[lindex
$rowidlist $y0]
3963 set x0
[lsearch
-exact $previdlist $id]
3964 set z
[expr {$x0 - $col}]
3966 set pprevidlist
[lindex
$rowidlist $ym]
3967 set xm
[lsearch
-exact $pprevidlist $id]
3968 set z0
[expr {$xm - $x0}]
3970 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3971 # Line currently goes right too much;
3972 # insert pads in this line
3973 set npad
[expr {$z - 1 + $isarrow}]
3974 insert_pad
$row $col $npad
3975 set idlist
[lindex
$rowidlist $row]
3977 set z
[expr {$x0 - $col}]
3980 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3981 # this line links to its first child on row $row-2
3982 set id
[lindex
$displayorder $ym]
3983 set xc
[lsearch
-exact $pprevidlist $id]
3985 set z0
[expr {$xc - $x0}]
3988 # avoid lines jigging left then immediately right
3989 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3990 insert_pad
$y0 $x0 1
3992 optimize_rows
$y0 $x0 $row
3993 set previdlist
[lindex
$rowidlist $y0]
3997 # Find the first column that doesn't have a line going right
3998 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
3999 set id
[lindex
$idlist $col]
4000 if {$id eq
{}} break
4001 set x0
[lsearch
-exact $previdlist $id]
4003 # check if this is the link to the first child
4004 set kid
[lindex
$displayorder $y0]
4005 if {[lindex
$children($curview,$id) 0] eq
$kid} {
4006 # it is, work out offset to child
4007 set x0
[lsearch
-exact $previdlist $kid]
4010 if {$x0 <= $col} break
4012 # Insert a pad at that column as long as it has a line and
4013 # isn't the last column
4014 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
4015 set idlist
[linsert
$idlist $col {}]
4016 lset rowidlist
$row $idlist
4024 global canvx0 linespc
4025 return [expr {$canvx0 + $col * $linespc}]
4029 global canvy0 linespc
4030 return [expr {$canvy0 + $row * $linespc}]
4033 proc linewidth
{id
} {
4034 global thickerline lthickness
4037 if {[info exists thickerline
] && $id eq
$thickerline} {
4038 set wid
[expr {2 * $lthickness}]
4043 proc rowranges
{id
} {
4044 global curview children uparrowlen downarrowlen
4047 set kids
$children($curview,$id)
4053 foreach child
$kids {
4054 if {![commitinview
$child $curview]} break
4055 set row
[rowofcommit
$child]
4056 if {![info exists prev
]} {
4057 lappend ret
[expr {$row + 1}]
4059 if {$row <= $prevrow} {
4060 puts
"oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4062 # see if the line extends the whole way from prevrow to row
4063 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4064 [lsearch
-exact [lindex
$rowidlist \
4065 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
4066 # it doesn't, see where it ends
4067 set r
[expr {$prevrow + $downarrowlen}]
4068 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4069 while {[incr r
-1] > $prevrow &&
4070 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4072 while {[incr r
] <= $row &&
4073 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4077 # see where it starts up again
4078 set r
[expr {$row - $uparrowlen}]
4079 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4080 while {[incr r
] < $row &&
4081 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4083 while {[incr r
-1] >= $prevrow &&
4084 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4090 if {$child eq
$id} {
4099 proc drawlineseg
{id row endrow arrowlow
} {
4100 global rowidlist displayorder iddrawn linesegs
4101 global canv colormap linespc curview maxlinelen parentlist
4103 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
4104 set le
[expr {$row + 1}]
4107 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
4113 set x
[lindex
$displayorder $le]
4118 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
4119 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
4135 if {[info exists linesegs
($id)]} {
4136 set lines
$linesegs($id)
4138 set r0
[lindex
$li 0]
4140 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
4150 set li
[lindex
$lines [expr {$i-1}]]
4151 set r1
[lindex
$li 1]
4152 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
4157 set x
[lindex
$cols [expr {$le - $row}]]
4158 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
4159 set dir
[expr {$xp - $x}]
4161 set ith
[lindex
$lines $i 2]
4162 set coords
[$canv coords
$ith]
4163 set ah
[$canv itemcget
$ith -arrow]
4164 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
4165 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
4166 if {$x2 ne
{} && $x - $x2 == $dir} {
4167 set coords
[lrange
$coords 0 end-2
]
4170 set coords
[list
[xc
$le $x] [yc
$le]]
4173 set itl
[lindex
$lines [expr {$i-1}] 2]
4174 set al
[$canv itemcget
$itl -arrow]
4175 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
4176 } elseif
{$arrowlow} {
4177 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
4178 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
4182 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
4183 for {set y
$le} {[incr y
-1] > $row} {} {
4185 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
4186 set ndir
[expr {$xp - $x}]
4187 if {$dir != $ndir ||
$xp < 0} {
4188 lappend coords
[xc
$y $x] [yc
$y]
4194 # join parent line to first child
4195 set ch
[lindex
$displayorder $row]
4196 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
4198 puts
"oops: drawlineseg: child $ch not on row $row"
4199 } elseif
{$xc != $x} {
4200 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
4201 set d
[expr {int
(0.5 * $linespc)}]
4204 set x2
[expr {$x1 - $d}]
4206 set x2
[expr {$x1 + $d}]
4209 set y1
[expr {$y2 + $d}]
4210 lappend coords
$x1 $y1 $x2 $y2
4211 } elseif
{$xc < $x - 1} {
4212 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
4213 } elseif
{$xc > $x + 1} {
4214 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
4218 lappend coords
[xc
$row $x] [yc
$row]
4220 set xn
[xc
$row $xp]
4222 lappend coords
$xn $yn
4226 set t
[$canv create line
$coords -width [linewidth
$id] \
4227 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
4230 set lines
[linsert
$lines $i [list
$row $le $t]]
4232 $canv coords
$ith $coords
4233 if {$arrow ne
$ah} {
4234 $canv itemconf
$ith -arrow $arrow
4236 lset lines
$i 0 $row
4239 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
4240 set ndir
[expr {$xo - $xp}]
4241 set clow
[$canv coords
$itl]
4242 if {$dir == $ndir} {
4243 set clow
[lrange
$clow 2 end
]
4245 set coords
[concat
$coords $clow]
4247 lset lines
[expr {$i-1}] 1 $le
4249 # coalesce two pieces
4251 set b
[lindex
$lines [expr {$i-1}] 0]
4252 set e
[lindex
$lines $i 1]
4253 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
4255 $canv coords
$itl $coords
4256 if {$arrow ne
$al} {
4257 $canv itemconf
$itl -arrow $arrow
4261 set linesegs
($id) $lines
4265 proc drawparentlinks
{id row
} {
4266 global rowidlist canv colormap curview parentlist
4267 global idpos linespc
4269 set rowids
[lindex
$rowidlist $row]
4270 set col [lsearch
-exact $rowids $id]
4271 if {$col < 0} return
4272 set olds
[lindex
$parentlist $row]
4273 set row2
[expr {$row + 1}]
4274 set x
[xc
$row $col]
4277 set d
[expr {int
(0.5 * $linespc)}]
4278 set ymid
[expr {$y + $d}]
4279 set ids
[lindex
$rowidlist $row2]
4280 # rmx = right-most X coord used
4283 set i
[lsearch
-exact $ids $p]
4285 puts
"oops, parent $p of $id not in list"
4288 set x2
[xc
$row2 $i]
4292 set j
[lsearch
-exact $rowids $p]
4294 # drawlineseg will do this one for us
4298 # should handle duplicated parents here...
4299 set coords
[list
$x $y]
4301 # if attaching to a vertical segment, draw a smaller
4302 # slant for visual distinctness
4305 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
4307 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
4309 } elseif
{$i < $col && $i < $j} {
4310 # segment slants towards us already
4311 lappend coords
[xc
$row $j] $y
4313 if {$i < $col - 1} {
4314 lappend coords
[expr {$x2 + $linespc}] $y
4315 } elseif
{$i > $col + 1} {
4316 lappend coords
[expr {$x2 - $linespc}] $y
4318 lappend coords
$x2 $y2
4321 lappend coords
$x2 $y2
4323 set t
[$canv create line
$coords -width [linewidth
$p] \
4324 -fill $colormap($p) -tags lines.
$p]
4328 if {$rmx > [lindex
$idpos($id) 1]} {
4329 lset idpos
($id) 1 $rmx
4334 proc drawlines
{id
} {
4337 $canv itemconf lines.
$id -width [linewidth
$id]
4340 proc drawcmittext
{id row
col} {
4341 global linespc canv canv2 canv3 fgcolor curview
4342 global cmitlisted commitinfo rowidlist parentlist
4343 global rowtextx idpos idtags idheads idotherrefs
4344 global linehtag linentag linedtag selectedline
4345 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4347 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4348 set listed
$cmitlisted($curview,$id)
4349 if {$id eq
$nullid} {
4351 } elseif
{$id eq
$nullid2} {
4354 set ofill
[expr {$listed != 0?
"blue": "white"}]
4356 set x
[xc
$row $col]
4358 set orad
[expr {$linespc / 3}]
4360 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
4361 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4362 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4363 } elseif
{$listed == 2} {
4364 # triangle pointing left for left-side commits
4365 set t
[$canv create polygon \
4366 [expr {$x - $orad}] $y \
4367 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4368 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4369 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4371 # triangle pointing right for right-side commits
4372 set t
[$canv create polygon \
4373 [expr {$x + $orad - 1}] $y \
4374 [expr {$x - $orad}] [expr {$y - $orad}] \
4375 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4376 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4379 $canv bind $t <1> {selcanvline
{} %x
%y
}
4380 set rmx
[llength
[lindex
$rowidlist $row]]
4381 set olds
[lindex
$parentlist $row]
4383 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
4385 set i
[lsearch
-exact $nextids $p]
4391 set xt
[xc
$row $rmx]
4392 set rowtextx
($row) $xt
4393 set idpos
($id) [list
$x $xt $y]
4394 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
4395 ||
[info exists idotherrefs
($id)]} {
4396 set xt
[drawtags
$id $x $xt $y]
4398 set headline
[lindex
$commitinfo($id) 0]
4399 set name
[lindex
$commitinfo($id) 1]
4400 set date [lindex
$commitinfo($id) 2]
4401 set date [formatdate
$date]
4404 set isbold
[ishighlighted
$id]
4406 lappend boldrows
$row
4407 set font mainfontbold
4409 lappend boldnamerows
$row
4410 set nfont mainfontbold
4413 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
4414 -text $headline -font $font -tags text
]
4415 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
4416 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
4417 -text $name -font $nfont -tags text
]
4418 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
4419 -text $date -font mainfont
-tags text
]
4420 if {[info exists selectedline
] && $selectedline == $row} {
4423 set xr
[expr {$xt + [font measure
$font $headline]}]
4424 if {$xr > $canvxmax} {
4430 proc drawcmitrow
{row
} {
4431 global displayorder rowidlist nrows_drawn
4432 global iddrawn markingmatches
4433 global commitinfo numcommits
4434 global filehighlight fhighlights findpattern nhighlights
4435 global hlview vhighlights
4436 global highlight_related rhighlights
4438 if {$row >= $numcommits} return
4440 set id
[lindex
$displayorder $row]
4441 if {[info exists hlview
] && ![info exists vhighlights
($id)]} {
4442 askvhighlight
$row $id
4444 if {[info exists filehighlight
] && ![info exists fhighlights
($id)]} {
4445 askfilehighlight
$row $id
4447 if {$findpattern ne
{} && ![info exists nhighlights
($id)]} {
4448 askfindhighlight
$row $id
4450 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($id)]} {
4451 askrelhighlight
$row $id
4453 if {![info exists iddrawn
($id)]} {
4454 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
4456 puts
"oops, row $row id $id not in list"
4459 if {![info exists commitinfo
($id)]} {
4463 drawcmittext
$id $row $col
4467 if {$markingmatches} {
4468 markrowmatches
$row $id
4472 proc drawcommits
{row
{endrow
{}}} {
4473 global numcommits iddrawn displayorder curview need_redisplay
4474 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4479 if {$endrow eq
{}} {
4482 if {$endrow >= $numcommits} {
4483 set endrow
[expr {$numcommits - 1}]
4486 set rl1
[expr {$row - $downarrowlen - 3}]
4490 set ro1
[expr {$row - 3}]
4494 set r2
[expr {$endrow + $uparrowlen + 3}]
4495 if {$r2 > $numcommits} {
4498 for {set r
$rl1} {$r < $r2} {incr r
} {
4499 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
4503 set rl1
[expr {$r + 1}]
4509 optimize_rows
$ro1 0 $r2
4510 if {$need_redisplay ||
$nrows_drawn > 2000} {
4515 # make the lines join to already-drawn rows either side
4516 set r
[expr {$row - 1}]
4517 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
4520 set er
[expr {$endrow + 1}]
4521 if {$er >= $numcommits ||
4522 ![info exists iddrawn
([lindex
$displayorder $er])]} {
4525 for {} {$r <= $er} {incr r
} {
4526 set id
[lindex
$displayorder $r]
4527 set wasdrawn
[info exists iddrawn
($id)]
4529 if {$r == $er} break
4530 set nextid
[lindex
$displayorder [expr {$r + 1}]]
4531 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
4532 drawparentlinks
$id $r
4534 set rowids
[lindex
$rowidlist $r]
4535 foreach lid
$rowids {
4536 if {$lid eq
{}} continue
4537 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
4539 # see if this is the first child of any of its parents
4540 foreach p
[lindex
$parentlist $r] {
4541 if {[lsearch
-exact $rowids $p] < 0} {
4542 # make this line extend up to the child
4543 set lineend
($p) [drawlineseg
$p $r $er 0]
4547 set lineend
($lid) [drawlineseg
$lid $r $er 1]
4553 proc undolayout
{row
} {
4554 global uparrowlen mingaplen downarrowlen
4555 global rowidlist rowisopt rowfinal need_redisplay
4557 set r
[expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4561 if {[llength
$rowidlist] > $r} {
4563 set rowidlist
[lrange
$rowidlist 0 $r]
4564 set rowfinal
[lrange
$rowfinal 0 $r]
4565 set rowisopt
[lrange
$rowisopt 0 $r]
4566 set need_redisplay
1
4571 proc drawvisible
{} {
4572 global canv linespc curview vrowmod selectedline targetrow targetid
4573 global need_redisplay cscroll numcommits
4575 set fs
[$canv yview
]
4576 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4577 if {$ymax eq
{} ||
$ymax == 0} return
4578 set f0
[lindex
$fs 0]
4579 set f1
[lindex
$fs 1]
4580 set y0
[expr {int
($f0 * $ymax)}]
4581 set y1
[expr {int
($f1 * $ymax)}]
4583 if {[info exists targetid
]} {
4584 if {[commitinview
$targetid $curview]} {
4585 set r
[rowofcommit
$targetid]
4586 if {$r != $targetrow} {
4587 # Fix up the scrollregion and change the scrolling position
4588 # now that our target row has moved.
4589 set diff [expr {($r - $targetrow) * $linespc}]
4592 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4595 set f0
[expr {$y0 / $ymax}]
4596 set f1
[expr {$y1 / $ymax}]
4597 allcanvs yview moveto
$f0
4598 $cscroll set $f0 $f1
4599 set need_redisplay
1
4606 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
4607 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
4608 if {$endrow >= $vrowmod($curview)} {
4609 update_arcrows
$curview
4611 if {[info exists selectedline
] &&
4612 $row <= $selectedline && $selectedline <= $endrow} {
4613 set targetrow
$selectedline
4615 set targetrow
[expr {int
(($row + $endrow) / 2)}]
4617 if {$targetrow >= $numcommits} {
4618 set targetrow
[expr {$numcommits - 1}]
4620 set targetid
[commitonrow
$targetrow]
4621 drawcommits
$row $endrow
4624 proc clear_display
{} {
4625 global iddrawn linesegs need_redisplay nrows_drawn
4626 global vhighlights fhighlights nhighlights rhighlights
4629 catch
{unset iddrawn
}
4630 catch
{unset linesegs
}
4631 catch
{unset vhighlights
}
4632 catch
{unset fhighlights
}
4633 catch
{unset nhighlights
}
4634 catch
{unset rhighlights
}
4635 set need_redisplay
0
4639 proc findcrossings
{id
} {
4640 global rowidlist parentlist numcommits displayorder
4644 foreach
{s e
} [rowranges
$id] {
4645 if {$e >= $numcommits} {
4646 set e
[expr {$numcommits - 1}]
4648 if {$e <= $s} continue
4649 for {set row
$e} {[incr row
-1] >= $s} {} {
4650 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
4652 set olds
[lindex
$parentlist $row]
4653 set kid
[lindex
$displayorder $row]
4654 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
4655 if {$kidx < 0} continue
4656 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
4658 set px
[lsearch
-exact $nextrow $p]
4659 if {$px < 0} continue
4660 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
4661 if {[lsearch
-exact $ccross $p] >= 0} continue
4662 if {$x == $px + ($kidx < $px?
-1: 1)} {
4664 } elseif
{[lsearch
-exact $cross $p] < 0} {
4671 return [concat
$ccross {{}} $cross]
4674 proc assigncolor
{id
} {
4675 global colormap colors nextcolor
4676 global parents children children curview
4678 if {[info exists colormap
($id)]} return
4679 set ncolors
[llength
$colors]
4680 if {[info exists children
($curview,$id)]} {
4681 set kids
$children($curview,$id)
4685 if {[llength
$kids] == 1} {
4686 set child
[lindex
$kids 0]
4687 if {[info exists colormap
($child)]
4688 && [llength
$parents($curview,$child)] == 1} {
4689 set colormap
($id) $colormap($child)
4695 foreach x
[findcrossings
$id] {
4697 # delimiter between corner crossings and other crossings
4698 if {[llength
$badcolors] >= $ncolors - 1} break
4699 set origbad
$badcolors
4701 if {[info exists colormap
($x)]
4702 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
4703 lappend badcolors
$colormap($x)
4706 if {[llength
$badcolors] >= $ncolors} {
4707 set badcolors
$origbad
4709 set origbad
$badcolors
4710 if {[llength
$badcolors] < $ncolors - 1} {
4711 foreach child
$kids {
4712 if {[info exists colormap
($child)]
4713 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
4714 lappend badcolors
$colormap($child)
4716 foreach p
$parents($curview,$child) {
4717 if {[info exists colormap
($p)]
4718 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
4719 lappend badcolors
$colormap($p)
4723 if {[llength
$badcolors] >= $ncolors} {
4724 set badcolors
$origbad
4727 for {set i
0} {$i <= $ncolors} {incr i
} {
4728 set c
[lindex
$colors $nextcolor]
4729 if {[incr nextcolor
] >= $ncolors} {
4732 if {[lsearch
-exact $badcolors $c]} break
4734 set colormap
($id) $c
4737 proc bindline
{t id
} {
4740 $canv bind $t <Enter
> "lineenter %x %y $id"
4741 $canv bind $t <Motion
> "linemotion %x %y $id"
4742 $canv bind $t <Leave
> "lineleave $id"
4743 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4746 proc drawtags
{id x xt y1
} {
4747 global idtags idheads idotherrefs mainhead
4748 global linespc lthickness
4749 global canv rowtextx curview fgcolor bgcolor
4754 if {[info exists idtags
($id)]} {
4755 set marks
$idtags($id)
4756 set ntags
[llength
$marks]
4758 if {[info exists idheads
($id)]} {
4759 set marks
[concat
$marks $idheads($id)]
4760 set nheads
[llength
$idheads($id)]
4762 if {[info exists idotherrefs
($id)]} {
4763 set marks
[concat
$marks $idotherrefs($id)]
4769 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4770 set yt
[expr {$y1 - 0.5 * $linespc}]
4771 set yb
[expr {$yt + $linespc - 1}]
4775 foreach tag
$marks {
4777 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4778 set wid
[font measure mainfontbold
$tag]
4780 set wid
[font measure mainfont
$tag]
4784 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4786 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4787 -width $lthickness -fill black
-tags tag.
$id]
4789 foreach tag
$marks x
$xvals wid
$wvals {
4790 set xl
[expr {$x + $delta}]
4791 set xr
[expr {$x + $delta + $wid + $lthickness}]
4793 if {[incr ntags
-1] >= 0} {
4795 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4796 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4797 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4798 $canv bind $t <1> [list showtag
$tag 1]
4799 set rowtextx
([rowofcommit
$id]) [expr {$xr + $linespc}]
4801 # draw a head or other ref
4802 if {[incr nheads
-1] >= 0} {
4804 if {$tag eq
$mainhead} {
4805 set font mainfontbold
4810 set xl
[expr {$xl - $delta/2}]
4811 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4812 -width 1 -outline black
-fill $col -tags tag.
$id
4813 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4814 set rwid
[font measure mainfont
$remoteprefix]
4815 set xi
[expr {$x + 1}]
4816 set yti
[expr {$yt + 1}]
4817 set xri
[expr {$x + $rwid}]
4818 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4819 -width 0 -fill "#ffddaa" -tags tag.
$id
4822 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4823 -font $font -tags [list tag.
$id text
]]
4825 $canv bind $t <1> [list showtag
$tag 1]
4826 } elseif
{$nheads >= 0} {
4827 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4833 proc xcoord
{i level
ln} {
4834 global canvx0 xspc1 xspc2
4836 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4837 if {$i > 0 && $i == $level} {
4838 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4839 } elseif
{$i > $level} {
4840 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4845 proc show_status
{msg
} {
4849 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4850 -tags text
-fill $fgcolor
4853 # Don't change the text pane cursor if it is currently the hand cursor,
4854 # showing that we are over a sha1 ID link.
4855 proc settextcursor
{c
} {
4856 global ctext curtextcursor
4858 if {[$ctext cget
-cursor] == $curtextcursor} {
4859 $ctext config
-cursor $c
4861 set curtextcursor
$c
4864 proc nowbusy
{what
{name
{}}} {
4865 global isbusy busyname statusw
4867 if {[array names isbusy
] eq
{}} {
4868 . config
-cursor watch
4872 set busyname
($what) $name
4874 $statusw conf
-text $name
4878 proc notbusy
{what
} {
4879 global isbusy maincursor textcursor busyname statusw
4883 if {$busyname($what) ne
{} &&
4884 [$statusw cget
-text] eq
$busyname($what)} {
4885 $statusw conf
-text {}
4888 if {[array names isbusy
] eq
{}} {
4889 . config
-cursor $maincursor
4890 settextcursor
$textcursor
4894 proc findmatches
{f
} {
4895 global findtype findstring
4896 if {$findtype == [mc
"Regexp"]} {
4897 set matches
[regexp
-indices -all -inline $findstring $f]
4900 if {$findtype == [mc
"IgnCase"]} {
4901 set f
[string tolower
$f]
4902 set fs
[string tolower
$fs]
4906 set l
[string length
$fs]
4907 while {[set j
[string first
$fs $f $i]] >= 0} {
4908 lappend matches
[list
$j [expr {$j+$l-1}]]
4909 set i
[expr {$j + $l}]
4915 proc dofind
{{dirn
1} {wrap
1}} {
4916 global findstring findstartline findcurline selectedline numcommits
4917 global gdttype filehighlight fh_serial find_dirn findallowwrap
4919 if {[info exists find_dirn
]} {
4920 if {$find_dirn == $dirn} return
4924 if {$findstring eq
{} ||
$numcommits == 0} return
4925 if {![info exists selectedline
]} {
4926 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4928 set findstartline
$selectedline
4930 set findcurline
$findstartline
4931 nowbusy finding
[mc
"Searching"]
4932 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4933 after cancel do_file_hl
$fh_serial
4934 do_file_hl
$fh_serial
4937 set findallowwrap
$wrap
4941 proc stopfinding
{} {
4942 global find_dirn findcurline fprogcoord
4944 if {[info exists find_dirn
]} {
4954 global commitdata commitinfo numcommits findpattern findloc
4955 global findstartline findcurline findallowwrap
4956 global find_dirn gdttype fhighlights fprogcoord
4957 global curview varcorder vrownum varccommits vrowmod
4959 if {![info exists find_dirn
]} {
4962 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4965 if {$find_dirn > 0} {
4967 if {$l >= $numcommits} {
4970 if {$l <= $findstartline} {
4971 set lim
[expr {$findstartline + 1}]
4974 set moretodo
$findallowwrap
4981 if {$l >= $findstartline} {
4982 set lim
[expr {$findstartline - 1}]
4985 set moretodo
$findallowwrap
4988 set n
[expr {($lim - $l) * $find_dirn}]
4993 if {$l + ($find_dirn > 0?
$n: 1) > $vrowmod($curview)} {
4994 update_arcrows
$curview
4998 set ai
[bsearch
$vrownum($curview) $l]
4999 set a
[lindex
$varcorder($curview) $ai]
5000 set arow
[lindex
$vrownum($curview) $ai]
5001 set ids
[lindex
$varccommits($curview,$a)]
5002 set arowend
[expr {$arow + [llength
$ids]}]
5003 if {$gdttype eq
[mc
"containing:"]} {
5004 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5005 if {$l < $arow ||
$l >= $arowend} {
5007 set a
[lindex
$varcorder($curview) $ai]
5008 set arow
[lindex
$vrownum($curview) $ai]
5009 set ids
[lindex
$varccommits($curview,$a)]
5010 set arowend
[expr {$arow + [llength
$ids]}]
5012 set id
[lindex
$ids [expr {$l - $arow}]]
5013 # shouldn't happen unless git log doesn't give all the commits...
5014 if {![info exists commitdata
($id)] ||
5015 ![doesmatch
$commitdata($id)]} {
5018 if {![info exists commitinfo
($id)]} {
5021 set info
$commitinfo($id)
5022 foreach f
$info ty
$fldtypes {
5023 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
5032 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5033 if {$l < $arow ||
$l >= $arowend} {
5035 set a
[lindex
$varcorder($curview) $ai]
5036 set arow
[lindex
$vrownum($curview) $ai]
5037 set ids
[lindex
$varccommits($curview,$a)]
5038 set arowend
[expr {$arow + [llength
$ids]}]
5040 set id
[lindex
$ids [expr {$l - $arow}]]
5041 if {![info exists fhighlights
($id)]} {
5042 # this sets fhighlights($id) to -1
5043 askfilehighlight
$l $id
5045 if {$fhighlights($id) > 0} {
5049 if {$fhighlights($id) < 0} {
5052 set findcurline
[expr {$l - $find_dirn}]
5057 if {$found ||
($domore && !$moretodo)} {
5073 set findcurline
[expr {$l - $find_dirn}]
5075 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
5079 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
5084 proc findselectline
{l
} {
5085 global findloc commentend ctext findcurline markingmatches gdttype
5087 set markingmatches
1
5090 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
5091 # highlight the matches in the comments
5092 set f
[$ctext get
1.0 $commentend]
5093 set matches
[findmatches
$f]
5094 foreach match
$matches {
5095 set start
[lindex
$match 0]
5096 set end
[expr {[lindex
$match 1] + 1}]
5097 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
5103 # mark the bits of a headline or author that match a find string
5104 proc markmatches
{canv l str tag matches font row
} {
5107 set bbox
[$canv bbox
$tag]
5108 set x0
[lindex
$bbox 0]
5109 set y0
[lindex
$bbox 1]
5110 set y1
[lindex
$bbox 3]
5111 foreach match
$matches {
5112 set start
[lindex
$match 0]
5113 set end
[lindex
$match 1]
5114 if {$start > $end} continue
5115 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
5116 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
5117 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
5118 [expr {$x0+$xlen+2}] $y1 \
5119 -outline {} -tags [list match
$l matches
] -fill yellow
]
5121 if {[info exists selectedline
] && $row == $selectedline} {
5122 $canv raise
$t secsel
5127 proc unmarkmatches
{} {
5128 global markingmatches
5130 allcanvs delete matches
5131 set markingmatches
0
5135 proc selcanvline
{w x y
} {
5136 global canv canvy0 ctext linespc
5138 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5139 if {$ymax == {}} return
5140 set yfrac
[lindex
[$canv yview
] 0]
5141 set y
[expr {$y + $yfrac * $ymax}]
5142 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
5147 set xmax
[lindex
[$canv cget
-scrollregion] 2]
5148 set xleft
[expr {[lindex
[$canv xview
] 0] * $xmax}]
5149 if {![info exists rowtextx
($l)] ||
$xleft + $x < $rowtextx($l)} return
5155 proc commit_descriptor
{p
} {
5157 if {![info exists commitinfo
($p)]} {
5161 if {[llength
$commitinfo($p)] > 1} {
5162 set l
[lindex
$commitinfo($p) 0]
5167 # append some text to the ctext widget, and make any SHA1 ID
5168 # that we know about be a clickable link.
5169 proc appendwithlinks
{text tags
} {
5170 global ctext linknum curview pendinglinks
5172 set start
[$ctext index
"end - 1c"]
5173 $ctext insert end
$text $tags
5174 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
5178 set linkid
[string range
$text $s $e]
5180 $ctext tag delete link
$linknum
5181 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
5182 setlink
$linkid link
$linknum
5187 proc setlink
{id lk
} {
5188 global curview ctext pendinglinks commitinterest
5190 if {[commitinview
$id $curview]} {
5191 $ctext tag conf
$lk -foreground blue
-underline 1
5192 $ctext tag
bind $lk <1> [list selectline
[rowofcommit
$id] 1]
5193 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
5194 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
5196 lappend pendinglinks
($id) $lk
5197 lappend commitinterest
($id) {makelink
%I
}
5201 proc makelink
{id
} {
5204 if {![info exists pendinglinks
($id)]} return
5205 foreach lk
$pendinglinks($id) {
5208 unset pendinglinks
($id)
5211 proc linkcursor
{w inc
} {
5212 global linkentercount curtextcursor
5214 if {[incr linkentercount
$inc] > 0} {
5215 $w configure
-cursor hand2
5217 $w configure
-cursor $curtextcursor
5218 if {$linkentercount < 0} {
5219 set linkentercount
0
5224 proc viewnextline
{dir
} {
5228 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5229 set wnow
[$canv yview
]
5230 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5231 set newtop
[expr {$wtop + $dir * $linespc}]
5234 } elseif
{$newtop > $ymax} {
5237 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5240 # add a list of tag or branch names at position pos
5241 # returns the number of names inserted
5242 proc appendrefs
{pos ids var
} {
5243 global ctext linknum curview
$var maxrefs
5245 if {[catch
{$ctext index
$pos}]} {
5248 $ctext conf
-state normal
5249 $ctext delete
$pos "$pos lineend"
5252 foreach tag
[set $var\
($id\
)] {
5253 lappend tags
[list
$tag $id]
5256 if {[llength
$tags] > $maxrefs} {
5257 $ctext insert
$pos "many ([llength $tags])"
5259 set tags
[lsort
-index 0 -decreasing $tags]
5262 set id
[lindex
$ti 1]
5265 $ctext tag delete
$lk
5266 $ctext insert
$pos $sep
5267 $ctext insert
$pos [lindex
$ti 0] $lk
5272 $ctext conf
-state disabled
5273 return [llength
$tags]
5276 # called when we have finished computing the nearby tags
5277 proc dispneartags
{delay
} {
5278 global selectedline currentid showneartags tagphase
5280 if {![info exists selectedline
] ||
!$showneartags} return
5281 after cancel dispnexttag
5283 after
200 dispnexttag
5286 after idle dispnexttag
5291 proc dispnexttag
{} {
5292 global selectedline currentid showneartags tagphase ctext
5294 if {![info exists selectedline
] ||
!$showneartags} return
5295 switch
-- $tagphase {
5297 set dtags
[desctags
$currentid]
5299 appendrefs precedes
$dtags idtags
5303 set atags
[anctags
$currentid]
5305 appendrefs follows
$atags idtags
5309 set dheads
[descheads
$currentid]
5310 if {$dheads ne
{}} {
5311 if {[appendrefs branch
$dheads idheads
] > 1
5312 && [$ctext get
"branch -3c"] eq
"h"} {
5313 # turn "Branch" into "Branches"
5314 $ctext conf
-state normal
5315 $ctext insert
"branch -2c" "es"
5316 $ctext conf
-state disabled
5321 if {[incr tagphase
] <= 2} {
5322 after idle dispnexttag
5326 proc make_secsel
{l
} {
5327 global linehtag linentag linedtag canv canv2 canv3
5329 if {![info exists linehtag
($l)]} return
5331 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
5332 -tags secsel
-fill [$canv cget
-selectbackground]]
5334 $canv2 delete secsel
5335 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
5336 -tags secsel
-fill [$canv2 cget
-selectbackground]]
5338 $canv3 delete secsel
5339 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
5340 -tags secsel
-fill [$canv3 cget
-selectbackground]]
5344 proc selectline
{l isnew
} {
5345 global canv ctext commitinfo selectedline
5346 global canvy0 linespc parents children curview
5347 global currentid sha1entry
5348 global commentend idtags linknum
5349 global mergemax numcommits pending_select
5350 global cmitmode showneartags allcommits
5352 catch
{unset pending_select
}
5357 if {$l < 0 ||
$l >= $numcommits} return
5358 set y
[expr {$canvy0 + $l * $linespc}]
5359 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5360 set ytop
[expr {$y - $linespc - 1}]
5361 set ybot
[expr {$y + $linespc + 1}]
5362 set wnow
[$canv yview
]
5363 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5364 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
5365 set wh
[expr {$wbot - $wtop}]
5367 if {$ytop < $wtop} {
5368 if {$ybot < $wtop} {
5369 set newtop
[expr {$y - $wh / 2.0}]
5372 if {$newtop > $wtop - $linespc} {
5373 set newtop
[expr {$wtop - $linespc}]
5376 } elseif
{$ybot > $wbot} {
5377 if {$ytop > $wbot} {
5378 set newtop
[expr {$y - $wh / 2.0}]
5380 set newtop
[expr {$ybot - $wh}]
5381 if {$newtop < $wtop + $linespc} {
5382 set newtop
[expr {$wtop + $linespc}]
5386 if {$newtop != $wtop} {
5390 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5396 set id
[commitonrow
$l]
5398 addtohistory
[list selbyid
$id]
5403 $sha1entry delete
0 end
5404 $sha1entry insert
0 $id
5405 $sha1entry selection from
0
5406 $sha1entry selection to end
5409 $ctext conf
-state normal
5412 set info
$commitinfo($id)
5413 set date [formatdate
[lindex
$info 2]]
5414 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
5415 set date [formatdate
[lindex
$info 4]]
5416 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
5417 if {[info exists idtags
($id)]} {
5418 $ctext insert end
[mc
"Tags:"]
5419 foreach tag
$idtags($id) {
5420 $ctext insert end
" $tag"
5422 $ctext insert end
"\n"
5426 set olds
$parents($curview,$id)
5427 if {[llength
$olds] > 1} {
5430 if {$np >= $mergemax} {
5435 $ctext insert end
"[mc "Parent
"]: " $tag
5436 appendwithlinks
[commit_descriptor
$p] {}
5441 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
5445 foreach c
$children($curview,$id) {
5446 append headers
"[mc "Child
"]: [commit_descriptor $c]"
5449 # make anything that looks like a SHA1 ID be a clickable link
5450 appendwithlinks
$headers {}
5451 if {$showneartags} {
5452 if {![info exists allcommits
]} {
5455 $ctext insert end
"[mc "Branch
"]: "
5456 $ctext mark
set branch
"end -1c"
5457 $ctext mark gravity branch left
5458 $ctext insert end
"\n[mc "Follows
"]: "
5459 $ctext mark
set follows
"end -1c"
5460 $ctext mark gravity follows left
5461 $ctext insert end
"\n[mc "Precedes
"]: "
5462 $ctext mark
set precedes
"end -1c"
5463 $ctext mark gravity precedes left
5464 $ctext insert end
"\n"
5467 $ctext insert end
"\n"
5468 set comment
[lindex
$info 5]
5469 if {[string first
"\r" $comment] >= 0} {
5470 set comment
[string map
{"\r" "\n "} $comment]
5472 appendwithlinks
$comment {comment
}
5474 $ctext tag remove found
1.0 end
5475 $ctext conf
-state disabled
5476 set commentend
[$ctext index
"end - 1c"]
5478 init_flist
[mc
"Comments"]
5479 if {$cmitmode eq
"tree"} {
5481 } elseif
{[llength
$olds] <= 1} {
5488 proc selfirstline
{} {
5493 proc sellastline
{} {
5496 set l
[expr {$numcommits - 1}]
5500 proc selnextline
{dir
} {
5503 if {![info exists selectedline
]} return
5504 set l
[expr {$selectedline + $dir}]
5509 proc selnextpage
{dir
} {
5510 global canv linespc selectedline numcommits
5512 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
5516 allcanvs yview scroll
[expr {$dir * $lpp}] units
5518 if {![info exists selectedline
]} return
5519 set l
[expr {$selectedline + $dir * $lpp}]
5522 } elseif
{$l >= $numcommits} {
5523 set l
[expr $numcommits - 1]
5529 proc unselectline
{} {
5530 global selectedline currentid
5532 catch
{unset selectedline
}
5533 catch
{unset currentid
}
5534 allcanvs delete secsel
5538 proc reselectline
{} {
5541 if {[info exists selectedline
]} {
5542 selectline
$selectedline 0
5546 proc addtohistory
{cmd
} {
5547 global
history historyindex curview
5549 set elt
[list
$curview $cmd]
5550 if {$historyindex > 0
5551 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
5555 if {$historyindex < [llength
$history]} {
5556 set history [lreplace
$history $historyindex end
$elt]
5558 lappend
history $elt
5561 if {$historyindex > 1} {
5562 .tf.bar.leftbut conf
-state normal
5564 .tf.bar.leftbut conf
-state disabled
5566 .tf.bar.rightbut conf
-state disabled
5572 set view
[lindex
$elt 0]
5573 set cmd
[lindex
$elt 1]
5574 if {$curview != $view} {
5581 global
history historyindex
5584 if {$historyindex > 1} {
5585 incr historyindex
-1
5586 godo
[lindex
$history [expr {$historyindex - 1}]]
5587 .tf.bar.rightbut conf
-state normal
5589 if {$historyindex <= 1} {
5590 .tf.bar.leftbut conf
-state disabled
5595 global
history historyindex
5598 if {$historyindex < [llength
$history]} {
5599 set cmd
[lindex
$history $historyindex]
5602 .tf.bar.leftbut conf
-state normal
5604 if {$historyindex >= [llength
$history]} {
5605 .tf.bar.rightbut conf
-state disabled
5610 global treefilelist treeidlist diffids diffmergeid treepending
5611 global nullid nullid2
5614 catch
{unset diffmergeid
}
5615 if {![info exists treefilelist
($id)]} {
5616 if {![info exists treepending
]} {
5617 if {$id eq
$nullid} {
5618 set cmd
[list | git ls-files
]
5619 } elseif
{$id eq
$nullid2} {
5620 set cmd
[list | git ls-files
--stage -t]
5622 set cmd
[list | git ls-tree
-r $id]
5624 if {[catch
{set gtf
[open
$cmd r
]}]} {
5628 set treefilelist
($id) {}
5629 set treeidlist
($id) {}
5630 fconfigure
$gtf -blocking 0
5631 filerun
$gtf [list gettreeline
$gtf $id]
5638 proc gettreeline
{gtf id
} {
5639 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5642 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
5643 if {$diffids eq
$nullid} {
5646 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
5647 set i
[string first
"\t" $line]
5648 if {$i < 0} continue
5649 set sha1
[lindex
$line 2]
5650 set fname
[string range
$line [expr {$i+1}] end
]
5651 if {[string index
$fname 0] eq
"\""} {
5652 set fname
[lindex
$fname 0]
5654 lappend treeidlist
($id) $sha1
5656 lappend treefilelist
($id) $fname
5659 return [expr {$nl >= 1000?
2: 1}]
5663 if {$cmitmode ne
"tree"} {
5664 if {![info exists diffmergeid
]} {
5665 gettreediffs
$diffids
5667 } elseif
{$id ne
$diffids} {
5676 global treefilelist treeidlist diffids nullid nullid2
5677 global ctext commentend
5679 set i
[lsearch
-exact $treefilelist($diffids) $f]
5681 puts
"oops, $f not in list for id $diffids"
5684 if {$diffids eq
$nullid} {
5685 if {[catch
{set bf
[open
$f r
]} err
]} {
5686 puts
"oops, can't read $f: $err"
5690 set blob
[lindex
$treeidlist($diffids) $i]
5691 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5692 puts
"oops, error reading blob $blob: $err"
5696 fconfigure
$bf -blocking 0
5697 filerun
$bf [list getblobline
$bf $diffids]
5698 $ctext config
-state normal
5699 clear_ctext
$commentend
5700 $ctext insert end
"\n"
5701 $ctext insert end
"$f\n" filesep
5702 $ctext config
-state disabled
5703 $ctext yview
$commentend
5707 proc getblobline
{bf id
} {
5708 global diffids cmitmode ctext
5710 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5714 $ctext config
-state normal
5716 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5717 $ctext insert end
"$line\n"
5720 # delete last newline
5721 $ctext delete
"end - 2c" "end - 1c"
5725 $ctext config
-state disabled
5726 return [expr {$nl >= 1000?
2: 1}]
5729 proc mergediff
{id
} {
5730 global diffmergeid mdifffd
5733 global limitdiffs viewfiles curview
5737 # this doesn't seem to actually affect anything...
5738 set cmd
[concat | git diff-tree
--no-commit-id --cc $id]
5739 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5740 set cmd
[concat
$cmd -- $viewfiles($curview)]
5742 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5743 error_popup
"[mc "Error getting merge diffs
:"] $err"
5746 fconfigure
$mdf -blocking 0
5747 set mdifffd
($id) $mdf
5748 set np
[llength
$parents($curview,$id)]
5750 filerun
$mdf [list getmergediffline
$mdf $id $np]
5753 proc getmergediffline
{mdf id np
} {
5754 global diffmergeid ctext cflist mergemax
5755 global difffilestart mdifffd
5757 $ctext conf
-state normal
5759 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5760 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5761 ||
$mdf != $mdifffd($id)} {
5765 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5766 # start of a new file
5767 $ctext insert end
"\n"
5768 set here
[$ctext index
"end - 1c"]
5769 lappend difffilestart
$here
5770 add_flist
[list
$fname]
5771 set l
[expr {(78 - [string length
$fname]) / 2}]
5772 set pad
[string range
"----------------------------------------" 1 $l]
5773 $ctext insert end
"$pad $fname $pad\n" filesep
5774 } elseif
{[regexp
{^@@
} $line]} {
5775 $ctext insert end
"$line\n" hunksep
5776 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5779 # parse the prefix - one ' ', '-' or '+' for each parent
5784 for {set j
0} {$j < $np} {incr j
} {
5785 set c
[string range
$line $j $j]
5788 } elseif
{$c == "-"} {
5790 } elseif
{$c == "+"} {
5799 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5800 # line doesn't appear in result, parents in $minuses have the line
5801 set num
[lindex
$minuses 0]
5802 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5803 # line appears in result, parents in $pluses don't have the line
5804 lappend tags mresult
5805 set num
[lindex
$spaces 0]
5808 if {$num >= $mergemax} {
5813 $ctext insert end
"$line\n" $tags
5816 $ctext conf
-state disabled
5821 return [expr {$nr >= 1000?
2: 1}]
5824 proc startdiff
{ids
} {
5825 global treediffs diffids treepending diffmergeid nullid nullid2
5829 catch
{unset diffmergeid
}
5830 if {![info exists treediffs
($ids)] ||
5831 [lsearch
-exact $ids $nullid] >= 0 ||
5832 [lsearch
-exact $ids $nullid2] >= 0} {
5833 if {![info exists treepending
]} {
5841 proc path_filter
{filter name
} {
5843 set l
[string length
$p]
5844 if {[string index
$p end
] eq
"/"} {
5845 if {[string compare
-length $l $p $name] == 0} {
5849 if {[string compare
-length $l $p $name] == 0 &&
5850 ([string length
$name] == $l ||
5851 [string index
$name $l] eq
"/")} {
5859 proc addtocflist
{ids
} {
5862 add_flist
$treediffs($ids)
5866 proc diffcmd
{ids flags
} {
5867 global nullid nullid2
5869 set i
[lsearch
-exact $ids $nullid]
5870 set j
[lsearch
-exact $ids $nullid2]
5872 if {[llength
$ids] > 1 && $j < 0} {
5873 # comparing working directory with some specific revision
5874 set cmd
[concat | git diff-index
$flags]
5876 lappend cmd
-R [lindex
$ids 1]
5878 lappend cmd
[lindex
$ids 0]
5881 # comparing working directory with index
5882 set cmd
[concat | git diff-files
$flags]
5887 } elseif
{$j >= 0} {
5888 set cmd
[concat | git diff-index
--cached $flags]
5889 if {[llength
$ids] > 1} {
5890 # comparing index with specific revision
5892 lappend cmd
-R [lindex
$ids 1]
5894 lappend cmd
[lindex
$ids 0]
5897 # comparing index with HEAD
5901 set cmd
[concat | git diff-tree
-r $flags $ids]
5906 proc gettreediffs
{ids
} {
5907 global treediff treepending
5909 set treepending
$ids
5911 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5912 fconfigure
$gdtf -blocking 0
5913 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5916 proc gettreediffline
{gdtf ids
} {
5917 global treediff treediffs treepending diffids diffmergeid
5918 global cmitmode viewfiles curview limitdiffs
5921 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5922 set i
[string first
"\t" $line]
5924 set file [string range
$line [expr {$i+1}] end
]
5925 if {[string index
$file 0] eq
"\""} {
5926 set file [lindex
$file 0]
5928 lappend treediff
$file
5932 return [expr {$nr >= 1000?
2: 1}]
5935 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5937 foreach f
$treediff {
5938 if {[path_filter
$viewfiles($curview) $f]} {
5942 set treediffs
($ids) $flist
5944 set treediffs
($ids) $treediff
5947 if {$cmitmode eq
"tree"} {
5949 } elseif
{$ids != $diffids} {
5950 if {![info exists diffmergeid
]} {
5951 gettreediffs
$diffids
5959 # empty string or positive integer
5960 proc diffcontextvalidate
{v
} {
5961 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5964 proc diffcontextchange
{n1 n2 op
} {
5965 global diffcontextstring diffcontext
5967 if {[string is integer
-strict $diffcontextstring]} {
5968 if {$diffcontextstring > 0} {
5969 set diffcontext
$diffcontextstring
5975 proc getblobdiffs
{ids
} {
5976 global blobdifffd diffids env
5977 global diffinhdr treediffs
5979 global limitdiffs viewfiles curview
5981 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5982 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5983 set cmd
[concat
$cmd -- $viewfiles($curview)]
5985 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5986 puts
"error getting diffs: $err"
5990 fconfigure
$bdf -blocking 0
5991 set blobdifffd
($ids) $bdf
5992 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5995 proc setinlist
{var i val
} {
5998 while {[llength
[set $var]] < $i} {
6001 if {[llength
[set $var]] == $i} {
6008 proc makediffhdr
{fname ids
} {
6009 global ctext curdiffstart treediffs
6011 set i
[lsearch
-exact $treediffs($ids) $fname]
6013 setinlist difffilestart
$i $curdiffstart
6015 set l
[expr {(78 - [string length
$fname]) / 2}]
6016 set pad
[string range
"----------------------------------------" 1 $l]
6017 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
6020 proc getblobdiffline
{bdf ids
} {
6021 global diffids blobdifffd ctext curdiffstart
6022 global diffnexthead diffnextnote difffilestart
6023 global diffinhdr treediffs
6026 $ctext conf
-state normal
6027 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
6028 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
6032 if {![string compare
-length 11 "diff --git " $line]} {
6033 # trim off "diff --git "
6034 set line
[string range
$line 11 end
]
6036 # start of a new file
6037 $ctext insert end
"\n"
6038 set curdiffstart
[$ctext index
"end - 1c"]
6039 $ctext insert end
"\n" filesep
6040 # If the name hasn't changed the length will be odd,
6041 # the middle char will be a space, and the two bits either
6042 # side will be a/name and b/name, or "a/name" and "b/name".
6043 # If the name has changed we'll get "rename from" and
6044 # "rename to" or "copy from" and "copy to" lines following this,
6045 # and we'll use them to get the filenames.
6046 # This complexity is necessary because spaces in the filename(s)
6047 # don't get escaped.
6048 set l
[string length
$line]
6049 set i
[expr {$l / 2}]
6050 if {!(($l & 1) && [string index
$line $i] eq
" " &&
6051 [string range
$line 2 [expr {$i - 1}]] eq \
6052 [string range
$line [expr {$i + 3}] end
])} {
6055 # unescape if quoted and chop off the a/ from the front
6056 if {[string index
$line 0] eq
"\""} {
6057 set fname
[string range
[lindex
$line 0] 2 end
]
6059 set fname
[string range
$line 2 [expr {$i - 1}]]
6061 makediffhdr
$fname $ids
6063 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
6064 $line match f1l f1c f2l f2c rest
]} {
6065 $ctext insert end
"$line\n" hunksep
6068 } elseif
{$diffinhdr} {
6069 if {![string compare
-length 12 "rename from " $line]} {
6070 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
6071 if {[string index
$fname 0] eq
"\""} {
6072 set fname
[lindex
$fname 0]
6074 set i
[lsearch
-exact $treediffs($ids) $fname]
6076 setinlist difffilestart
$i $curdiffstart
6078 } elseif
{![string compare
-length 10 $line "rename to "] ||
6079 ![string compare
-length 8 $line "copy to "]} {
6080 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
6081 if {[string index
$fname 0] eq
"\""} {
6082 set fname
[lindex
$fname 0]
6084 makediffhdr
$fname $ids
6085 } elseif
{[string compare
-length 3 $line "---"] == 0} {
6088 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
6092 $ctext insert end
"$line\n" filesep
6095 set x
[string range
$line 0 0]
6096 if {$x == "-" ||
$x == "+"} {
6097 set tag
[expr {$x == "+"}]
6098 $ctext insert end
"$line\n" d
$tag
6099 } elseif
{$x == " "} {
6100 $ctext insert end
"$line\n"
6102 # "\ No newline at end of file",
6103 # or something else we don't recognize
6104 $ctext insert end
"$line\n" hunksep
6108 $ctext conf
-state disabled
6113 return [expr {$nr >= 1000?
2: 1}]
6116 proc changediffdisp
{} {
6117 global ctext diffelide
6119 $ctext tag conf d0
-elide [lindex
$diffelide 0]
6120 $ctext tag conf d1
-elide [lindex
$diffelide 1]
6124 global difffilestart ctext
6125 set prev
[lindex
$difffilestart 0]
6126 set here
[$ctext index @
0,0]
6127 foreach loc
$difffilestart {
6128 if {[$ctext compare
$loc >= $here]} {
6138 global difffilestart ctext
6139 set here
[$ctext index @
0,0]
6140 foreach loc
$difffilestart {
6141 if {[$ctext compare
$loc > $here]} {
6148 proc clear_ctext
{{first
1.0}} {
6149 global ctext smarktop smarkbot
6152 set l
[lindex
[split $first .
] 0]
6153 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
6156 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
6159 $ctext delete
$first end
6160 if {$first eq
"1.0"} {
6161 catch
{unset pendinglinks
}
6165 proc settabs
{{firstab
{}}} {
6166 global firsttabstop tabstop ctext have_tk85
6168 if {$firstab ne
{} && $have_tk85} {
6169 set firsttabstop
$firstab
6171 set w
[font measure textfont
"0"]
6172 if {$firsttabstop != 0} {
6173 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
6174 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6175 } elseif
{$have_tk85 ||
$tabstop != 8} {
6176 $ctext conf
-tabs [expr {$tabstop * $w}]
6178 $ctext conf
-tabs {}
6182 proc incrsearch
{name ix op
} {
6183 global ctext searchstring searchdirn
6185 $ctext tag remove found
1.0 end
6186 if {[catch
{$ctext index anchor
}]} {
6187 # no anchor set, use start of selection, or of visible area
6188 set sel
[$ctext tag ranges sel
]
6190 $ctext mark
set anchor
[lindex
$sel 0]
6191 } elseif
{$searchdirn eq
"-forwards"} {
6192 $ctext mark
set anchor @
0,0
6194 $ctext mark
set anchor @
0,[winfo height
$ctext]
6197 if {$searchstring ne
{}} {
6198 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
6207 global sstring ctext searchstring searchdirn
6210 $sstring icursor end
6211 set searchdirn
-forwards
6212 if {$searchstring ne
{}} {
6213 set sel
[$ctext tag ranges sel
]
6215 set start
"[lindex $sel 0] + 1c"
6216 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6219 set match
[$ctext search
-count mlen
-- $searchstring $start]
6220 $ctext tag remove sel
1.0 end
6226 set mend
"$match + $mlen c"
6227 $ctext tag add sel
$match $mend
6228 $ctext mark
unset anchor
6232 proc dosearchback
{} {
6233 global sstring ctext searchstring searchdirn
6236 $sstring icursor end
6237 set searchdirn
-backwards
6238 if {$searchstring ne
{}} {
6239 set sel
[$ctext tag ranges sel
]
6241 set start
[lindex
$sel 0]
6242 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6243 set start @
0,[winfo height
$ctext]
6245 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
6246 $ctext tag remove sel
1.0 end
6252 set mend
"$match + $ml c"
6253 $ctext tag add sel
$match $mend
6254 $ctext mark
unset anchor
6258 proc searchmark
{first last
} {
6259 global ctext searchstring
6263 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
6264 if {$match eq
{}} break
6265 set mend
"$match + $mlen c"
6266 $ctext tag add found
$match $mend
6270 proc searchmarkvisible
{doall
} {
6271 global ctext smarktop smarkbot
6273 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
6274 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
6275 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
6276 # no overlap with previous
6277 searchmark
$topline $botline
6278 set smarktop
$topline
6279 set smarkbot
$botline
6281 if {$topline < $smarktop} {
6282 searchmark
$topline [expr {$smarktop-1}]
6283 set smarktop
$topline
6285 if {$botline > $smarkbot} {
6286 searchmark
[expr {$smarkbot+1}] $botline
6287 set smarkbot
$botline
6292 proc scrolltext
{f0 f1
} {
6295 .bleft.sb
set $f0 $f1
6296 if {$searchstring ne
{}} {
6302 global linespc charspc canvx0 canvy0
6303 global xspc1 xspc2 lthickness
6305 set linespc
[font metrics mainfont
-linespace]
6306 set charspc
[font measure mainfont
"m"]
6307 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
6308 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
6309 set lthickness
[expr {int
($linespc / 9) + 1}]
6310 set xspc1
(0) $linespc
6318 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6319 if {$ymax eq
{} ||
$ymax == 0} return
6320 set span
[$canv yview
]
6323 allcanvs yview moveto
[lindex
$span 0]
6325 if {[info exists selectedline
]} {
6326 selectline
$selectedline 0
6327 allcanvs yview moveto
[lindex
$span 0]
6331 proc parsefont
{f n
} {
6334 set fontattr
($f,family
) [lindex
$n 0]
6336 if {$s eq
{} ||
$s == 0} {
6339 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
6341 set fontattr
($f,size
) $s
6342 set fontattr
($f,weight
) normal
6343 set fontattr
($f,slant
) roman
6344 foreach style
[lrange
$n 2 end
] {
6347 "bold" {set fontattr
($f,weight
) $style}
6349 "italic" {set fontattr
($f,slant
) $style}
6354 proc fontflags
{f
{isbold
0}} {
6357 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
6358 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
6359 -slant $fontattr($f,slant
)]
6365 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
6366 if {$fontattr($f,weight
) eq
"bold"} {
6369 if {$fontattr($f,slant
) eq
"italic"} {
6375 proc incrfont
{inc
} {
6376 global mainfont textfont ctext canv cflist showrefstop
6377 global stopped entries fontattr
6380 set s
$fontattr(mainfont
,size
)
6385 set fontattr
(mainfont
,size
) $s
6386 font config mainfont
-size $s
6387 font config mainfontbold
-size $s
6388 set mainfont
[fontname mainfont
]
6389 set s
$fontattr(textfont
,size
)
6394 set fontattr
(textfont
,size
) $s
6395 font config textfont
-size $s
6396 font config textfontbold
-size $s
6397 set textfont
[fontname textfont
]
6404 global sha1entry sha1string
6405 if {[string length
$sha1string] == 40} {
6406 $sha1entry delete
0 end
6410 proc sha1change
{n1 n2 op
} {
6411 global sha1string currentid sha1but
6412 if {$sha1string == {}
6413 ||
([info exists currentid
] && $sha1string == $currentid)} {
6418 if {[$sha1but cget
-state] == $state} return
6419 if {$state == "normal"} {
6420 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
6422 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
6426 proc gotocommit
{} {
6427 global sha1string tagids headids curview varcid
6429 if {$sha1string == {}
6430 ||
([info exists currentid
] && $sha1string == $currentid)} return
6431 if {[info exists tagids
($sha1string)]} {
6432 set id
$tagids($sha1string)
6433 } elseif
{[info exists headids
($sha1string)]} {
6434 set id
$headids($sha1string)
6436 set id
[string tolower
$sha1string]
6437 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
6438 set matches
[array names varcid
"$curview,$id*"]
6439 if {$matches ne
{}} {
6440 if {[llength
$matches] > 1} {
6441 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
6444 set id
[lindex
[split [lindex
$matches 0] ","] 1]
6448 if {[commitinview
$id $curview]} {
6449 selectline
[rowofcommit
$id] 1
6452 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
6453 set msg
[mc
"SHA1 id %s is not known" $sha1string]
6455 set msg
[mc
"Tag/Head %s is not known" $sha1string]
6460 proc lineenter
{x y id
} {
6461 global hoverx hovery hoverid hovertimer
6462 global commitinfo canv
6464 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6468 if {[info exists hovertimer
]} {
6469 after cancel
$hovertimer
6471 set hovertimer
[after
500 linehover
]
6475 proc linemotion
{x y id
} {
6476 global hoverx hovery hoverid hovertimer
6478 if {[info exists hoverid
] && $id == $hoverid} {
6481 if {[info exists hovertimer
]} {
6482 after cancel
$hovertimer
6484 set hovertimer
[after
500 linehover
]
6488 proc lineleave
{id
} {
6489 global hoverid hovertimer canv
6491 if {[info exists hoverid
] && $id == $hoverid} {
6493 if {[info exists hovertimer
]} {
6494 after cancel
$hovertimer
6502 global hoverx hovery hoverid hovertimer
6503 global canv linespc lthickness
6506 set text
[lindex
$commitinfo($hoverid) 0]
6507 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6508 if {$ymax == {}} return
6509 set yfrac
[lindex
[$canv yview
] 0]
6510 set x
[expr {$hoverx + 2 * $linespc}]
6511 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6512 set x0
[expr {$x - 2 * $lthickness}]
6513 set y0
[expr {$y - 2 * $lthickness}]
6514 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
6515 set y1
[expr {$y + $linespc + 2 * $lthickness}]
6516 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
6517 -fill \
#ffff80 -outline black -width 1 -tags hover]
6519 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
6524 proc clickisonarrow
{id y
} {
6527 set ranges
[rowranges
$id]
6528 set thresh
[expr {2 * $lthickness + 6}]
6529 set n
[expr {[llength
$ranges] - 1}]
6530 for {set i
1} {$i < $n} {incr i
} {
6531 set row
[lindex
$ranges $i]
6532 if {abs
([yc
$row] - $y) < $thresh} {
6539 proc arrowjump
{id n y
} {
6542 # 1 <-> 2, 3 <-> 4, etc...
6543 set n
[expr {(($n - 1) ^
1) + 1}]
6544 set row
[lindex
[rowranges
$id] $n]
6546 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6547 if {$ymax eq
{} ||
$ymax <= 0} return
6548 set view
[$canv yview
]
6549 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
6550 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
6554 allcanvs yview moveto
$yfrac
6557 proc lineclick
{x y id isnew
} {
6558 global ctext commitinfo children canv thickerline curview
6560 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6565 # draw this line thicker than normal
6569 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6570 if {$ymax eq
{}} return
6571 set yfrac
[lindex
[$canv yview
] 0]
6572 set y
[expr {$y + $yfrac * $ymax}]
6574 set dirn
[clickisonarrow
$id $y]
6576 arrowjump
$id $dirn $y
6581 addtohistory
[list lineclick
$x $y $id 0]
6583 # fill the details pane with info about this line
6584 $ctext conf
-state normal
6587 $ctext insert end
"[mc "Parent
"]:\t"
6588 $ctext insert end
$id link0
6590 set info
$commitinfo($id)
6591 $ctext insert end
"\n\t[lindex $info 0]\n"
6592 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
6593 set date [formatdate
[lindex
$info 2]]
6594 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
6595 set kids
$children($curview,$id)
6597 $ctext insert end
"\n[mc "Children
"]:"
6599 foreach child
$kids {
6601 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
6602 set info
$commitinfo($child)
6603 $ctext insert end
"\n\t"
6604 $ctext insert end
$child link
$i
6605 setlink
$child link
$i
6606 $ctext insert end
"\n\t[lindex $info 0]"
6607 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
6608 set date [formatdate
[lindex
$info 2]]
6609 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
6612 $ctext conf
-state disabled
6616 proc normalline
{} {
6618 if {[info exists thickerline
]} {
6627 if {[commitinview
$id $curview]} {
6628 selectline
[rowofcommit
$id] 1
6634 if {![info exists startmstime
]} {
6635 set startmstime
[clock clicks
-milliseconds]
6637 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
6640 proc rowmenu
{x y id
} {
6641 global rowctxmenu selectedline rowmenuid curview
6642 global nullid nullid2 fakerowmenu mainhead
6646 if {![info exists selectedline
]
6647 ||
[rowofcommit
$id] eq
$selectedline} {
6652 if {$id ne
$nullid && $id ne
$nullid2} {
6653 set menu
$rowctxmenu
6654 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6656 set menu
$fakerowmenu
6658 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6659 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6660 $menu entryconfigure
[mc
"Make patch"] -state $state
6661 tk_popup
$menu $x $y
6664 proc diffvssel
{dirn
} {
6665 global rowmenuid selectedline
6667 if {![info exists selectedline
]} return
6669 set oldid
[commitonrow
$selectedline]
6670 set newid
$rowmenuid
6672 set oldid
$rowmenuid
6673 set newid
[commitonrow
$selectedline]
6675 addtohistory
[list doseldiff
$oldid $newid]
6676 doseldiff
$oldid $newid
6679 proc doseldiff
{oldid newid
} {
6683 $ctext conf
-state normal
6685 init_flist
[mc
"Top"]
6686 $ctext insert end
"[mc "From
"] "
6687 $ctext insert end
$oldid link0
6688 setlink
$oldid link0
6689 $ctext insert end
"\n "
6690 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6691 $ctext insert end
"\n\n[mc "To
"] "
6692 $ctext insert end
$newid link1
6693 setlink
$newid link1
6694 $ctext insert end
"\n "
6695 $ctext insert end
[lindex
$commitinfo($newid) 0]
6696 $ctext insert end
"\n"
6697 $ctext conf
-state disabled
6698 $ctext tag remove found
1.0 end
6699 startdiff
[list
$oldid $newid]
6703 global rowmenuid currentid commitinfo patchtop patchnum
6705 if {![info exists currentid
]} return
6706 set oldid
$currentid
6707 set oldhead
[lindex
$commitinfo($oldid) 0]
6708 set newid
$rowmenuid
6709 set newhead
[lindex
$commitinfo($newid) 0]
6712 catch
{destroy
$top}
6714 label
$top.title
-text [mc
"Generate patch"]
6715 grid
$top.title
- -pady 10
6716 label
$top.from
-text [mc
"From:"]
6717 entry
$top.fromsha1
-width 40 -relief flat
6718 $top.fromsha1 insert
0 $oldid
6719 $top.fromsha1 conf
-state readonly
6720 grid
$top.from
$top.fromsha1
-sticky w
6721 entry
$top.fromhead
-width 60 -relief flat
6722 $top.fromhead insert
0 $oldhead
6723 $top.fromhead conf
-state readonly
6724 grid x
$top.fromhead
-sticky w
6725 label
$top.to
-text [mc
"To:"]
6726 entry
$top.tosha1
-width 40 -relief flat
6727 $top.tosha1 insert
0 $newid
6728 $top.tosha1 conf
-state readonly
6729 grid
$top.to
$top.tosha1
-sticky w
6730 entry
$top.tohead
-width 60 -relief flat
6731 $top.tohead insert
0 $newhead
6732 $top.tohead conf
-state readonly
6733 grid x
$top.tohead
-sticky w
6734 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6735 grid
$top.
rev x
-pady 10
6736 label
$top.flab
-text [mc
"Output file:"]
6737 entry
$top.fname
-width 60
6738 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6740 grid
$top.flab
$top.fname
-sticky w
6742 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6743 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6744 grid
$top.buts.gen
$top.buts.can
6745 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6746 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6747 grid
$top.buts
- -pady 10 -sticky ew
6751 proc mkpatchrev
{} {
6754 set oldid
[$patchtop.fromsha1 get
]
6755 set oldhead
[$patchtop.fromhead get
]
6756 set newid
[$patchtop.tosha1 get
]
6757 set newhead
[$patchtop.tohead get
]
6758 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6759 v
[list
$newid $newhead $oldid $oldhead] {
6760 $patchtop.
$e conf
-state normal
6761 $patchtop.
$e delete
0 end
6762 $patchtop.
$e insert
0 $v
6763 $patchtop.
$e conf
-state readonly
6768 global patchtop nullid nullid2
6770 set oldid
[$patchtop.fromsha1 get
]
6771 set newid
[$patchtop.tosha1 get
]
6772 set fname
[$patchtop.fname get
]
6773 set cmd
[diffcmd
[list
$oldid $newid] -p]
6774 # trim off the initial "|"
6775 set cmd
[lrange
$cmd 1 end
]
6776 lappend cmd
>$fname &
6777 if {[catch
{eval exec $cmd} err
]} {
6778 error_popup
"[mc "Error creating
patch:"] $err"
6780 catch
{destroy
$patchtop}
6784 proc mkpatchcan
{} {
6787 catch
{destroy
$patchtop}
6792 global rowmenuid mktagtop commitinfo
6796 catch
{destroy
$top}
6798 label
$top.title
-text [mc
"Create tag"]
6799 grid
$top.title
- -pady 10
6800 label
$top.id
-text [mc
"ID:"]
6801 entry
$top.sha1
-width 40 -relief flat
6802 $top.sha1 insert
0 $rowmenuid
6803 $top.sha1 conf
-state readonly
6804 grid
$top.id
$top.sha1
-sticky w
6805 entry
$top.
head -width 60 -relief flat
6806 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6807 $top.
head conf
-state readonly
6808 grid x
$top.
head -sticky w
6809 label
$top.tlab
-text [mc
"Tag name:"]
6810 entry
$top.tag
-width 60
6811 grid
$top.tlab
$top.tag
-sticky w
6813 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6814 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6815 grid
$top.buts.gen
$top.buts.can
6816 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6817 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6818 grid
$top.buts
- -pady 10 -sticky ew
6823 global mktagtop env tagids idtags
6825 set id
[$mktagtop.sha1 get
]
6826 set tag
[$mktagtop.tag get
]
6828 error_popup
[mc
"No tag name specified"]
6831 if {[info exists tagids
($tag)]} {
6832 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6837 set fname
[file join $dir "refs/tags" $tag]
6838 set f
[open
$fname w
]
6842 error_popup
"[mc "Error creating tag
:"] $err"
6846 set tagids
($tag) $id
6847 lappend idtags
($id) $tag
6854 proc redrawtags
{id
} {
6855 global canv linehtag idpos currentid curview
6856 global canvxmax iddrawn
6858 if {![commitinview
$id $curview]} return
6859 if {![info exists iddrawn
($id)]} return
6860 set row
[rowofcommit
$id]
6861 $canv delete tag.
$id
6862 set xt
[eval drawtags
$id $idpos($id)]
6863 $canv coords
$linehtag($row) $xt [lindex
$idpos($id) 2]
6864 set text
[$canv itemcget
$linehtag($row) -text]
6865 set font
[$canv itemcget
$linehtag($row) -font]
6866 set xr
[expr {$xt + [font measure
$font $text]}]
6867 if {$xr > $canvxmax} {
6871 if {[info exists currentid
] && $currentid == $id} {
6879 catch
{destroy
$mktagtop}
6888 proc writecommit
{} {
6889 global rowmenuid wrcomtop commitinfo wrcomcmd
6891 set top .writecommit
6893 catch
{destroy
$top}
6895 label
$top.title
-text [mc
"Write commit to file"]
6896 grid
$top.title
- -pady 10
6897 label
$top.id
-text [mc
"ID:"]
6898 entry
$top.sha1
-width 40 -relief flat
6899 $top.sha1 insert
0 $rowmenuid
6900 $top.sha1 conf
-state readonly
6901 grid
$top.id
$top.sha1
-sticky w
6902 entry
$top.
head -width 60 -relief flat
6903 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6904 $top.
head conf
-state readonly
6905 grid x
$top.
head -sticky w
6906 label
$top.clab
-text [mc
"Command:"]
6907 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6908 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6909 label
$top.flab
-text [mc
"Output file:"]
6910 entry
$top.fname
-width 60
6911 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6912 grid
$top.flab
$top.fname
-sticky w
6914 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6915 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6916 grid
$top.buts.gen
$top.buts.can
6917 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6918 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6919 grid
$top.buts
- -pady 10 -sticky ew
6926 set id
[$wrcomtop.sha1 get
]
6927 set cmd
"echo $id | [$wrcomtop.cmd get]"
6928 set fname
[$wrcomtop.fname get
]
6929 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6930 error_popup
"[mc "Error writing commit
:"] $err"
6932 catch
{destroy
$wrcomtop}
6939 catch
{destroy
$wrcomtop}
6944 global rowmenuid mkbrtop
6947 catch
{destroy
$top}
6949 label
$top.title
-text [mc
"Create new branch"]
6950 grid
$top.title
- -pady 10
6951 label
$top.id
-text [mc
"ID:"]
6952 entry
$top.sha1
-width 40 -relief flat
6953 $top.sha1 insert
0 $rowmenuid
6954 $top.sha1 conf
-state readonly
6955 grid
$top.id
$top.sha1
-sticky w
6956 label
$top.nlab
-text [mc
"Name:"]
6957 entry
$top.name
-width 40
6958 grid
$top.nlab
$top.name
-sticky w
6960 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6961 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6962 grid
$top.buts.go
$top.buts.can
6963 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6964 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6965 grid
$top.buts
- -pady 10 -sticky ew
6970 global headids idheads
6972 set name
[$top.name get
]
6973 set id
[$top.sha1 get
]
6975 error_popup
[mc
"Please specify a name for the new branch"]
6978 catch
{destroy
$top}
6982 exec git branch
$name $id
6987 set headids
($name) $id
6988 lappend idheads
($id) $name
6997 proc cherrypick
{} {
6998 global rowmenuid curview
7001 set oldhead
[exec git rev-parse HEAD
]
7002 set dheads
[descheads
$rowmenuid]
7003 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
7004 set ok
[confirm_popup
[mc
"Commit %s is already\
7005 included in branch %s -- really re-apply it?" \
7006 [string range
$rowmenuid 0 7] $mainhead]]
7009 nowbusy cherrypick
[mc
"Cherry-picking"]
7011 # Unfortunately git-cherry-pick writes stuff to stderr even when
7012 # no error occurs, and exec takes that as an indication of error...
7013 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
7018 set newhead
[exec git rev-parse HEAD
]
7019 if {$newhead eq
$oldhead} {
7021 error_popup
[mc
"No changes committed"]
7024 addnewchild
$newhead $oldhead
7025 if {[commitinview
$oldhead $curview]} {
7026 insertrow
$newhead $oldhead $curview
7027 if {$mainhead ne
{}} {
7028 movehead
$newhead $mainhead
7029 movedhead
$newhead $mainhead
7038 global mainheadid mainhead rowmenuid confirm_ok resettype
7041 set w
".confirmreset"
7044 wm title
$w [mc
"Confirm reset"]
7045 message
$w.m
-text \
7046 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
7047 -justify center
-aspect 1000
7048 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
7049 frame
$w.f
-relief sunken
-border 2
7050 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
7051 grid
$w.f.rt
-sticky w
7053 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
7054 -text [mc
"Soft: Leave working tree and index untouched"]
7055 grid
$w.f.soft
-sticky w
7056 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
7057 -text [mc
"Mixed: Leave working tree untouched, reset index"]
7058 grid
$w.f.mixed
-sticky w
7059 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
7060 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
7061 grid
$w.f.hard
-sticky w
7062 pack
$w.f
-side top
-fill x
7063 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
7064 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
7065 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
7066 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
7067 bind $w <Visibility
> "grab $w; focus $w"
7069 if {!$confirm_ok} return
7070 if {[catch
{set fd
[open \
7071 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
7075 filerun
$fd [list readresetstat
$fd]
7076 nowbusy
reset [mc
"Resetting"]
7080 proc readresetstat
{fd
} {
7081 global mainhead mainheadid showlocalchanges rprogcoord
7083 if {[gets
$fd line
] >= 0} {
7084 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
7085 set rprogcoord
[expr {1.0 * $m / $n}]
7093 if {[catch
{close
$fd} err
]} {
7096 set oldhead
$mainheadid
7097 set newhead
[exec git rev-parse HEAD
]
7098 if {$newhead ne
$oldhead} {
7099 movehead
$newhead $mainhead
7100 movedhead
$newhead $mainhead
7101 set mainheadid
$newhead
7105 if {$showlocalchanges} {
7111 # context menu for a head
7112 proc headmenu
{x y id
head} {
7113 global headmenuid headmenuhead headctxmenu mainhead
7117 set headmenuhead
$head
7119 if {$head eq
$mainhead} {
7122 $headctxmenu entryconfigure
0 -state $state
7123 $headctxmenu entryconfigure
1 -state $state
7124 tk_popup
$headctxmenu $x $y
7128 global headmenuid headmenuhead mainhead headids
7129 global showlocalchanges mainheadid
7131 # check the tree is clean first??
7132 set oldmainhead
$mainhead
7133 nowbusy checkout
[mc
"Checking out"]
7137 exec git checkout
-q $headmenuhead
7143 set mainhead
$headmenuhead
7144 set mainheadid
$headmenuid
7145 if {[info exists headids
($oldmainhead)]} {
7146 redrawtags
$headids($oldmainhead)
7148 redrawtags
$headmenuid
7150 if {$showlocalchanges} {
7156 global headmenuid headmenuhead mainhead
7159 set head $headmenuhead
7161 # this check shouldn't be needed any more...
7162 if {$head eq
$mainhead} {
7163 error_popup
[mc
"Cannot delete the currently checked-out branch"]
7166 set dheads
[descheads
$id]
7167 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
7168 # the stuff on this branch isn't on any other branch
7169 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
7170 branch.\nReally delete branch %s?" $head $head]]} return
7174 if {[catch
{exec git branch
-D $head} err
]} {
7179 removehead
$id $head
7180 removedhead
$id $head
7187 # Display a list of tags and heads
7189 global showrefstop bgcolor fgcolor selectbgcolor
7190 global bglist fglist reflistfilter reflist maincursor
7193 set showrefstop
$top
7194 if {[winfo exists
$top]} {
7200 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
7201 text
$top.list
-background $bgcolor -foreground $fgcolor \
7202 -selectbackground $selectbgcolor -font mainfont \
7203 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7204 -width 30 -height 20 -cursor $maincursor \
7205 -spacing1 1 -spacing3 1 -state disabled
7206 $top.list tag configure highlight
-background $selectbgcolor
7207 lappend bglist
$top.list
7208 lappend fglist
$top.list
7209 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
7210 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
7211 grid
$top.list
$top.ysb
-sticky nsew
7212 grid
$top.xsb x
-sticky ew
7214 label
$top.f.l
-text "[mc "Filter
"]: "
7215 entry
$top.f.e
-width 20 -textvariable reflistfilter
7216 set reflistfilter
"*"
7217 trace add variable reflistfilter
write reflistfilter_change
7218 pack
$top.f.e
-side right
-fill x
-expand 1
7219 pack
$top.f.l
-side left
7220 grid
$top.f
- -sticky ew
-pady 2
7221 button
$top.close
-command [list destroy
$top] -text [mc
"Close"]
7223 grid columnconfigure
$top 0 -weight 1
7224 grid rowconfigure
$top 0 -weight 1
7225 bind $top.list
<1> {break}
7226 bind $top.list
<B1-Motion
> {break}
7227 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
7232 proc sel_reflist
{w x y
} {
7233 global showrefstop reflist headids tagids otherrefids
7235 if {![winfo exists
$showrefstop]} return
7236 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
7237 set ref
[lindex
$reflist [expr {$l-1}]]
7238 set n
[lindex
$ref 0]
7239 switch
-- [lindex
$ref 1] {
7240 "H" {selbyid
$headids($n)}
7241 "T" {selbyid
$tagids($n)}
7242 "o" {selbyid
$otherrefids($n)}
7244 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
7247 proc unsel_reflist
{} {
7250 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7251 $showrefstop.list tag remove highlight
0.0 end
7254 proc reflistfilter_change
{n1 n2 op
} {
7255 global reflistfilter
7257 after cancel refill_reflist
7258 after
200 refill_reflist
7261 proc refill_reflist
{} {
7262 global reflist reflistfilter showrefstop headids tagids otherrefids
7263 global curview commitinterest
7265 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7267 foreach n
[array names headids
] {
7268 if {[string match
$reflistfilter $n]} {
7269 if {[commitinview
$headids($n) $curview]} {
7270 lappend refs
[list
$n H
]
7272 set commitinterest
($headids($n)) {run refill_reflist
}
7276 foreach n
[array names tagids
] {
7277 if {[string match
$reflistfilter $n]} {
7278 if {[commitinview
$tagids($n) $curview]} {
7279 lappend refs
[list
$n T
]
7281 set commitinterest
($tagids($n)) {run refill_reflist
}
7285 foreach n
[array names otherrefids
] {
7286 if {[string match
$reflistfilter $n]} {
7287 if {[commitinview
$otherrefids($n) $curview]} {
7288 lappend refs
[list
$n o
]
7290 set commitinterest
($otherrefids($n)) {run refill_reflist
}
7294 set refs
[lsort
-index 0 $refs]
7295 if {$refs eq
$reflist} return
7297 # Update the contents of $showrefstop.list according to the
7298 # differences between $reflist (old) and $refs (new)
7299 $showrefstop.list conf
-state normal
7300 $showrefstop.list insert end
"\n"
7303 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
7304 if {$i < [llength
$reflist]} {
7305 if {$j < [llength
$refs]} {
7306 set cmp [string compare
[lindex
$reflist $i 0] \
7307 [lindex
$refs $j 0]]
7309 set cmp [string compare
[lindex
$reflist $i 1] \
7310 [lindex
$refs $j 1]]
7320 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
7328 set l
[expr {$j + 1}]
7329 $showrefstop.list image create
$l.0 -align baseline \
7330 -image reficon-
[lindex
$refs $j 1] -padx 2
7331 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
7337 # delete last newline
7338 $showrefstop.list delete end-2c end-1c
7339 $showrefstop.list conf
-state disabled
7342 # Stuff for finding nearby tags
7343 proc getallcommits
{} {
7344 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7345 global idheads idtags idotherrefs allparents tagobjid
7347 if {![info exists allcommits
]} {
7353 set allccache
[file join [gitdir
] "gitk.cache"]
7355 set f
[open
$allccache r
]
7364 set cmd
[list | git rev-list
--parents]
7365 set allcupdate
[expr {$seeds ne
{}}]
7369 set refs
[concat
[array names idheads
] [array names idtags
] \
7370 [array names idotherrefs
]]
7373 foreach name
[array names tagobjid
] {
7374 lappend tagobjs
$tagobjid($name)
7376 foreach id
[lsort
-unique $refs] {
7377 if {![info exists allparents
($id)] &&
7378 [lsearch
-exact $tagobjs $id] < 0} {
7389 set fd
[open
[concat
$cmd $ids] r
]
7390 fconfigure
$fd -blocking 0
7393 filerun
$fd [list getallclines
$fd]
7399 # Since most commits have 1 parent and 1 child, we group strings of
7400 # such commits into "arcs" joining branch/merge points (BMPs), which
7401 # are commits that either don't have 1 parent or don't have 1 child.
7403 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7404 # arcout(id) - outgoing arcs for BMP
7405 # arcids(a) - list of IDs on arc including end but not start
7406 # arcstart(a) - BMP ID at start of arc
7407 # arcend(a) - BMP ID at end of arc
7408 # growing(a) - arc a is still growing
7409 # arctags(a) - IDs out of arcids (excluding end) that have tags
7410 # archeads(a) - IDs out of arcids (excluding end) that have heads
7411 # The start of an arc is at the descendent end, so "incoming" means
7412 # coming from descendents, and "outgoing" means going towards ancestors.
7414 proc getallclines
{fd
} {
7415 global allparents allchildren idtags idheads nextarc
7416 global arcnos arcids arctags arcout arcend arcstart archeads growing
7417 global seeds allcommits cachedarcs allcupdate
7420 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
7421 set id
[lindex
$line 0]
7422 if {[info exists allparents
($id)]} {
7427 set olds
[lrange
$line 1 end
]
7428 set allparents
($id) $olds
7429 if {![info exists allchildren
($id)]} {
7430 set allchildren
($id) {}
7435 if {[llength
$olds] == 1 && [llength
$a] == 1} {
7436 lappend arcids
($a) $id
7437 if {[info exists idtags
($id)]} {
7438 lappend arctags
($a) $id
7440 if {[info exists idheads
($id)]} {
7441 lappend archeads
($a) $id
7443 if {[info exists allparents
($olds)]} {
7444 # seen parent already
7445 if {![info exists arcout
($olds)]} {
7448 lappend arcids
($a) $olds
7449 set arcend
($a) $olds
7452 lappend allchildren
($olds) $id
7453 lappend arcnos
($olds) $a
7457 foreach a
$arcnos($id) {
7458 lappend arcids
($a) $id
7465 lappend allchildren
($p) $id
7466 set a
[incr nextarc
]
7467 set arcstart
($a) $id
7474 if {[info exists allparents
($p)]} {
7475 # seen it already, may need to make a new branch
7476 if {![info exists arcout
($p)]} {
7479 lappend arcids
($a) $p
7483 lappend arcnos
($p) $a
7488 global cached_dheads cached_dtags cached_atags
7489 catch
{unset cached_dheads
}
7490 catch
{unset cached_dtags
}
7491 catch
{unset cached_atags
}
7494 return [expr {$nid >= 1000?
2: 1}]
7498 fconfigure
$fd -blocking 1
7501 # got an error reading the list of commits
7502 # if we were updating, try rereading the whole thing again
7508 error_popup
"[mc "Error reading commit topology information
;\
7509 branch and preceding
/following tag information\
7510 will be incomplete.
"]\n($err)"
7513 if {[incr allcommits
-1] == 0} {
7523 proc recalcarc
{a
} {
7524 global arctags archeads arcids idtags idheads
7528 foreach id
[lrange
$arcids($a) 0 end-1
] {
7529 if {[info exists idtags
($id)]} {
7532 if {[info exists idheads
($id)]} {
7537 set archeads
($a) $ah
7541 global arcnos arcids nextarc arctags archeads idtags idheads
7542 global arcstart arcend arcout allparents growing
7545 if {[llength
$a] != 1} {
7546 puts
"oops splitarc called but [llength $a] arcs already"
7550 set i
[lsearch
-exact $arcids($a) $p]
7552 puts
"oops splitarc $p not in arc $a"
7555 set na
[incr nextarc
]
7556 if {[info exists arcend
($a)]} {
7557 set arcend
($na) $arcend($a)
7559 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
7560 set j
[lsearch
-exact $arcnos($l) $a]
7561 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
7563 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
7564 set arcids
($a) [lrange
$arcids($a) 0 $i]
7566 set arcstart
($na) $p
7568 set arcids
($na) $tail
7569 if {[info exists growing
($a)]} {
7575 if {[llength
$arcnos($id)] == 1} {
7578 set j
[lsearch
-exact $arcnos($id) $a]
7579 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
7583 # reconstruct tags and heads lists
7584 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
7589 set archeads
($na) {}
7593 # Update things for a new commit added that is a child of one
7594 # existing commit. Used when cherry-picking.
7595 proc addnewchild
{id p
} {
7596 global allparents allchildren idtags nextarc
7597 global arcnos arcids arctags arcout arcend arcstart archeads growing
7598 global seeds allcommits
7600 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
7601 set allparents
($id) [list
$p]
7602 set allchildren
($id) {}
7605 lappend allchildren
($p) $id
7606 set a
[incr nextarc
]
7607 set arcstart
($a) $id
7610 set arcids
($a) [list
$p]
7612 if {![info exists arcout
($p)]} {
7615 lappend arcnos
($p) $a
7616 set arcout
($id) [list
$a]
7619 # This implements a cache for the topology information.
7620 # The cache saves, for each arc, the start and end of the arc,
7621 # the ids on the arc, and the outgoing arcs from the end.
7622 proc readcache
{f
} {
7623 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7624 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7629 if {$lim - $a > 500} {
7630 set lim
[expr {$a + 500}]
7634 # finish reading the cache and setting up arctags, etc.
7636 if {$line ne
"1"} {error
"bad final version"}
7638 foreach id
[array names idtags
] {
7639 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7640 [llength
$allparents($id)] == 1} {
7641 set a
[lindex
$arcnos($id) 0]
7642 if {$arctags($a) eq
{}} {
7647 foreach id
[array names idheads
] {
7648 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7649 [llength
$allparents($id)] == 1} {
7650 set a
[lindex
$arcnos($id) 0]
7651 if {$archeads($a) eq
{}} {
7656 foreach id
[lsort
-unique $possible_seeds] {
7657 if {$arcnos($id) eq
{}} {
7663 while {[incr a
] <= $lim} {
7665 if {[llength
$line] != 3} {error
"bad line"}
7666 set s
[lindex
$line 0]
7668 lappend arcout
($s) $a
7669 if {![info exists arcnos
($s)]} {
7670 lappend possible_seeds
$s
7673 set e
[lindex
$line 1]
7678 if {![info exists arcout
($e)]} {
7682 set arcids
($a) [lindex
$line 2]
7683 foreach id
$arcids($a) {
7684 lappend allparents
($s) $id
7686 lappend arcnos
($id) $a
7688 if {![info exists allparents
($s)]} {
7689 set allparents
($s) {}
7694 set nextarc
[expr {$a - 1}]
7707 global nextarc cachedarcs possible_seeds
7711 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7712 # make sure it's an integer
7713 set cachedarcs
[expr {int
([lindex
$line 1])}]
7714 if {$cachedarcs < 0} {error
"bad number of arcs"}
7716 set possible_seeds
{}
7724 proc dropcache
{err
} {
7725 global allcwait nextarc cachedarcs seeds
7727 #puts "dropping cache ($err)"
7728 foreach v
{arcnos arcout arcids arcstart arcend growing \
7729 arctags archeads allparents allchildren
} {
7740 proc writecache
{f
} {
7741 global cachearc cachedarcs allccache
7742 global arcstart arcend arcnos arcids arcout
7746 if {$lim - $a > 1000} {
7747 set lim
[expr {$a + 1000}]
7750 while {[incr a
] <= $lim} {
7751 if {[info exists arcend
($a)]} {
7752 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7754 puts
$f [list
$arcstart($a) {} $arcids($a)]
7759 catch
{file delete
$allccache}
7760 #puts "writing cache failed ($err)"
7763 set cachearc
[expr {$a - 1}]
7764 if {$a > $cachedarcs} {
7773 global nextarc cachedarcs cachearc allccache
7775 if {$nextarc == $cachedarcs} return
7777 set cachedarcs
$nextarc
7779 set f
[open
$allccache w
]
7780 puts
$f [list
1 $cachedarcs]
7785 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7786 # or 0 if neither is true.
7787 proc anc_or_desc
{a b
} {
7788 global arcout arcstart arcend arcnos cached_isanc
7790 if {$arcnos($a) eq
$arcnos($b)} {
7791 # Both are on the same arc(s); either both are the same BMP,
7792 # or if one is not a BMP, the other is also not a BMP or is
7793 # the BMP at end of the arc (and it only has 1 incoming arc).
7794 # Or both can be BMPs with no incoming arcs.
7795 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7798 # assert {[llength $arcnos($a)] == 1}
7799 set arc
[lindex
$arcnos($a) 0]
7800 set i
[lsearch
-exact $arcids($arc) $a]
7801 set j
[lsearch
-exact $arcids($arc) $b]
7802 if {$i < 0 ||
$i > $j} {
7809 if {![info exists arcout
($a)]} {
7810 set arc
[lindex
$arcnos($a) 0]
7811 if {[info exists arcend
($arc)]} {
7812 set aend
$arcend($arc)
7816 set a
$arcstart($arc)
7820 if {![info exists arcout
($b)]} {
7821 set arc
[lindex
$arcnos($b) 0]
7822 if {[info exists arcend
($arc)]} {
7823 set bend
$arcend($arc)
7827 set b
$arcstart($arc)
7837 if {[info exists cached_isanc
($a,$bend)]} {
7838 if {$cached_isanc($a,$bend)} {
7842 if {[info exists cached_isanc
($b,$aend)]} {
7843 if {$cached_isanc($b,$aend)} {
7846 if {[info exists cached_isanc
($a,$bend)]} {
7851 set todo
[list
$a $b]
7854 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7855 set x
[lindex
$todo $i]
7856 if {$anc($x) eq
{}} {
7859 foreach arc
$arcnos($x) {
7860 set xd
$arcstart($arc)
7862 set cached_isanc
($a,$bend) 1
7863 set cached_isanc
($b,$aend) 0
7865 } elseif
{$xd eq
$aend} {
7866 set cached_isanc
($b,$aend) 1
7867 set cached_isanc
($a,$bend) 0
7870 if {![info exists anc
($xd)]} {
7871 set anc
($xd) $anc($x)
7873 } elseif
{$anc($xd) ne
$anc($x)} {
7878 set cached_isanc
($a,$bend) 0
7879 set cached_isanc
($b,$aend) 0
7883 # This identifies whether $desc has an ancestor that is
7884 # a growing tip of the graph and which is not an ancestor of $anc
7885 # and returns 0 if so and 1 if not.
7886 # If we subsequently discover a tag on such a growing tip, and that
7887 # turns out to be a descendent of $anc (which it could, since we
7888 # don't necessarily see children before parents), then $desc
7889 # isn't a good choice to display as a descendent tag of
7890 # $anc (since it is the descendent of another tag which is
7891 # a descendent of $anc). Similarly, $anc isn't a good choice to
7892 # display as a ancestor tag of $desc.
7894 proc is_certain
{desc anc
} {
7895 global arcnos arcout arcstart arcend growing problems
7898 if {[llength
$arcnos($anc)] == 1} {
7899 # tags on the same arc are certain
7900 if {$arcnos($desc) eq
$arcnos($anc)} {
7903 if {![info exists arcout
($anc)]} {
7904 # if $anc is partway along an arc, use the start of the arc instead
7905 set a
[lindex
$arcnos($anc) 0]
7906 set anc
$arcstart($a)
7909 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7912 set a
[lindex
$arcnos($desc) 0]
7918 set anclist
[list
$x]
7922 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7923 set x
[lindex
$anclist $i]
7928 foreach a
$arcout($x) {
7929 if {[info exists growing
($a)]} {
7930 if {![info exists growanc
($x)] && $dl($x)} {
7936 if {[info exists dl
($y)]} {
7940 if {![info exists
done($y)]} {
7943 if {[info exists growanc
($x)]} {
7947 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7948 set z
[lindex
$xl $k]
7949 foreach c
$arcout($z) {
7950 if {[info exists arcend
($c)]} {
7952 if {[info exists dl
($v)] && $dl($v)} {
7954 if {![info exists
done($v)]} {
7957 if {[info exists growanc
($v)]} {
7967 } elseif
{$y eq
$anc ||
!$dl($x)} {
7978 foreach x
[array names growanc
] {
7987 proc validate_arctags
{a
} {
7988 global arctags idtags
7992 foreach id
$arctags($a) {
7994 if {![info exists idtags
($id)]} {
7995 set na
[lreplace
$na $i $i]
8002 proc validate_archeads
{a
} {
8003 global archeads idheads
8006 set na
$archeads($a)
8007 foreach id
$archeads($a) {
8009 if {![info exists idheads
($id)]} {
8010 set na
[lreplace
$na $i $i]
8014 set archeads
($a) $na
8017 # Return the list of IDs that have tags that are descendents of id,
8018 # ignoring IDs that are descendents of IDs already reported.
8019 proc desctags
{id
} {
8020 global arcnos arcstart arcids arctags idtags allparents
8021 global growing cached_dtags
8023 if {![info exists allparents
($id)]} {
8026 set t1
[clock clicks
-milliseconds]
8028 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8029 # part-way along an arc; check that arc first
8030 set a
[lindex
$arcnos($id) 0]
8031 if {$arctags($a) ne
{}} {
8033 set i
[lsearch
-exact $arcids($a) $id]
8035 foreach t
$arctags($a) {
8036 set j
[lsearch
-exact $arcids($a) $t]
8044 set id
$arcstart($a)
8045 if {[info exists idtags
($id)]} {
8049 if {[info exists cached_dtags
($id)]} {
8050 return $cached_dtags($id)
8057 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8058 set id
[lindex
$todo $i]
8060 set ta
[info exists hastaggedancestor
($id)]
8064 # ignore tags on starting node
8065 if {!$ta && $i > 0} {
8066 if {[info exists idtags
($id)]} {
8069 } elseif
{[info exists cached_dtags
($id)]} {
8070 set tagloc
($id) $cached_dtags($id)
8074 foreach a
$arcnos($id) {
8076 if {!$ta && $arctags($a) ne
{}} {
8078 if {$arctags($a) ne
{}} {
8079 lappend tagloc
($id) [lindex
$arctags($a) end
]
8082 if {$ta ||
$arctags($a) ne
{}} {
8083 set tomark
[list
$d]
8084 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8085 set dd [lindex
$tomark $j]
8086 if {![info exists hastaggedancestor
($dd)]} {
8087 if {[info exists
done($dd)]} {
8088 foreach b
$arcnos($dd) {
8089 lappend tomark
$arcstart($b)
8091 if {[info exists tagloc
($dd)]} {
8094 } elseif
{[info exists queued
($dd)]} {
8097 set hastaggedancestor
($dd) 1
8101 if {![info exists queued
($d)]} {
8104 if {![info exists hastaggedancestor
($d)]} {
8111 foreach id
[array names tagloc
] {
8112 if {![info exists hastaggedancestor
($id)]} {
8113 foreach t
$tagloc($id) {
8114 if {[lsearch
-exact $tags $t] < 0} {
8120 set t2
[clock clicks
-milliseconds]
8123 # remove tags that are descendents of other tags
8124 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8125 set a
[lindex
$tags $i]
8126 for {set j
0} {$j < $i} {incr j
} {
8127 set b
[lindex
$tags $j]
8128 set r
[anc_or_desc
$a $b]
8130 set tags
[lreplace
$tags $j $j]
8133 } elseif
{$r == -1} {
8134 set tags
[lreplace
$tags $i $i]
8141 if {[array names growing
] ne
{}} {
8142 # graph isn't finished, need to check if any tag could get
8143 # eclipsed by another tag coming later. Simply ignore any
8144 # tags that could later get eclipsed.
8147 if {[is_certain
$t $origid]} {
8151 if {$tags eq
$ctags} {
8152 set cached_dtags
($origid) $tags
8157 set cached_dtags
($origid) $tags
8159 set t3
[clock clicks
-milliseconds]
8160 if {0 && $t3 - $t1 >= 100} {
8161 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
8162 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8168 global arcnos arcids arcout arcend arctags idtags allparents
8169 global growing cached_atags
8171 if {![info exists allparents
($id)]} {
8174 set t1
[clock clicks
-milliseconds]
8176 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8177 # part-way along an arc; check that arc first
8178 set a
[lindex
$arcnos($id) 0]
8179 if {$arctags($a) ne
{}} {
8181 set i
[lsearch
-exact $arcids($a) $id]
8182 foreach t
$arctags($a) {
8183 set j
[lsearch
-exact $arcids($a) $t]
8189 if {![info exists arcend
($a)]} {
8193 if {[info exists idtags
($id)]} {
8197 if {[info exists cached_atags
($id)]} {
8198 return $cached_atags($id)
8206 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8207 set id
[lindex
$todo $i]
8209 set td
[info exists hastaggeddescendent
($id)]
8213 # ignore tags on starting node
8214 if {!$td && $i > 0} {
8215 if {[info exists idtags
($id)]} {
8218 } elseif
{[info exists cached_atags
($id)]} {
8219 set tagloc
($id) $cached_atags($id)
8223 foreach a
$arcout($id) {
8224 if {!$td && $arctags($a) ne
{}} {
8226 if {$arctags($a) ne
{}} {
8227 lappend tagloc
($id) [lindex
$arctags($a) 0]
8230 if {![info exists arcend
($a)]} continue
8232 if {$td ||
$arctags($a) ne
{}} {
8233 set tomark
[list
$d]
8234 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8235 set dd [lindex
$tomark $j]
8236 if {![info exists hastaggeddescendent
($dd)]} {
8237 if {[info exists
done($dd)]} {
8238 foreach b
$arcout($dd) {
8239 if {[info exists arcend
($b)]} {
8240 lappend tomark
$arcend($b)
8243 if {[info exists tagloc
($dd)]} {
8246 } elseif
{[info exists queued
($dd)]} {
8249 set hastaggeddescendent
($dd) 1
8253 if {![info exists queued
($d)]} {
8256 if {![info exists hastaggeddescendent
($d)]} {
8262 set t2
[clock clicks
-milliseconds]
8265 foreach id
[array names tagloc
] {
8266 if {![info exists hastaggeddescendent
($id)]} {
8267 foreach t
$tagloc($id) {
8268 if {[lsearch
-exact $tags $t] < 0} {
8275 # remove tags that are ancestors of other tags
8276 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8277 set a
[lindex
$tags $i]
8278 for {set j
0} {$j < $i} {incr j
} {
8279 set b
[lindex
$tags $j]
8280 set r
[anc_or_desc
$a $b]
8282 set tags
[lreplace
$tags $j $j]
8285 } elseif
{$r == 1} {
8286 set tags
[lreplace
$tags $i $i]
8293 if {[array names growing
] ne
{}} {
8294 # graph isn't finished, need to check if any tag could get
8295 # eclipsed by another tag coming later. Simply ignore any
8296 # tags that could later get eclipsed.
8299 if {[is_certain
$origid $t]} {
8303 if {$tags eq
$ctags} {
8304 set cached_atags
($origid) $tags
8309 set cached_atags
($origid) $tags
8311 set t3
[clock clicks
-milliseconds]
8312 if {0 && $t3 - $t1 >= 100} {
8313 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
8314 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8319 # Return the list of IDs that have heads that are descendents of id,
8320 # including id itself if it has a head.
8321 proc descheads
{id
} {
8322 global arcnos arcstart arcids archeads idheads cached_dheads
8325 if {![info exists allparents
($id)]} {
8329 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8330 # part-way along an arc; check it first
8331 set a
[lindex
$arcnos($id) 0]
8332 if {$archeads($a) ne
{}} {
8333 validate_archeads
$a
8334 set i
[lsearch
-exact $arcids($a) $id]
8335 foreach t
$archeads($a) {
8336 set j
[lsearch
-exact $arcids($a) $t]
8341 set id
$arcstart($a)
8347 for {set i
0} {$i < [llength
$todo]} {incr i
} {
8348 set id
[lindex
$todo $i]
8349 if {[info exists cached_dheads
($id)]} {
8350 set ret
[concat
$ret $cached_dheads($id)]
8352 if {[info exists idheads
($id)]} {
8355 foreach a
$arcnos($id) {
8356 if {$archeads($a) ne
{}} {
8357 validate_archeads
$a
8358 if {$archeads($a) ne
{}} {
8359 set ret
[concat
$ret $archeads($a)]
8363 if {![info exists seen
($d)]} {
8370 set ret
[lsort
-unique $ret]
8371 set cached_dheads
($origid) $ret
8372 return [concat
$ret $aret]
8375 proc addedtag
{id
} {
8376 global arcnos arcout cached_dtags cached_atags
8378 if {![info exists arcnos
($id)]} return
8379 if {![info exists arcout
($id)]} {
8380 recalcarc
[lindex
$arcnos($id) 0]
8382 catch
{unset cached_dtags
}
8383 catch
{unset cached_atags
}
8386 proc addedhead
{hid
head} {
8387 global arcnos arcout cached_dheads
8389 if {![info exists arcnos
($hid)]} return
8390 if {![info exists arcout
($hid)]} {
8391 recalcarc
[lindex
$arcnos($hid) 0]
8393 catch
{unset cached_dheads
}
8396 proc removedhead
{hid
head} {
8397 global cached_dheads
8399 catch
{unset cached_dheads
}
8402 proc movedhead
{hid
head} {
8403 global arcnos arcout cached_dheads
8405 if {![info exists arcnos
($hid)]} return
8406 if {![info exists arcout
($hid)]} {
8407 recalcarc
[lindex
$arcnos($hid) 0]
8409 catch
{unset cached_dheads
}
8412 proc changedrefs
{} {
8413 global cached_dheads cached_dtags cached_atags
8414 global arctags archeads arcnos arcout idheads idtags
8416 foreach id
[concat
[array names idheads
] [array names idtags
]] {
8417 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
8418 set a
[lindex
$arcnos($id) 0]
8419 if {![info exists donearc
($a)]} {
8425 catch
{unset cached_dtags
}
8426 catch
{unset cached_atags
}
8427 catch
{unset cached_dheads
}
8430 proc rereadrefs
{} {
8431 global idtags idheads idotherrefs mainheadid
8433 set refids
[concat
[array names idtags
] \
8434 [array names idheads
] [array names idotherrefs
]]
8435 foreach id
$refids {
8436 if {![info exists ref
($id)]} {
8437 set ref
($id) [listrefs
$id]
8440 set oldmainhead
$mainheadid
8443 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
8444 [array names idheads
] [array names idotherrefs
]]]
8445 foreach id
$refids {
8446 set v
[listrefs
$id]
8447 if {![info exists ref
($id)] ||
$ref($id) != $v ||
8448 ($id eq
$oldmainhead && $id ne
$mainheadid) ||
8449 ($id eq
$mainheadid && $id ne
$oldmainhead)} {
8456 proc listrefs
{id
} {
8457 global idtags idheads idotherrefs
8460 if {[info exists idtags
($id)]} {
8464 if {[info exists idheads
($id)]} {
8468 if {[info exists idotherrefs
($id)]} {
8469 set z
$idotherrefs($id)
8471 return [list
$x $y $z]
8474 proc showtag
{tag isnew
} {
8475 global ctext tagcontents tagids linknum tagobjid
8478 addtohistory
[list showtag
$tag 0]
8480 $ctext conf
-state normal
8484 if {![info exists tagcontents
($tag)]} {
8486 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
8489 if {[info exists tagcontents
($tag)]} {
8490 set text
$tagcontents($tag)
8492 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
8494 appendwithlinks
$text {}
8495 $ctext conf
-state disabled
8506 proc mkfontdisp
{font top
which} {
8507 global fontattr fontpref
$font
8509 set fontpref
($font) [set $font]
8510 button
$top.
${font}but
-text $which -font optionfont \
8511 -command [list choosefont
$font $which]
8512 label
$top.
$font -relief flat
-font $font \
8513 -text $fontattr($font,family
) -justify left
8514 grid x
$top.
${font}but
$top.
$font -sticky w
8517 proc choosefont
{font
which} {
8518 global fontparam fontlist fonttop fontattr
8520 set fontparam
(which) $which
8521 set fontparam
(font
) $font
8522 set fontparam
(family
) [font actual
$font -family]
8523 set fontparam
(size
) $fontattr($font,size
)
8524 set fontparam
(weight
) $fontattr($font,weight
)
8525 set fontparam
(slant
) $fontattr($font,slant
)
8528 if {![winfo exists
$top]} {
8530 eval font config sample
[font actual
$font]
8532 wm title
$top [mc
"Gitk font chooser"]
8533 label
$top.l
-textvariable fontparam
(which)
8534 pack
$top.l
-side top
8535 set fontlist
[lsort
[font families
]]
8537 listbox
$top.f.fam
-listvariable fontlist \
8538 -yscrollcommand [list
$top.f.sb
set]
8539 bind $top.f.fam
<<ListboxSelect>> selfontfam
8540 scrollbar $top.f.sb -command [list $top.f.fam yview]
8541 pack $top.f.sb -side right -fill y
8542 pack $top.f.fam -side left -fill both -expand 1
8543 pack $top.f -side top -fill both -expand 1
8545 spinbox $top.g.size -from 4 -to 40 -width 4 \
8546 -textvariable fontparam(size) \
8547 -validatecommand {string is integer -strict %s}
8548 checkbutton $top.g.bold -padx 5 \
8549 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8550 -variable fontparam(weight) -onvalue bold -offvalue normal
8551 checkbutton $top.g.ital -padx 5 \
8552 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8553 -variable fontparam(slant) -onvalue italic -offvalue roman
8554 pack $top.g.size $top.g.bold $top.g.ital -side left
8555 pack $top.g -side top
8556 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8558 $top.c create text 100 25 -anchor center -text $which -font sample \
8559 -fill black -tags text
8560 bind $top.c <Configure> [list centertext $top.c]
8561 pack $top.c -side top -fill x
8563 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8564 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8565 grid $top.buts.ok $top.buts.can
8566 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8567 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8568 pack $top.buts -side bottom -fill x
8569 trace add variable fontparam write chg_fontparam
8572 $top.c itemconf text -text $which
8574 set i [lsearch -exact $fontlist $fontparam(family)]
8576 $top.f.fam selection set $i
8581 proc centertext {w} {
8582 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8586 global fontparam fontpref prefstop
8588 set f $fontparam(font)
8589 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8590 if {$fontparam(weight) eq "bold"} {
8591 lappend fontpref($f) "bold"
8593 if {$fontparam(slant) eq "italic"} {
8594 lappend fontpref($f) "italic"
8597 $w conf -text $fontparam(family) -font $fontpref($f)
8603 global fonttop fontparam
8605 if {[info exists fonttop]} {
8606 catch {destroy $fonttop}
8607 catch {font delete sample}
8613 proc selfontfam {} {
8614 global fonttop fontparam
8616 set i [$fonttop.f.fam curselection]
8618 set fontparam(family) [$fonttop.f.fam get $i]
8622 proc chg_fontparam {v sub op} {
8625 font config sample -$sub $fontparam($sub)
8629 global maxwidth maxgraphpct
8630 global oldprefs prefstop showneartags showlocalchanges
8631 global bgcolor fgcolor ctext diffcolors selectbgcolor
8632 global tabstop limitdiffs
8636 if {[winfo exists $top]} {
8640 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8641 limitdiffs tabstop} {
8642 set oldprefs($v) [set $v]
8645 wm title $top [mc "Gitk preferences"]
8646 label $top.ldisp -text [mc "Commit list display options"]
8647 grid $top.ldisp - -sticky w -pady 10
8648 label $top.spacer -text " "
8649 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8651 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8652 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8653 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8655 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8656 grid x $top.maxpctl $top.maxpct -sticky w
8657 frame $top.showlocal
8658 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8659 checkbutton $top.showlocal.b -variable showlocalchanges
8660 pack $top.showlocal.b $top.showlocal.l -side left
8661 grid x $top.showlocal -sticky w
8663 label $top.ddisp -text [mc "Diff display options"]
8664 grid $top.ddisp - -sticky w -pady 10
8665 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8666 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8667 grid x $top.tabstopl $top.tabstop -sticky w
8669 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8670 checkbutton $top.ntag.b -variable showneartags
8671 pack $top.ntag.b $top.ntag.l -side left
8672 grid x $top.ntag -sticky w
8674 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8675 checkbutton $top.ldiff.b -variable limitdiffs
8676 pack $top.ldiff.b $top.ldiff.l -side left
8677 grid x $top.ldiff -sticky w
8679 label $top.cdisp -text [mc "Colors: press to choose"]
8680 grid $top.cdisp - -sticky w -pady 10
8681 label $top.bg -padx 40 -relief sunk -background $bgcolor
8682 button $top.bgbut -text [mc "Background"] -font optionfont \
8683 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8684 grid x $top.bgbut $top.bg -sticky w
8685 label $top.fg -padx 40 -relief sunk -background $fgcolor
8686 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8687 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8688 grid x $top.fgbut $top.fg -sticky w
8689 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8690 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8691 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8692 [list $ctext tag conf d0 -foreground]]
8693 grid x $top.diffoldbut $top.diffold -sticky w
8694 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8695 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8696 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8697 [list $ctext tag conf d1 -foreground]]
8698 grid x $top.diffnewbut $top.diffnew -sticky w
8699 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8700 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8701 -command [list choosecolor diffcolors 2 $top.hunksep \
8702 "diff hunk header" \
8703 [list $ctext tag conf hunksep -foreground]]
8704 grid x $top.hunksepbut $top.hunksep -sticky w
8705 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8706 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8707 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8708 grid x $top.selbgbut $top.selbgsep -sticky w
8710 label $top.cfont -text [mc "Fonts: press to choose"]
8711 grid $top.cfont - -sticky w -pady 10
8712 mkfontdisp mainfont $top [mc "Main font"]
8713 mkfontdisp textfont $top [mc "Diff display font"]
8714 mkfontdisp uifont $top [mc "User interface font"]
8717 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8718 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8719 grid $top.buts.ok $top.buts.can
8720 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8721 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8722 grid $top.buts - - -pady 10 -sticky ew
8723 bind $top <Visibility> "focus $top.buts.ok"
8726 proc choosecolor {v vi w x cmd} {
8729 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8730 -title [mc "Gitk: choose color for %s" $x]]
8731 if {$c eq {}} return
8732 $w conf -background $c
8738 global bglist cflist
8740 $w configure -selectbackground $c
8742 $cflist tag configure highlight \
8743 -background [$cflist cget -selectbackground]
8744 allcanvs itemconf secsel -fill $c
8751 $w conf -background $c
8759 $w conf -foreground $c
8761 allcanvs itemconf text -fill $c
8762 $canv itemconf circle -outline $c
8766 global oldprefs prefstop
8768 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8769 limitdiffs tabstop} {
8771 set $v $oldprefs($v)
8773 catch {destroy $prefstop}
8779 global maxwidth maxgraphpct
8780 global oldprefs prefstop showneartags showlocalchanges
8781 global fontpref mainfont textfont uifont
8782 global limitdiffs treediffs
8784 catch {destroy $prefstop}
8788 if {$mainfont ne $fontpref(mainfont)} {
8789 set mainfont $fontpref(mainfont)
8790 parsefont mainfont $mainfont
8791 eval font configure mainfont [fontflags mainfont]
8792 eval font configure mainfontbold [fontflags mainfont 1]
8796 if {$textfont ne $fontpref(textfont)} {
8797 set textfont $fontpref(textfont)
8798 parsefont textfont $textfont
8799 eval font configure textfont [fontflags textfont]
8800 eval font configure textfontbold [fontflags textfont 1]
8802 if {$uifont ne $fontpref(uifont)} {
8803 set uifont $fontpref(uifont)
8804 parsefont uifont $uifont
8805 eval font configure uifont [fontflags uifont]
8808 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8809 if {$showlocalchanges} {
8815 if {$limitdiffs != $oldprefs(limitdiffs)} {
8816 # treediffs elements are limited by path
8817 catch {unset treediffs}
8819 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8820 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8822 } elseif {$showneartags != $oldprefs(showneartags) ||
8823 $limitdiffs != $oldprefs(limitdiffs)} {
8828 proc formatdate {d} {
8829 global datetimeformat
8831 set d [clock format $d -format $datetimeformat]
8836 # This list of encoding names and aliases is distilled from
8837 # http://www.iana.org/assignments/character-sets.
8838 # Not all of them are supported by Tcl.
8839 set encoding_aliases {
8840 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8841 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8842 { ISO-10646-UTF-1 csISO10646UTF1 }
8843 { ISO_646.basic:1983 ref csISO646basic1983 }
8844 { INVARIANT csINVARIANT }
8845 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8846 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8847 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8848 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8849 { NATS-DANO iso-ir-9-1 csNATSDANO }
8850 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8851 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8852 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8853 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8854 { ISO-2022-KR csISO2022KR }
8856 { ISO-2022-JP csISO2022JP }
8857 { ISO-2022-JP-2 csISO2022JP2 }
8858 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8860 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8861 { IT iso-ir-15 ISO646-IT csISO15Italian }
8862 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8863 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8864 { greek7-old iso-ir-18 csISO18Greek7Old }
8865 { latin-greek iso-ir-19 csISO19LatinGreek }
8866 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8867 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8868 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8869 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8870 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8871 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8872 { INIS iso-ir-49 csISO49INIS }
8873 { INIS-8 iso-ir-50 csISO50INIS8 }
8874 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8875 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8876 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8877 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8878 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8879 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8881 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8882 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8883 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8884 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8885 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8886 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8887 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8888 { greek7 iso-ir-88 csISO88Greek7 }
8889 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8890 { iso-ir-90 csISO90 }
8891 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8892 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8893 csISO92JISC62991984b }
8894 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8895 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8896 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8897 csISO95JIS62291984handadd }
8898 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8899 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8900 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8901 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8903 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8904 { T.61-7bit iso-ir-102 csISO102T617bit }
8905 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8906 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8907 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8908 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8909 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8910 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8911 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8912 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8913 arabic csISOLatinArabic }
8914 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8915 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8916 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8917 greek greek8 csISOLatinGreek }
8918 { T.101-G2 iso-ir-128 csISO128T101G2 }
8919 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8921 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8922 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8923 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8924 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8925 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8926 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8927 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8928 csISOLatinCyrillic }
8929 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8930 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8931 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8932 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8933 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8934 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8935 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8936 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8937 { ISO_10367-box iso-ir-155 csISO10367Box }
8938 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8939 { latin-lap lap iso-ir-158 csISO158Lap }
8940 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8941 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8944 { JIS_X0201 X0201 csHalfWidthKatakana }
8945 { KSC5636 ISO646-KR csKSC5636 }
8946 { ISO-10646-UCS-2 csUnicode }
8947 { ISO-10646-UCS-4 csUCS4 }
8948 { DEC-MCS dec csDECMCS }
8949 { hp-roman8 roman8 r8 csHPRoman8 }
8950 { macintosh mac csMacintosh }
8951 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8953 { IBM038 EBCDIC-INT cp038 csIBM038 }
8954 { IBM273 CP273 csIBM273 }
8955 { IBM274 EBCDIC-BE CP274 csIBM274 }
8956 { IBM275 EBCDIC-BR cp275 csIBM275 }
8957 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8958 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8959 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8960 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8961 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8962 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8963 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8964 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8965 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8966 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8967 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8968 { IBM437 cp437 437 csPC8CodePage437 }
8969 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8970 { IBM775 cp775 csPC775Baltic }
8971 { IBM850 cp850 850 csPC850Multilingual }
8972 { IBM851 cp851 851 csIBM851 }
8973 { IBM852 cp852 852 csPCp852 }
8974 { IBM855 cp855 855 csIBM855 }
8975 { IBM857 cp857 857 csIBM857 }
8976 { IBM860 cp860 860 csIBM860 }
8977 { IBM861 cp861 861 cp-is csIBM861 }
8978 { IBM862 cp862 862 csPC862LatinHebrew }
8979 { IBM863 cp863 863 csIBM863 }
8980 { IBM864 cp864 csIBM864 }
8981 { IBM865 cp865 865 csIBM865 }
8982 { IBM866 cp866 866 csIBM866 }
8983 { IBM868 CP868 cp-ar csIBM868 }
8984 { IBM869 cp869 869 cp-gr csIBM869 }
8985 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8986 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8987 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8988 { IBM891 cp891 csIBM891 }
8989 { IBM903 cp903 csIBM903 }
8990 { IBM904 cp904 904 csIBBM904 }
8991 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8992 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8993 { IBM1026 CP1026 csIBM1026 }
8994 { EBCDIC-AT-DE csIBMEBCDICATDE }
8995 { EBCDIC-AT-DE-A csEBCDICATDEA }
8996 { EBCDIC-CA-FR csEBCDICCAFR }
8997 { EBCDIC-DK-NO csEBCDICDKNO }
8998 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8999 { EBCDIC-FI-SE csEBCDICFISE }
9000 { EBCDIC-FI-SE-A csEBCDICFISEA }
9001 { EBCDIC-FR csEBCDICFR }
9002 { EBCDIC-IT csEBCDICIT }
9003 { EBCDIC-PT csEBCDICPT }
9004 { EBCDIC-ES csEBCDICES }
9005 { EBCDIC-ES-A csEBCDICESA }
9006 { EBCDIC-ES-S csEBCDICESS }
9007 { EBCDIC-UK csEBCDICUK }
9008 { EBCDIC-US csEBCDICUS }
9009 { UNKNOWN-8BIT csUnknown8BiT }
9010 { MNEMONIC csMnemonic }
9015 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9016 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9017 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9018 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9019 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9020 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9021 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9022 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9023 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9024 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9025 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9026 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9027 { IBM1047 IBM-1047 }
9028 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9029 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9030 { UNICODE-1-1 csUnicode11 }
9033 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9034 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9036 { ISO-8859-15 ISO_8859-15 Latin-9 }
9037 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9038 { GBK CP936 MS936 windows-936 }
9039 { JIS_Encoding csJISEncoding }
9040 { Shift_JIS MS_Kanji csShiftJIS }
9041 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9043 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9044 { ISO-10646-UCS-Basic csUnicodeASCII }
9045 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9046 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9047 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9048 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9049 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9050 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9051 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9052 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9053 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9054 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9055 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9056 { Ventura-US csVenturaUS }
9057 { Ventura-International csVenturaInternational }
9058 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9059 { PC8-Turkish csPC8Turkish }
9060 { IBM-Symbols csIBMSymbols }
9061 { IBM-Thai csIBMThai }
9062 { HP-Legal csHPLegal }
9063 { HP-Pi-font csHPPiFont }
9064 { HP-Math8 csHPMath8 }
9065 { Adobe-Symbol-Encoding csHPPSMath }
9066 { HP-DeskTop csHPDesktop }
9067 { Ventura-Math csVenturaMath }
9068 { Microsoft-Publishing csMicrosoftPublishing }
9069 { Windows-31J csWindows31J }
9074 proc tcl_encoding {enc} {
9075 global encoding_aliases
9076 set names [encoding names]
9077 set lcnames [string tolower $names]
9078 set enc [string tolower $enc]
9079 set i [lsearch -exact $lcnames $enc]
9081 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9082 if {[regsub {^iso[-_]} $enc iso encx]} {
9083 set i [lsearch -exact $lcnames $encx]
9087 foreach l $encoding_aliases {
9088 set ll [string tolower $l]
9089 if {[lsearch -exact $ll $enc] < 0} continue
9090 # look through the aliases for one that tcl knows about
9092 set i [lsearch -exact $lcnames $e]
9094 if {[regsub {^iso[-_]} $e iso ex]} {
9095 set i [lsearch -exact $lcnames $ex]
9104 return [lindex $names $i]
9109 # First check that Tcl/Tk is recent enough
9110 if {[catch {package require Tk 8.4} err]} {
9111 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9112 Gitk requires at least Tcl/Tk 8.4."]
9118 set wrcomcmd "git diff-tree --stdin -p --pretty"
9122 set gitencoding [exec git config --get i18n.commitencoding]
9124 if {$gitencoding == ""} {
9125 set gitencoding "utf-8"
9127 set tclencoding [tcl_encoding $gitencoding]
9128 if {$tclencoding == {}} {
9129 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9132 set mainfont {Helvetica 9}
9133 set textfont {Courier 9}
9134 set uifont {Helvetica 9 bold}
9136 set findmergefiles 0
9144 set cmitmode "patch"
9145 set wrapcomment "none"
9149 set showlocalchanges 1
9151 set datetimeformat "%Y-%m-%d %H:%M:%S"
9153 set colors {green red blue magenta darkgrey brown orange}
9156 set diffcolors {red "#00a000" blue}
9158 set selectbgcolor gray85
9160 ## For msgcat loading, first locate the installation location.
9161 if { [info exists ::env(GITK_MSGSDIR)] } {
9162 ## Msgsdir was manually set in the environment.
9163 set gitk_msgsdir $::env(GITK_MSGSDIR)
9165 ## Let's guess the prefix from argv0.
9166 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9167 set gitk_libdir [file join $gitk_prefix share gitk lib]
9168 set gitk_msgsdir [file join $gitk_libdir msgs]
9172 ## Internationalization (i18n) through msgcat and gettext. See
9173 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9174 package require msgcat
9175 namespace import ::msgcat::mc
9176 ## And eventually load the actual message catalog
9177 ::msgcat::mcload $gitk_msgsdir
9179 catch {source ~/.gitk}
9181 font create optionfont -family sans-serif -size -12
9183 parsefont mainfont $mainfont
9184 eval font create mainfont [fontflags mainfont]
9185 eval font create mainfontbold [fontflags mainfont 1]
9187 parsefont textfont $textfont
9188 eval font create textfont [fontflags textfont]
9189 eval font create textfontbold [fontflags textfont 1]
9191 parsefont uifont $uifont
9192 eval font create uifont [fontflags uifont]
9196 # check that we can find a .git directory somewhere...
9197 if {[catch {set gitdir [gitdir]}]} {
9198 show_error {} . [mc "Cannot find a git repository here."]
9201 if {![file isdirectory $gitdir]} {
9202 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9208 set cmdline_files {}
9213 "-d" { set datemode 1 }
9216 lappend revtreeargs $arg
9219 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9223 lappend revtreeargs $arg
9229 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9230 # no -- on command line, but some arguments (other than -d)
9232 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9233 set cmdline_files [split $f "\n"]
9234 set n [llength $cmdline_files]
9235 set revtreeargs [lrange $revtreeargs 0 end-$n]
9236 # Unfortunately git rev-parse doesn't produce an error when
9237 # something is both a revision and a filename. To be consistent
9238 # with git log and git rev-list, check revtreeargs for filenames.
9239 foreach arg $revtreeargs {
9240 if {[file exists $arg]} {
9241 show_error {} . [mc "Ambiguous argument '%s': both revision\
9247 # unfortunately we get both stdout and stderr in $err,
9248 # so look for "fatal:".
9249 set i [string first "fatal:" $err]
9251 set err [string range $err [expr {$i + 6}] end]
9253 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9259 # find the list of unmerged files
9263 set fd [open "| git ls-files -u" r]
9265 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9268 while {[gets $fd line] >= 0} {
9269 set i [string first "\t" $line]
9270 if {$i < 0} continue
9271 set fname [string range $line [expr {$i+1}] end]
9272 if {[lsearch -exact $mlist $fname] >= 0} continue
9274 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9275 lappend mlist $fname
9280 if {$nr_unmerged == 0} {
9281 show_error {} . [mc "No files selected: --merge specified but\
9282 no files are unmerged."]
9284 show_error {} . [mc "No files selected: --merge specified but\
9285 no unmerged files are within file limit."]
9289 set cmdline_files $mlist
9292 set nullid "0000000000000000000000000000000000000000"
9293 set nullid2 "0000000000000000000000000000000000000001"
9295 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9302 set highlight_paths {}
9304 set searchdirn -forwards
9308 set markingmatches 0
9309 set linkentercount 0
9310 set need_redisplay 0
9317 set selectedhlview [mc "None"]
9318 set highlight_related [mc "None"]
9319 set highlight_files {}
9332 # wait for the window to become visible
9334 wm title . "[file tail $argv0]: [file tail [pwd]]"
9337 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9338 # create a view for the files/dirs specified on the command line
9342 set viewname(1) [mc "Command line"]
9343 set viewfiles(1) $cmdline_files
9344 set viewargs(1) $revtreeargs
9347 .bar.view entryconf [mc "Edit view..."] -state normal
9348 .bar.view entryconf [mc "Delete view"] -state normal
9351 if {[info exists permviews]} {
9352 foreach v $permviews {
9355 set viewname($n) [lindex $v 0]
9356 set viewfiles($n) [lindex $v 1]
9357 set viewargs($n) [lindex $v 2]