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
664 global vhighlights nhighlights fhighlights rhighlights
666 set vtokmod
($v) [lindex
$varctok($v) $a]
668 if {$v == $curview} {
669 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
670 set a
[lindex
$vupptr($v) $a]
676 set lim
[llength
$varccommits($v,$a)]
678 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
683 catch
{unset nhighlights
}
684 catch
{unset fhighlights
}
685 catch
{unset vhighlights
}
686 catch
{unset rhighlights
}
689 proc update_arcrows
{v
} {
690 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
691 global varcid vrownum varcorder varcix varccommits
692 global vupptr vdownptr vleftptr varctok
693 global displayorder parentlist curview cached_commitrow
695 set narctot
[expr {[llength
$varctok($v)] - 1}]
697 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
698 # go up the tree until we find something that has a row number,
699 # or we get to a seed
700 set a
[lindex
$vupptr($v) $a]
703 set a
[lindex
$vdownptr($v) 0]
706 set varcorder
($v) [list
$a]
708 lset varcrow
($v) $a 0
712 set arcn
[lindex
$varcix($v) $a]
713 # see if a is the last arc; if so, nothing to do
714 if {$arcn == $narctot - 1} {
717 if {[llength
$vrownum($v)] > $arcn + 1} {
718 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
719 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
721 set row
[lindex
$varcrow($v) $a]
723 if {$v == $curview} {
724 if {[llength
$displayorder] > $vrowmod($v)} {
725 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
726 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
728 catch
{unset cached_commitrow
}
732 incr row
[llength
$varccommits($v,$a)]
733 # go down if possible
734 set b
[lindex
$vdownptr($v) $a]
736 # if not, go left, or go up until we can go left
738 set b
[lindex
$vleftptr($v) $a]
740 set a
[lindex
$vupptr($v) $a]
746 lappend vrownum
($v) $row
747 lappend varcorder
($v) $a
748 lset varcix
($v) $a $arcn
749 lset varcrow
($v) $a $row
751 set vtokmod
($v) [lindex
$varctok($v) $p]
754 if {[info exists currentid
]} {
755 set selectedline
[rowofcommit
$currentid]
759 # Test whether view $v contains commit $id
760 proc commitinview
{id v
} {
763 return [info exists varcid
($v,$id)]
766 # Return the row number for commit $id in the current view
767 proc rowofcommit
{id
} {
768 global varcid varccommits varcrow curview cached_commitrow
769 global varctok vtokmod
772 if {![info exists varcid
($v,$id)]} {
773 puts
"oops rowofcommit no arc for [shortids $id]"
776 set a
$varcid($v,$id)
777 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
780 if {[info exists cached_commitrow
($id)]} {
781 return $cached_commitrow($id)
783 set i
[lsearch
-exact $varccommits($v,$a) $id]
785 puts
"oops didn't find commit [shortids $id] in arc $a"
788 incr i
[lindex
$varcrow($v) $a]
789 set cached_commitrow
($id) $i
793 # Returns 1 if a is on an earlier row than b, otherwise 0
794 proc comes_before
{a b
} {
795 global varcid varctok curview
798 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
799 ![info exists varcid
($v,$b)]} {
802 if {$varcid($v,$a) != $varcid($v,$b)} {
803 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
804 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
806 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
809 proc bsearch
{l elt
} {
810 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
815 while {$hi - $lo > 1} {
816 set mid
[expr {int
(($lo + $hi) / 2)}]
817 set t
[lindex
$l $mid]
820 } elseif
{$elt > $t} {
829 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
830 proc make_disporder
{start end
} {
831 global vrownum curview commitidx displayorder parentlist
832 global varccommits varcorder parents vrowmod varcrow
833 global d_valid_start d_valid_end
835 if {$end > $vrowmod($curview)} {
836 update_arcrows
$curview
838 set ai
[bsearch
$vrownum($curview) $start]
839 set start
[lindex
$vrownum($curview) $ai]
840 set narc
[llength
$vrownum($curview)]
841 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
842 set a
[lindex
$varcorder($curview) $ai]
843 set l
[llength
$displayorder]
844 set al
[llength
$varccommits($curview,$a)]
847 set pad
[ntimes
[expr {$r - $l}] {}]
848 set displayorder
[concat
$displayorder $pad]
849 set parentlist
[concat
$parentlist $pad]
851 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
852 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
854 foreach id
$varccommits($curview,$a) {
855 lappend displayorder
$id
856 lappend parentlist
$parents($curview,$id)
858 } elseif
{[lindex
$displayorder $r] eq
{}} {
860 foreach id
$varccommits($curview,$a) {
861 lset displayorder
$i $id
862 lset parentlist
$i $parents($curview,$id)
870 proc commitonrow
{row
} {
873 set id
[lindex
$displayorder $row]
875 make_disporder
$row [expr {$row + 1}]
876 set id
[lindex
$displayorder $row]
881 proc closevarcs
{v
} {
882 global varctok varccommits varcid parents children
883 global cmitlisted commitidx commitinterest vtokmod
885 set missing_parents
0
887 set narcs
[llength
$varctok($v)]
888 for {set a
1} {$a < $narcs} {incr a
} {
889 set id
[lindex
$varccommits($v,$a) end
]
890 foreach p
$parents($v,$id) {
891 if {[info exists varcid
($v,$p)]} continue
892 # add p as a new commit
894 set cmitlisted
($v,$p) 0
895 set parents
($v,$p) {}
896 if {[llength
$children($v,$p)] == 1 &&
897 [llength
$parents($v,$id)] == 1} {
900 set b
[newvarc
$v $p]
903 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
906 lappend varccommits
($v,$b) $p
908 if {[info exists commitinterest
($p)]} {
909 foreach
script $commitinterest($p) {
910 lappend scripts
[string map
[list
"%I" $p] $script]
912 unset commitinterest
($id)
916 if {$missing_parents > 0} {
923 proc getcommitlines
{fd inst view
} {
924 global cmitlisted commitinterest leftover
925 global commitidx commitdata datemode
926 global parents children curview hlview
927 global vnextroot idpending ordertok
928 global varccommits varcid varctok vtokmod
930 set stuff
[read $fd 500000]
931 # git log doesn't terminate the last commit with a null...
932 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
939 global commfd viewcomplete viewactive viewname progresscoords
942 set i
[lsearch
-exact $viewinstances($view) $inst]
944 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
946 # set it blocking so we wait for the process to terminate
947 fconfigure
$fd -blocking 1
948 if {[catch
{close
$fd} err
]} {
950 if {$view != $curview} {
951 set fv
" for the \"$viewname($view)\" view"
953 if {[string range
$err 0 4] == "usage"} {
954 set err
"Gitk: error reading commits$fv:\
955 bad arguments to git rev-list."
956 if {$viewname($view) eq
"Command line"} {
958 " (Note: arguments to gitk are passed to git rev-list\
959 to allow selection of commits to be displayed.)"
962 set err
"Error reading commits$fv: $err"
966 if {[incr viewactive
($view) -1] <= 0} {
967 set viewcomplete
($view) 1
968 # Check if we have seen any ids listed as parents that haven't
969 # appeared in the list
972 set progresscoords
{0 0}
975 if {$view == $curview} {
976 run chewcommits
$view
984 set i
[string first
"\0" $stuff $start]
986 append leftover
($inst) [string range
$stuff $start end
]
990 set cmit
$leftover($inst)
991 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
992 set leftover
($inst) {}
994 set cmit
[string range
$stuff $start [expr {$i - 1}]]
996 set start
[expr {$i + 1}]
997 set j
[string first
"\n" $cmit]
1000 if {$j >= 0 && [string match
"commit *" $cmit]} {
1001 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1002 if {[string match
{[-<>]*} $ids]} {
1003 switch
-- [string index
$ids 0] {
1008 set ids
[string range
$ids 1 end
]
1012 if {[string length
$id] != 40} {
1020 if {[string length
$shortcmit] > 80} {
1021 set shortcmit
"[string range $shortcmit 0 80]..."
1023 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1026 set id [lindex $ids 0]
1028 if {!$listed && [info exists parents($vid)]} continue
1030 set olds [lrange $ids 1 end]
1034 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1035 set cmitlisted($vid) $listed
1036 set parents($vid) $olds
1038 if {![info exists children($vid)]} {
1039 set children($vid) {}
1040 } elseif {[llength $children($vid)] == 1} {
1041 set k [lindex $children($vid) 0]
1042 if {[llength $parents($view,$k)] == 1 &&
1044 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1045 set a $varcid($view,$k)
1050 set a [newvarc $view $id]
1053 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1056 lappend varccommits($view,$a) $id
1060 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1062 if {[llength [lappend children($vp) $id]] > 1 &&
1063 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1064 set children($vp) [lsort -command [list vtokcmp $view] \
1066 catch {unset ordertok}
1068 if {[info exists varcid($view,$p)]} {
1069 fix_reversal $p $a $view
1075 incr commitidx($view)
1076 if {[info exists commitinterest($id)]} {
1077 foreach script $commitinterest($id) {
1078 lappend scripts [string map [list "%I" $id] $script]
1080 unset commitinterest($id)
1085 run chewcommits $view
1086 foreach s $scripts {
1089 if {$view == $curview} {
1090 # update progress bar
1091 global progressdirn progresscoords proglastnc
1092 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1093 set proglastnc $commitidx($view)
1094 set l [lindex $progresscoords 0]
1095 set r [lindex $progresscoords 1]
1096 if {$progressdirn} {
1097 set r [expr {$r + $inc}]
1103 set l [expr {$r - 0.2}]
1106 set l [expr {$l - $inc}]
1111 set r [expr {$l + 0.2}]
1113 set progresscoords [list $l $r]
1120 proc chewcommits {view} {
1121 global curview hlview viewcomplete
1122 global pending_select
1124 if {$view == $curview} {
1126 if {$viewcomplete($view)} {
1127 global commitidx varctok
1128 global numcommits startmsecs
1129 global mainheadid commitinfo nullid
1131 if {[info exists pending_select]} {
1132 set row [first_real_row]
1135 if {$commitidx($curview) > 0} {
1136 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1137 #puts "overall $ms ms for $numcommits commits"
1138 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1140 show_status [mc "No commits selected"]
1145 if {[info exists hlview] && $view == $hlview} {
1151 proc readcommit {id} {
1152 if {[catch {set contents [exec git cat-file commit $id]}]} return
1153 parsecommit $id $contents 0
1156 proc parsecommit {id contents listed} {
1157 global commitinfo cdate
1166 set hdrend [string first "\n\n" $contents]
1168 # should never happen...
1169 set hdrend [string length $contents]
1171 set header [string range $contents 0 [expr {$hdrend - 1}]]
1172 set comment [string range $contents [expr {$hdrend + 2}] end]
1173 foreach line [split $header "\n"] {
1174 set tag [lindex $line 0]
1175 if {$tag == "author"} {
1176 set audate [lindex $line end-1]
1177 set auname [lrange $line 1 end-2]
1178 } elseif {$tag == "committer"} {
1179 set comdate [lindex $line end-1]
1180 set comname [lrange $line 1 end-2]
1184 # take the first non-blank line of the comment as the headline
1185 set headline [string trimleft $comment]
1186 set i [string first "\n" $headline]
1188 set headline [string range $headline 0 $i]
1190 set headline [string trimright $headline]
1191 set i [string first "\r" $headline]
1193 set headline [string trimright [string range $headline 0 $i]]
1196 # git rev-list indents the comment by 4 spaces;
1197 # if we got this via git cat-file, add the indentation
1199 foreach line [split $comment "\n"] {
1200 append newcomment " "
1201 append newcomment $line
1202 append newcomment "\n"
1204 set comment $newcomment
1206 if {$comdate != {}} {
1207 set cdate($id) $comdate
1209 set commitinfo($id) [list $headline $auname $audate \
1210 $comname $comdate $comment]
1213 proc getcommit {id} {
1214 global commitdata commitinfo
1216 if {[info exists commitdata($id)]} {
1217 parsecommit $id $commitdata($id) 1
1220 if {![info exists commitinfo($id)]} {
1221 set commitinfo($id) [list [mc "No commit information available"]]
1228 global tagids idtags headids idheads tagobjid
1229 global otherrefids idotherrefs mainhead mainheadid
1231 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1234 set refd [open [list | git show-ref -d] r]
1235 while {[gets $refd line] >= 0} {
1236 if {[string index $line 40] ne " "} continue
1237 set id [string range $line 0 39]
1238 set ref [string range $line 41 end]
1239 if {![string match "refs/*" $ref]} continue
1240 set name [string range $ref 5 end]
1241 if {[string match "remotes/*" $name]} {
1242 if {![string match "*/HEAD" $name]} {
1243 set headids($name) $id
1244 lappend idheads($id) $name
1246 } elseif {[string match "heads/*" $name]} {
1247 set name [string range $name 6 end]
1248 set headids($name) $id
1249 lappend idheads($id) $name
1250 } elseif {[string match "tags/*" $name]} {
1251 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1252 # which is what we want since the former is the commit ID
1253 set name [string range $name 5 end]
1254 if {[string match "*^{}" $name]} {
1255 set name [string range $name 0 end-3]
1257 set tagobjid($name) $id
1259 set tagids($name) $id
1260 lappend idtags($id) $name
1262 set otherrefids($name) $id
1263 lappend idotherrefs($id) $name
1270 set thehead [exec git symbolic-ref HEAD]
1271 if {[string match "refs/heads/*" $thehead]} {
1272 set mainhead [string range $thehead 11 end]
1273 if {[info exists headids($mainhead)]} {
1274 set mainheadid $headids($mainhead)
1280 # skip over fake commits
1281 proc first_real_row {} {
1282 global nullid nullid2 numcommits
1284 for {set row 0} {$row < $numcommits} {incr row} {
1285 set id [commitonrow $row]
1286 if {$id ne $nullid && $id ne $nullid2} {
1293 # update things for a head moved to a child of its previous location
1294 proc movehead {id name} {
1295 global headids idheads
1297 removehead $headids($name) $name
1298 set headids($name) $id
1299 lappend idheads($id) $name
1302 # update things when a head has been removed
1303 proc removehead {id name} {
1304 global headids idheads
1306 if {$idheads($id) eq $name} {
1309 set i [lsearch -exact $idheads($id) $name]
1311 set idheads($id) [lreplace $idheads($id) $i $i]
1314 unset headids($name)
1317 proc show_error {w top msg} {
1318 message $w.m -text $msg -justify center -aspect 400
1319 pack $w.m -side top -fill x -padx 20 -pady 20
1320 button $w.ok -text [mc OK] -command "destroy $top"
1321 pack $w.ok -side bottom -fill x
1322 bind $top <Visibility> "grab $top; focus $top"
1323 bind $top <Key-Return> "destroy $top"
1327 proc error_popup msg {
1331 show_error $w $w $msg
1334 proc confirm_popup msg {
1340 message $w.m -text $msg -justify center -aspect 400
1341 pack $w.m -side top -fill x -padx 20 -pady 20
1342 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1343 pack $w.ok -side left -fill x
1344 button $w.cancel -text [mc Cancel] -command "destroy $w"
1345 pack $w.cancel -side right -fill x
1346 bind $w <Visibility> "grab $w; focus $w"
1351 proc makewindow {} {
1352 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1354 global findtype findtypemenu findloc findstring fstring geometry
1355 global entries sha1entry sha1string sha1but
1356 global diffcontextstring diffcontext
1357 global maincursor textcursor curtextcursor
1358 global rowctxmenu fakerowmenu mergemax wrapcomment
1359 global highlight_files gdttype
1360 global searchstring sstring
1361 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1362 global headctxmenu progresscanv progressitem progresscoords statusw
1363 global fprogitem fprogcoord lastprogupdate progupdatepending
1364 global rprogitem rprogcoord
1368 .bar add cascade -label [mc "File"] -menu .bar.file
1369 .bar configure -font uifont
1371 .bar.file add command -label [mc "Update"] -command updatecommits
1372 .bar.file add command -label [mc "Reload"] -command reloadcommits
1373 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1374 .bar.file add command -label [mc "List references"] -command showrefs
1375 .bar.file add command -label [mc "Quit"] -command doquit
1376 .bar.file configure -font uifont
1378 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1379 .bar.edit add command -label [mc "Preferences"] -command doprefs
1380 .bar.edit configure -font uifont
1382 menu .bar.view -font uifont
1383 .bar add cascade -label [mc "View"] -menu .bar.view
1384 .bar.view add command -label [mc "New view..."] -command {newview 0}
1385 .bar.view add command -label [mc "Edit view..."] -command editview \
1387 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1388 .bar.view add separator
1389 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1390 -variable selectedview -value 0
1393 .bar add cascade -label [mc "Help"] -menu .bar.help
1394 .bar.help add command -label [mc "About gitk"] -command about
1395 .bar.help add command -label [mc "Key bindings"] -command keys
1396 .bar.help configure -font uifont
1397 . configure -menu .bar
1399 # the gui has upper and lower half, parts of a paned window.
1400 panedwindow .ctop -orient vertical
1402 # possibly use assumed geometry
1403 if {![info exists geometry(pwsash0)]} {
1404 set geometry(topheight) [expr {15 * $linespc}]
1405 set geometry(topwidth) [expr {80 * $charspc}]
1406 set geometry(botheight) [expr {15 * $linespc}]
1407 set geometry(botwidth) [expr {50 * $charspc}]
1408 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1409 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1412 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1413 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1415 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1417 # create three canvases
1418 set cscroll .tf.histframe.csb
1419 set canv .tf.histframe.pwclist.canv
1421 -selectbackground $selectbgcolor \
1422 -background $bgcolor -bd 0 \
1423 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1424 .tf.histframe.pwclist add $canv
1425 set canv2 .tf.histframe.pwclist.canv2
1427 -selectbackground $selectbgcolor \
1428 -background $bgcolor -bd 0 -yscrollincr $linespc
1429 .tf.histframe.pwclist add $canv2
1430 set canv3 .tf.histframe.pwclist.canv3
1432 -selectbackground $selectbgcolor \
1433 -background $bgcolor -bd 0 -yscrollincr $linespc
1434 .tf.histframe.pwclist add $canv3
1435 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1436 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1438 # a scroll bar to rule them
1439 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1440 pack $cscroll -side right -fill y
1441 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1442 lappend bglist $canv $canv2 $canv3
1443 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1445 # we have two button bars at bottom of top frame. Bar 1
1447 frame .tf.lbar -height 15
1449 set sha1entry .tf.bar.sha1
1450 set entries $sha1entry
1451 set sha1but .tf.bar.sha1label
1452 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1453 -command gotocommit -width 8 -font uifont
1454 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1455 pack .tf.bar.sha1label -side left
1456 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1457 trace add variable sha1string write sha1change
1458 pack $sha1entry -side left -pady 2
1460 image create bitmap bm-left -data {
1461 #define left_width 16
1462 #define left_height 16
1463 static unsigned char left_bits[] = {
1464 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1465 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1466 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1468 image create bitmap bm-right -data {
1469 #define right_width 16
1470 #define right_height 16
1471 static unsigned char right_bits[] = {
1472 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1473 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1474 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1476 button .tf.bar.leftbut -image bm-left -command goback \
1477 -state disabled -width 26
1478 pack .tf.bar.leftbut -side left -fill y
1479 button .tf.bar.rightbut -image bm-right -command goforw \
1480 -state disabled -width 26
1481 pack .tf.bar.rightbut -side left -fill y
1483 # Status label and progress bar
1484 set statusw .tf.bar.status
1485 label $statusw -width 15 -relief sunken -font uifont
1486 pack $statusw -side left -padx 5
1487 set h [expr {[font metrics uifont -linespace] + 2}]
1488 set progresscanv .tf.bar.progress
1489 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1490 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1491 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1492 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1493 pack $progresscanv -side right -expand 1 -fill x
1494 set progresscoords {0 0}
1497 bind $progresscanv <Configure> adjustprogress
1498 set lastprogupdate [clock clicks -milliseconds]
1499 set progupdatepending 0
1501 # build up the bottom bar of upper window
1502 label .tf.lbar.flabel -text "[mc "Find"] " -font uifont
1503 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1} -font uifont
1504 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1} -font uifont
1505 label .tf.lbar.flab2 -text " [mc "commit"] " -font uifont
1506 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1508 set gdttype [mc "containing:"]
1509 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1510 [mc "containing:"] \
1511 [mc "touching paths:"] \
1512 [mc "adding/removing string:"]]
1513 trace add variable gdttype write gdttype_change
1514 $gm conf -font uifont
1515 .tf.lbar.gdttype conf -font uifont
1516 pack .tf.lbar.gdttype -side left -fill y
1519 set fstring .tf.lbar.findstring
1520 lappend entries $fstring
1521 entry $fstring -width 30 -font textfont -textvariable findstring
1522 trace add variable findstring write find_change
1523 set findtype [mc "Exact"]
1524 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1525 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1526 trace add variable findtype write findcom_change
1527 .tf.lbar.findtype configure -font uifont
1528 .tf.lbar.findtype.menu configure -font uifont
1529 set findloc [mc "All fields"]
1530 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1531 [mc "Comments"] [mc "Author"] [mc "Committer"]
1532 trace add variable findloc write find_change
1533 .tf.lbar.findloc configure -font uifont
1534 .tf.lbar.findloc.menu configure -font uifont
1535 pack .tf.lbar.findloc -side right
1536 pack .tf.lbar.findtype -side right
1537 pack $fstring -side left -expand 1 -fill x
1539 # Finish putting the upper half of the viewer together
1540 pack .tf.lbar -in .tf -side bottom -fill x
1541 pack .tf.bar -in .tf -side bottom -fill x
1542 pack .tf.histframe -fill both -side top -expand 1
1544 .ctop paneconfigure .tf -height $geometry(topheight)
1545 .ctop paneconfigure .tf -width $geometry(topwidth)
1547 # now build up the bottom
1548 panedwindow .pwbottom -orient horizontal
1550 # lower left, a text box over search bar, scroll bar to the right
1551 # if we know window height, then that will set the lower text height, otherwise
1552 # we set lower text height which will drive window height
1553 if {[info exists geometry(main)]} {
1554 frame .bleft -width $geometry(botwidth)
1556 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1561 button .bleft.top.search -text [mc "Search"] -command dosearch \
1563 pack .bleft.top.search -side left -padx 5
1564 set sstring .bleft.top.sstring
1565 entry $sstring -width 20 -font textfont -textvariable searchstring
1566 lappend entries $sstring
1567 trace add variable searchstring write incrsearch
1568 pack $sstring -side left -expand 1 -fill x
1569 radiobutton .bleft.mid.diff -text [mc "Diff"] -font uifont \
1570 -command changediffdisp -variable diffelide -value {0 0}
1571 radiobutton .bleft.mid.old -text [mc "Old version"] -font uifont \
1572 -command changediffdisp -variable diffelide -value {0 1}
1573 radiobutton .bleft.mid.new -text [mc "New version"] -font uifont \
1574 -command changediffdisp -variable diffelide -value {1 0}
1575 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: " \
1577 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1578 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1579 -from 1 -increment 1 -to 10000000 \
1580 -validate all -validatecommand "diffcontextvalidate %P" \
1581 -textvariable diffcontextstring
1582 .bleft.mid.diffcontext set $diffcontext
1583 trace add variable diffcontextstring write diffcontextchange
1584 lappend entries .bleft.mid.diffcontext
1585 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1586 set ctext .bleft.ctext
1587 text $ctext -background $bgcolor -foreground $fgcolor \
1588 -state disabled -font textfont \
1589 -yscrollcommand scrolltext -wrap none
1591 $ctext conf -tabstyle wordprocessor
1593 scrollbar .bleft.sb -command "$ctext yview"
1594 pack .bleft.top -side top -fill x
1595 pack .bleft.mid -side top -fill x
1596 pack .bleft.sb -side right -fill y
1597 pack $ctext -side left -fill both -expand 1
1598 lappend bglist $ctext
1599 lappend fglist $ctext
1601 $ctext tag conf comment -wrap $wrapcomment
1602 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1603 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1604 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1605 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1606 $ctext tag conf m0 -fore red
1607 $ctext tag conf m1 -fore blue
1608 $ctext tag conf m2 -fore green
1609 $ctext tag conf m3 -fore purple
1610 $ctext tag conf m4 -fore brown
1611 $ctext tag conf m5 -fore "#009090"
1612 $ctext tag conf m6 -fore magenta
1613 $ctext tag conf m7 -fore "#808000"
1614 $ctext tag conf m8 -fore "#009000"
1615 $ctext tag conf m9 -fore "#ff0080"
1616 $ctext tag conf m10 -fore cyan
1617 $ctext tag conf m11 -fore "#b07070"
1618 $ctext tag conf m12 -fore "#70b0f0"
1619 $ctext tag conf m13 -fore "#70f0b0"
1620 $ctext tag conf m14 -fore "#f0b070"
1621 $ctext tag conf m15 -fore "#ff70b0"
1622 $ctext tag conf mmax -fore darkgrey
1624 $ctext tag conf mresult -font textfontbold
1625 $ctext tag conf msep -font textfontbold
1626 $ctext tag conf found -back yellow
1628 .pwbottom add .bleft
1629 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1634 radiobutton .bright.mode.patch -text [mc "Patch"] \
1635 -command reselectline -variable cmitmode -value "patch"
1636 .bright.mode.patch configure -font uifont
1637 radiobutton .bright.mode.tree -text [mc "Tree"] \
1638 -command reselectline -variable cmitmode -value "tree"
1639 .bright.mode.tree configure -font uifont
1640 grid .bright.mode.patch .bright.mode.tree -sticky ew
1641 pack .bright.mode -side top -fill x
1642 set cflist .bright.cfiles
1643 set indent [font measure mainfont "nn"]
1645 -selectbackground $selectbgcolor \
1646 -background $bgcolor -foreground $fgcolor \
1648 -tabs [list $indent [expr {2 * $indent}]] \
1649 -yscrollcommand ".bright.sb set" \
1650 -cursor [. cget -cursor] \
1651 -spacing1 1 -spacing3 1
1652 lappend bglist $cflist
1653 lappend fglist $cflist
1654 scrollbar .bright.sb -command "$cflist yview"
1655 pack .bright.sb -side right -fill y
1656 pack $cflist -side left -fill both -expand 1
1657 $cflist tag configure highlight \
1658 -background [$cflist cget -selectbackground]
1659 $cflist tag configure bold -font mainfontbold
1661 .pwbottom add .bright
1664 # restore window position if known
1665 if {[info exists geometry(main)]} {
1666 wm geometry . "$geometry(main)"
1669 if {[tk windowingsystem] eq {aqua}} {
1675 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1676 pack .ctop -fill both -expand 1
1677 bindall <1> {selcanvline %W %x %y}
1678 #bindall <B1-Motion> {selcanvline %W %x %y}
1679 if {[tk windowingsystem] == "win32"} {
1680 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1681 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1683 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1684 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1685 if {[tk windowingsystem] eq "aqua"} {
1686 bindall <MouseWheel> {
1687 set delta [expr {- (%D)}]
1688 allcanvs yview scroll $delta units
1692 bindall <2> "canvscan mark %W %x %y"
1693 bindall <B2-Motion> "canvscan dragto %W %x %y"
1694 bindkey <Home> selfirstline
1695 bindkey <End> sellastline
1696 bind . <Key-Up> "selnextline -1"
1697 bind . <Key-Down> "selnextline 1"
1698 bind . <Shift-Key-Up> "dofind -1 0"
1699 bind . <Shift-Key-Down> "dofind 1 0"
1700 bindkey <Key-Right> "goforw"
1701 bindkey <Key-Left> "goback"
1702 bind . <Key-Prior> "selnextpage -1"
1703 bind . <Key-Next> "selnextpage 1"
1704 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1705 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1706 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1707 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1708 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1709 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1710 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1711 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1712 bindkey <Key-space> "$ctext yview scroll 1 pages"
1713 bindkey p "selnextline -1"
1714 bindkey n "selnextline 1"
1717 bindkey i "selnextline -1"
1718 bindkey k "selnextline 1"
1721 bindkey b "$ctext yview scroll -1 pages"
1722 bindkey d "$ctext yview scroll 18 units"
1723 bindkey u "$ctext yview scroll -18 units"
1724 bindkey / {dofind 1 1}
1725 bindkey <Key-Return> {dofind 1 1}
1726 bindkey ? {dofind -1 1}
1728 bindkey <F5> updatecommits
1729 bind . <$M1B-q> doquit
1730 bind . <$M1B-f> {dofind 1 1}
1731 bind . <$M1B-g> {dofind 1 0}
1732 bind . <$M1B-r> dosearchback
1733 bind . <$M1B-s> dosearch
1734 bind . <$M1B-equal> {incrfont 1}
1735 bind . <$M1B-KP_Add> {incrfont 1}
1736 bind . <$M1B-minus> {incrfont -1}
1737 bind . <$M1B-KP_Subtract> {incrfont -1}
1738 wm protocol . WM_DELETE_WINDOW doquit
1739 bind . <Button-1> "click %W"
1740 bind $fstring <Key-Return> {dofind 1 1}
1741 bind $sha1entry <Key-Return> gotocommit
1742 bind $sha1entry <<PasteSelection>> clearsha1
1743 bind $cflist <1> {sel_flist %W %x %y; break}
1744 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1745 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1746 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1748 set maincursor [. cget -cursor]
1749 set textcursor [$ctext cget -cursor]
1750 set curtextcursor $textcursor
1752 set rowctxmenu .rowctxmenu
1753 menu $rowctxmenu -tearoff 0
1754 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1755 -command {diffvssel 0}
1756 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1757 -command {diffvssel 1}
1758 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1759 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1760 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1761 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1762 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1764 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1767 set fakerowmenu .fakerowmenu
1768 menu $fakerowmenu -tearoff 0
1769 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1770 -command {diffvssel 0}
1771 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1772 -command {diffvssel 1}
1773 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1774 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1775 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1776 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1778 set headctxmenu .headctxmenu
1779 menu $headctxmenu -tearoff 0
1780 $headctxmenu add command -label [mc "Check out this branch"] \
1782 $headctxmenu add command -label [mc "Remove this branch"] \
1786 set flist_menu .flistctxmenu
1787 menu $flist_menu -tearoff 0
1788 $flist_menu add command -label [mc "Highlight this too"] \
1789 -command {flist_hl 0}
1790 $flist_menu add command -label [mc "Highlight this only"] \
1791 -command {flist_hl 1}
1794 # Windows sends all mouse wheel events to the current focused window, not
1795 # the one where the mouse hovers, so bind those events here and redirect
1796 # to the correct window
1797 proc windows_mousewheel_redirector {W X Y D} {
1798 global canv canv2 canv3
1799 set w [winfo containing -displayof $W $X $Y]
1801 set u [expr {$D < 0 ? 5 : -5}]
1802 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1803 allcanvs yview scroll $u units
1806 $w yview scroll $u units
1812 # mouse-2 makes all windows scan vertically, but only the one
1813 # the cursor is in scans horizontally
1814 proc canvscan {op w x y} {
1815 global canv canv2 canv3
1816 foreach c [list $canv $canv2 $canv3] {
1825 proc scrollcanv {cscroll f0 f1} {
1826 $cscroll set $f0 $f1
1831 # when we make a key binding for the toplevel, make sure
1832 # it doesn't get triggered when that key is pressed
in the
1833 # find string entry widget.
1834 proc bindkey
{ev
script} {
1837 set escript
[bind Entry
$ev]
1838 if {$escript == {}} {
1839 set escript
[bind Entry
<Key
>]
1841 foreach e
$entries {
1842 bind $e $ev "$escript; break"
1846 # set the focus back to the toplevel for any click outside
1849 global ctext entries
1850 foreach e
[concat
$entries $ctext] {
1851 if {$w == $e} return
1856 # Adjust the progress bar for a change in requested extent or canvas size
1857 proc adjustprogress
{} {
1858 global progresscanv progressitem progresscoords
1859 global fprogitem fprogcoord lastprogupdate progupdatepending
1860 global rprogitem rprogcoord
1862 set w
[expr {[winfo width
$progresscanv] - 4}]
1863 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1864 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1865 set h
[winfo height
$progresscanv]
1866 $progresscanv coords
$progressitem $x0 0 $x1 $h
1867 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1868 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1869 set now
[clock clicks
-milliseconds]
1870 if {$now >= $lastprogupdate + 100} {
1871 set progupdatepending
0
1873 } elseif
{!$progupdatepending} {
1874 set progupdatepending
1
1875 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1879 proc doprogupdate
{} {
1880 global lastprogupdate progupdatepending
1882 if {$progupdatepending} {
1883 set progupdatepending
0
1884 set lastprogupdate
[clock clicks
-milliseconds]
1889 proc savestuff
{w
} {
1890 global canv canv2 canv3 mainfont textfont uifont tabstop
1891 global stuffsaved findmergefiles maxgraphpct
1892 global maxwidth showneartags showlocalchanges
1893 global viewname viewfiles viewargs viewperm nextviewnum
1894 global cmitmode wrapcomment datetimeformat limitdiffs
1895 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1897 if {$stuffsaved} return
1898 if {![winfo viewable .
]} return
1900 set f
[open
"~/.gitk-new" w
]
1901 puts
$f [list
set mainfont
$mainfont]
1902 puts
$f [list
set textfont
$textfont]
1903 puts
$f [list
set uifont
$uifont]
1904 puts
$f [list
set tabstop
$tabstop]
1905 puts
$f [list
set findmergefiles
$findmergefiles]
1906 puts
$f [list
set maxgraphpct
$maxgraphpct]
1907 puts
$f [list
set maxwidth
$maxwidth]
1908 puts
$f [list
set cmitmode
$cmitmode]
1909 puts
$f [list
set wrapcomment
$wrapcomment]
1910 puts
$f [list
set showneartags
$showneartags]
1911 puts
$f [list
set showlocalchanges
$showlocalchanges]
1912 puts
$f [list
set datetimeformat
$datetimeformat]
1913 puts
$f [list
set limitdiffs
$limitdiffs]
1914 puts
$f [list
set bgcolor
$bgcolor]
1915 puts
$f [list
set fgcolor
$fgcolor]
1916 puts
$f [list
set colors
$colors]
1917 puts
$f [list
set diffcolors
$diffcolors]
1918 puts
$f [list
set diffcontext
$diffcontext]
1919 puts
$f [list
set selectbgcolor
$selectbgcolor]
1921 puts
$f "set geometry(main) [wm geometry .]"
1922 puts
$f "set geometry(topwidth) [winfo width .tf]"
1923 puts
$f "set geometry(topheight) [winfo height .tf]"
1924 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1925 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1926 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1927 puts
$f "set geometry(botheight) [winfo height .bleft]"
1929 puts
-nonewline $f "set permviews {"
1930 for {set v
0} {$v < $nextviewnum} {incr v
} {
1931 if {$viewperm($v)} {
1932 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1937 file rename
-force "~/.gitk-new" "~/.gitk"
1942 proc resizeclistpanes
{win w
} {
1944 if {[info exists oldwidth
($win)]} {
1945 set s0
[$win sash coord
0]
1946 set s1
[$win sash coord
1]
1948 set sash0
[expr {int
($w/2 - 2)}]
1949 set sash1
[expr {int
($w*5/6 - 2)}]
1951 set factor [expr {1.0 * $w / $oldwidth($win)}]
1952 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1953 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1957 if {$sash1 < $sash0 + 20} {
1958 set sash1
[expr {$sash0 + 20}]
1960 if {$sash1 > $w - 10} {
1961 set sash1
[expr {$w - 10}]
1962 if {$sash0 > $sash1 - 20} {
1963 set sash0
[expr {$sash1 - 20}]
1967 $win sash place
0 $sash0 [lindex
$s0 1]
1968 $win sash place
1 $sash1 [lindex
$s1 1]
1970 set oldwidth
($win) $w
1973 proc resizecdetpanes
{win w
} {
1975 if {[info exists oldwidth
($win)]} {
1976 set s0
[$win sash coord
0]
1978 set sash0
[expr {int
($w*3/4 - 2)}]
1980 set factor [expr {1.0 * $w / $oldwidth($win)}]
1981 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1985 if {$sash0 > $w - 15} {
1986 set sash0
[expr {$w - 15}]
1989 $win sash place
0 $sash0 [lindex
$s0 1]
1991 set oldwidth
($win) $w
1994 proc allcanvs args
{
1995 global canv canv2 canv3
2001 proc bindall
{event action
} {
2002 global canv canv2 canv3
2003 bind $canv $event $action
2004 bind $canv2 $event $action
2005 bind $canv3 $event $action
2011 if {[winfo exists
$w]} {
2016 wm title
$w [mc
"About gitk"]
2017 message
$w.m
-text [mc
"
2018 Gitk - a commit viewer for git
2020 Copyright © 2005-2006 Paul Mackerras
2022 Use and redistribute under the terms of the GNU General Public License"] \
2023 -justify center
-aspect 400 -border 2 -bg white
-relief groove
2024 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
2025 $w.m configure
-font uifont
2026 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2027 pack
$w.ok
-side bottom
2028 $w.ok configure
-font uifont
2029 bind $w <Visibility
> "focus $w.ok"
2030 bind $w <Key-Escape
> "destroy $w"
2031 bind $w <Key-Return
> "destroy $w"
2037 if {[winfo exists
$w]} {
2041 if {[tk windowingsystem
] eq
{aqua
}} {
2047 wm title
$w [mc
"Gitk key bindings"]
2048 message
$w.m
-text [mc
"
2052 <Home> Move to first commit
2053 <End> Move to last commit
2054 <Up>, p, i Move up one commit
2055 <Down>, n, k Move down one commit
2056 <Left>, z, j Go back in history list
2057 <Right>, x, l Go forward in history list
2058 <PageUp> Move up one page in commit list
2059 <PageDown> Move down one page in commit list
2060 <$M1T-Home> Scroll to top of commit list
2061 <$M1T-End> Scroll to bottom of commit list
2062 <$M1T-Up> Scroll commit list up one line
2063 <$M1T-Down> Scroll commit list down one line
2064 <$M1T-PageUp> Scroll commit list up one page
2065 <$M1T-PageDown> Scroll commit list down one page
2066 <Shift-Up> Find backwards (upwards, later commits)
2067 <Shift-Down> Find forwards (downwards, earlier commits)
2068 <Delete>, b Scroll diff view up one page
2069 <Backspace> Scroll diff view up one page
2070 <Space> Scroll diff view down one page
2071 u Scroll diff view up 18 lines
2072 d Scroll diff view down 18 lines
2074 <$M1T-G> Move to next find hit
2075 <Return> Move to next find hit
2076 / Move to next find hit, or redo find
2077 ? Move to previous find hit
2078 f Scroll diff view to next file
2079 <$M1T-S> Search for next hit in diff view
2080 <$M1T-R> Search for previous hit in diff view
2081 <$M1T-KP+> Increase font size
2082 <$M1T-plus> Increase font size
2083 <$M1T-KP-> Decrease font size
2084 <$M1T-minus> Decrease font size
2087 -justify left
-bg white
-border 2 -relief groove
2088 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
2089 $w.m configure
-font uifont
2090 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2091 pack
$w.ok
-side bottom
2092 $w.ok configure
-font uifont
2093 bind $w <Visibility
> "focus $w.ok"
2094 bind $w <Key-Escape
> "destroy $w"
2095 bind $w <Key-Return
> "destroy $w"
2098 # Procedures for manipulating the file list window at the
2099 # bottom right of the overall window.
2101 proc treeview
{w l openlevs
} {
2102 global treecontents treediropen treeheight treeparent treeindex
2112 set treecontents
() {}
2113 $w conf
-state normal
2115 while {[string range
$f 0 $prefixend] ne
$prefix} {
2116 if {$lev <= $openlevs} {
2117 $w mark
set e
:$treeindex($prefix) "end -1c"
2118 $w mark gravity e
:$treeindex($prefix) left
2120 set treeheight
($prefix) $ht
2121 incr ht
[lindex
$htstack end
]
2122 set htstack
[lreplace
$htstack end end
]
2123 set prefixend
[lindex
$prefendstack end
]
2124 set prefendstack
[lreplace
$prefendstack end end
]
2125 set prefix
[string range
$prefix 0 $prefixend]
2128 set tail [string range
$f [expr {$prefixend+1}] end
]
2129 while {[set slash
[string first
"/" $tail]] >= 0} {
2132 lappend prefendstack
$prefixend
2133 incr prefixend
[expr {$slash + 1}]
2134 set d
[string range
$tail 0 $slash]
2135 lappend treecontents
($prefix) $d
2136 set oldprefix
$prefix
2138 set treecontents
($prefix) {}
2139 set treeindex
($prefix) [incr ix
]
2140 set treeparent
($prefix) $oldprefix
2141 set tail [string range
$tail [expr {$slash+1}] end
]
2142 if {$lev <= $openlevs} {
2144 set treediropen
($prefix) [expr {$lev < $openlevs}]
2145 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
2146 $w mark
set d
:$ix "end -1c"
2147 $w mark gravity d
:$ix left
2149 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2151 $w image create end
-align center
-image $bm -padx 1 \
2153 $w insert end
$d [highlight_tag
$prefix]
2154 $w mark
set s
:$ix "end -1c"
2155 $w mark gravity s
:$ix left
2160 if {$lev <= $openlevs} {
2163 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2165 $w insert end
$tail [highlight_tag
$f]
2167 lappend treecontents
($prefix) $tail
2170 while {$htstack ne
{}} {
2171 set treeheight
($prefix) $ht
2172 incr ht
[lindex
$htstack end
]
2173 set htstack
[lreplace
$htstack end end
]
2174 set prefixend
[lindex
$prefendstack end
]
2175 set prefendstack
[lreplace
$prefendstack end end
]
2176 set prefix
[string range
$prefix 0 $prefixend]
2178 $w conf
-state disabled
2181 proc linetoelt
{l
} {
2182 global treeheight treecontents
2187 foreach e
$treecontents($prefix) {
2192 if {[string index
$e end
] eq
"/"} {
2193 set n
$treeheight($prefix$e)
2205 proc highlight_tree
{y prefix
} {
2206 global treeheight treecontents cflist
2208 foreach e
$treecontents($prefix) {
2210 if {[highlight_tag
$path] ne
{}} {
2211 $cflist tag add bold
$y.0 "$y.0 lineend"
2214 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
2215 set y
[highlight_tree
$y $path]
2221 proc treeclosedir
{w dir
} {
2222 global treediropen treeheight treeparent treeindex
2224 set ix
$treeindex($dir)
2225 $w conf
-state normal
2226 $w delete s
:$ix e
:$ix
2227 set treediropen
($dir) 0
2228 $w image configure a
:$ix -image tri-rt
2229 $w conf
-state disabled
2230 set n
[expr {1 - $treeheight($dir)}]
2231 while {$dir ne
{}} {
2232 incr treeheight
($dir) $n
2233 set dir
$treeparent($dir)
2237 proc treeopendir
{w dir
} {
2238 global treediropen treeheight treeparent treecontents treeindex
2240 set ix
$treeindex($dir)
2241 $w conf
-state normal
2242 $w image configure a
:$ix -image tri-dn
2243 $w mark
set e
:$ix s
:$ix
2244 $w mark gravity e
:$ix right
2247 set n
[llength
$treecontents($dir)]
2248 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
2251 incr treeheight
($x) $n
2253 foreach e
$treecontents($dir) {
2255 if {[string index
$e end
] eq
"/"} {
2256 set iy
$treeindex($de)
2257 $w mark
set d
:$iy e
:$ix
2258 $w mark gravity d
:$iy left
2259 $w insert e
:$ix $str
2260 set treediropen
($de) 0
2261 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
2263 $w insert e
:$ix $e [highlight_tag
$de]
2264 $w mark
set s
:$iy e
:$ix
2265 $w mark gravity s
:$iy left
2266 set treeheight
($de) 1
2268 $w insert e
:$ix $str
2269 $w insert e
:$ix $e [highlight_tag
$de]
2272 $w mark gravity e
:$ix left
2273 $w conf
-state disabled
2274 set treediropen
($dir) 1
2275 set top
[lindex
[split [$w index @
0,0] .
] 0]
2276 set ht
[$w cget
-height]
2277 set l
[lindex
[split [$w index s
:$ix] .
] 0]
2280 } elseif
{$l + $n + 1 > $top + $ht} {
2281 set top
[expr {$l + $n + 2 - $ht}]
2289 proc treeclick
{w x y
} {
2290 global treediropen cmitmode ctext cflist cflist_top
2292 if {$cmitmode ne
"tree"} return
2293 if {![info exists cflist_top
]} return
2294 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2295 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2296 $cflist tag add highlight
$l.0 "$l.0 lineend"
2302 set e
[linetoelt
$l]
2303 if {[string index
$e end
] ne
"/"} {
2305 } elseif
{$treediropen($e)} {
2312 proc setfilelist
{id
} {
2313 global treefilelist cflist
2315 treeview
$cflist $treefilelist($id) 0
2318 image create bitmap tri-rt
-background black
-foreground blue
-data {
2319 #define tri-rt_width 13
2320 #define tri-rt_height 13
2321 static unsigned char tri-rt_bits
[] = {
2322 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2323 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2326 #define tri-rt-mask_width 13
2327 #define tri-rt-mask_height 13
2328 static unsigned char tri-rt-mask_bits
[] = {
2329 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2330 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2333 image create bitmap tri-dn
-background black
-foreground blue
-data {
2334 #define tri-dn_width 13
2335 #define tri-dn_height 13
2336 static unsigned char tri-dn_bits
[] = {
2337 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2338 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2341 #define tri-dn-mask_width 13
2342 #define tri-dn-mask_height 13
2343 static unsigned char tri-dn-mask_bits
[] = {
2344 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2345 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2349 image create bitmap reficon-T
-background black
-foreground yellow
-data {
2350 #define tagicon_width 13
2351 #define tagicon_height 9
2352 static unsigned char tagicon_bits
[] = {
2353 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2354 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2356 #define tagicon-mask_width 13
2357 #define tagicon-mask_height 9
2358 static unsigned char tagicon-mask_bits
[] = {
2359 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2360 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2363 #define headicon_width 13
2364 #define headicon_height 9
2365 static unsigned char headicon_bits
[] = {
2366 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2367 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2370 #define headicon-mask_width 13
2371 #define headicon-mask_height 9
2372 static unsigned char headicon-mask_bits
[] = {
2373 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2374 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2376 image create bitmap reficon-H
-background black
-foreground green \
2377 -data $rectdata -maskdata $rectmask
2378 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
2379 -data $rectdata -maskdata $rectmask
2381 proc init_flist
{first
} {
2382 global cflist cflist_top difffilestart
2384 $cflist conf
-state normal
2385 $cflist delete
0.0 end
2387 $cflist insert end
$first
2389 $cflist tag add highlight
1.0 "1.0 lineend"
2391 catch
{unset cflist_top
}
2393 $cflist conf
-state disabled
2394 set difffilestart
{}
2397 proc highlight_tag
{f
} {
2398 global highlight_paths
2400 foreach p
$highlight_paths {
2401 if {[string match
$p $f]} {
2408 proc highlight_filelist
{} {
2409 global cmitmode cflist
2411 $cflist conf
-state normal
2412 if {$cmitmode ne
"tree"} {
2413 set end
[lindex
[split [$cflist index end
] .
] 0]
2414 for {set l
2} {$l < $end} {incr l
} {
2415 set line
[$cflist get
$l.0 "$l.0 lineend"]
2416 if {[highlight_tag
$line] ne
{}} {
2417 $cflist tag add bold
$l.0 "$l.0 lineend"
2423 $cflist conf
-state disabled
2426 proc unhighlight_filelist
{} {
2429 $cflist conf
-state normal
2430 $cflist tag remove bold
1.0 end
2431 $cflist conf
-state disabled
2434 proc add_flist
{fl
} {
2437 $cflist conf
-state normal
2439 $cflist insert end
"\n"
2440 $cflist insert end
$f [highlight_tag
$f]
2442 $cflist conf
-state disabled
2445 proc sel_flist
{w x y
} {
2446 global ctext difffilestart cflist cflist_top cmitmode
2448 if {$cmitmode eq
"tree"} return
2449 if {![info exists cflist_top
]} return
2450 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2451 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2452 $cflist tag add highlight
$l.0 "$l.0 lineend"
2457 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
2461 proc pop_flist_menu
{w X Y x y
} {
2462 global ctext cflist cmitmode flist_menu flist_menu_file
2463 global treediffs diffids
2466 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2468 if {$cmitmode eq
"tree"} {
2469 set e
[linetoelt
$l]
2470 if {[string index
$e end
] eq
"/"} return
2472 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
2474 set flist_menu_file
$e
2475 tk_popup
$flist_menu $X $Y
2478 proc flist_hl
{only
} {
2479 global flist_menu_file findstring gdttype
2481 set x
[shellquote
$flist_menu_file]
2482 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
2485 append findstring
" " $x
2487 set gdttype
[mc
"touching paths:"]
2490 # Functions for adding and removing shell-type quoting
2492 proc shellquote
{str
} {
2493 if {![string match
"*\['\"\\ \t]*" $str]} {
2496 if {![string match
"*\['\"\\]*" $str]} {
2499 if {![string match
"*'*" $str]} {
2502 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2505 proc shellarglist
{l
} {
2511 append str
[shellquote
$a]
2516 proc shelldequote
{str
} {
2521 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
2522 append ret
[string range
$str $used end
]
2523 set used
[string length
$str]
2526 set first
[lindex
$first 0]
2527 set ch
[string index
$str $first]
2528 if {$first > $used} {
2529 append ret
[string range
$str $used [expr {$first - 1}]]
2532 if {$ch eq
" " ||
$ch eq
"\t"} break
2535 set first
[string first
"'" $str $used]
2537 error
"unmatched single-quote"
2539 append ret
[string range
$str $used [expr {$first - 1}]]
2544 if {$used >= [string length
$str]} {
2545 error
"trailing backslash"
2547 append ret
[string index
$str $used]
2552 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
2553 error
"unmatched double-quote"
2555 set first
[lindex
$first 0]
2556 set ch
[string index
$str $first]
2557 if {$first > $used} {
2558 append ret
[string range
$str $used [expr {$first - 1}]]
2561 if {$ch eq
"\""} break
2563 append ret
[string index
$str $used]
2567 return [list
$used $ret]
2570 proc shellsplit
{str
} {
2573 set str
[string trimleft
$str]
2574 if {$str eq
{}} break
2575 set dq
[shelldequote
$str]
2576 set n
[lindex
$dq 0]
2577 set word
[lindex
$dq 1]
2578 set str
[string range
$str $n end
]
2584 # Code to implement multiple views
2586 proc newview
{ishighlight
} {
2587 global nextviewnum newviewname newviewperm uifont newishighlight
2588 global newviewargs revtreeargs
2590 set newishighlight
$ishighlight
2592 if {[winfo exists
$top]} {
2596 set newviewname
($nextviewnum) "View $nextviewnum"
2597 set newviewperm
($nextviewnum) 0
2598 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
2599 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
2604 global viewname viewperm newviewname newviewperm
2605 global viewargs newviewargs
2607 set top .gitkvedit-
$curview
2608 if {[winfo exists
$top]} {
2612 set newviewname
($curview) $viewname($curview)
2613 set newviewperm
($curview) $viewperm($curview)
2614 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
2615 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
2618 proc vieweditor
{top n title
} {
2619 global newviewname newviewperm viewfiles
2623 wm title
$top $title
2624 label
$top.
nl -text [mc
"Name"] -font uifont
2625 entry
$top.name
-width 20 -textvariable newviewname
($n) -font uifont
2626 grid
$top.
nl $top.name
-sticky w
-pady 5
2627 checkbutton
$top.perm
-text [mc
"Remember this view"] -variable newviewperm
($n) \
2629 grid
$top.perm
- -pady 5 -sticky w
2630 message
$top.al
-aspect 1000 -font uifont \
2631 -text [mc
"Commits to include (arguments to git rev-list):"]
2632 grid
$top.al
- -sticky w
-pady 5
2633 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
2634 -background white
-font uifont
2635 grid
$top.args
- -sticky ew
-padx 5
2636 message
$top.l
-aspect 1000 -font uifont \
2637 -text [mc
"Enter files and directories to include, one per line:"]
2638 grid
$top.l
- -sticky w
2639 text
$top.t
-width 40 -height 10 -background white
-font uifont
2640 if {[info exists viewfiles
($n)]} {
2641 foreach f
$viewfiles($n) {
2642 $top.t insert end
$f
2643 $top.t insert end
"\n"
2645 $top.t delete
{end
- 1c
} end
2646 $top.t mark
set insert
0.0
2648 grid
$top.t
- -sticky ew
-padx 5
2650 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n] \
2652 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top] \
2654 grid
$top.buts.ok
$top.buts.can
2655 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
2656 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
2657 grid
$top.buts
- -pady 10 -sticky ew
2661 proc doviewmenu
{m first cmd op argv
} {
2662 set nmenu
[$m index end
]
2663 for {set i
$first} {$i <= $nmenu} {incr i
} {
2664 if {[$m entrycget
$i -command] eq
$cmd} {
2665 eval $m $op $i $argv
2671 proc allviewmenus
{n op args
} {
2674 doviewmenu .bar.view
5 [list showview
$n] $op $args
2675 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2678 proc newviewok
{top n
} {
2679 global nextviewnum newviewperm newviewname newishighlight
2680 global viewname viewfiles viewperm selectedview curview
2681 global viewargs newviewargs viewhlmenu
2684 set newargs
[shellsplit
$newviewargs($n)]
2686 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
2692 foreach f
[split [$top.t get
0.0 end
] "\n"] {
2693 set ft
[string trim
$f]
2698 if {![info exists viewfiles
($n)]} {
2699 # creating a new view
2701 set viewname
($n) $newviewname($n)
2702 set viewperm
($n) $newviewperm($n)
2703 set viewfiles
($n) $files
2704 set viewargs
($n) $newargs
2706 if {!$newishighlight} {
2709 run addvhighlight
$n
2712 # editing an existing view
2713 set viewperm
($n) $newviewperm($n)
2714 if {$newviewname($n) ne
$viewname($n)} {
2715 set viewname
($n) $newviewname($n)
2716 doviewmenu .bar.view
5 [list showview
$n] \
2717 entryconf
[list
-label $viewname($n)]
2718 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2719 # entryconf [list -label $viewname($n) -value $viewname($n)]
2721 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n)} {
2722 set viewfiles
($n) $files
2723 set viewargs
($n) $newargs
2724 if {$curview == $n} {
2729 catch
{destroy
$top}
2733 global curview viewperm hlview selectedhlview
2735 if {$curview == 0} return
2736 if {[info exists hlview
] && $hlview == $curview} {
2737 set selectedhlview
[mc
"None"]
2740 allviewmenus
$curview delete
2741 set viewperm
($curview) 0
2745 proc addviewmenu
{n
} {
2746 global viewname viewhlmenu
2748 .bar.view add radiobutton
-label $viewname($n) \
2749 -command [list showview
$n] -variable selectedview
-value $n
2750 #$viewhlmenu add radiobutton -label $viewname($n) \
2751 # -command [list addvhighlight $n] -variable selectedhlview
2755 global curview viewfiles cached_commitrow ordertok
2756 global displayorder parentlist rowidlist rowisopt rowfinal
2757 global colormap rowtextx nextcolor canvxmax
2758 global numcommits viewcomplete
2759 global selectedline currentid canv canvy0
2761 global pending_select
2763 global selectedview selectfirst
2764 global hlview selectedhlview commitinterest
2766 if {$n == $curview} return
2768 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2769 set span
[$canv yview
]
2770 set ytop
[expr {[lindex
$span 0] * $ymax}]
2771 set ybot
[expr {[lindex
$span 1] * $ymax}]
2772 set yscreen
[expr {($ybot - $ytop) / 2}]
2773 if {[info exists selectedline
]} {
2774 set selid
$currentid
2775 set y
[yc
$selectedline]
2776 if {$ytop < $y && $y < $ybot} {
2777 set yscreen
[expr {$y - $ytop}]
2779 } elseif
{[info exists pending_select
]} {
2780 set selid
$pending_select
2781 unset pending_select
2785 catch
{unset treediffs
}
2787 if {[info exists hlview
] && $hlview == $n} {
2789 set selectedhlview
[mc
"None"]
2791 catch
{unset commitinterest
}
2792 catch
{unset cached_commitrow
}
2793 catch
{unset ordertok
}
2797 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2798 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2801 if {![info exists viewcomplete
($n)]} {
2803 set pending_select
$selid
2814 set numcommits
$commitidx($n)
2816 catch
{unset colormap
}
2817 catch
{unset rowtextx
}
2819 set canvxmax
[$canv cget
-width]
2826 if {$selid ne
{} && [commitinview
$selid $n]} {
2827 set row
[rowofcommit
$selid]
2828 # try to get the selected row in the same position on the screen
2829 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2830 set ytop
[expr {[yc
$row] - $yscreen}]
2834 set yf
[expr {$ytop * 1.0 / $ymax}]
2836 allcanvs yview moveto
$yf
2840 } elseif
{$selid ne
{}} {
2841 set pending_select
$selid
2843 set row
[first_real_row
]
2844 if {$row < $numcommits} {
2850 if {!$viewcomplete($n)} {
2851 if {$numcommits == 0} {
2852 show_status
[mc
"Reading commits..."]
2854 } elseif
{$numcommits == 0} {
2855 show_status
[mc
"No commits selected"]
2859 # Stuff relating to the highlighting facility
2861 proc ishighlighted
{row
} {
2862 global vhighlights fhighlights nhighlights rhighlights
2864 if {[info exists nhighlights
($row)] && $nhighlights($row) > 0} {
2865 return $nhighlights($row)
2867 if {[info exists vhighlights
($row)] && $vhighlights($row) > 0} {
2868 return $vhighlights($row)
2870 if {[info exists fhighlights
($row)] && $fhighlights($row) > 0} {
2871 return $fhighlights($row)
2873 if {[info exists rhighlights
($row)] && $rhighlights($row) > 0} {
2874 return $rhighlights($row)
2879 proc bolden
{row font
} {
2880 global canv linehtag selectedline boldrows
2882 lappend boldrows
$row
2883 $canv itemconf
$linehtag($row) -font $font
2884 if {[info exists selectedline
] && $row == $selectedline} {
2886 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2887 -outline {{}} -tags secsel \
2888 -fill [$canv cget
-selectbackground]]
2893 proc bolden_name
{row font
} {
2894 global canv2 linentag selectedline boldnamerows
2896 lappend boldnamerows
$row
2897 $canv2 itemconf
$linentag($row) -font $font
2898 if {[info exists selectedline
] && $row == $selectedline} {
2899 $canv2 delete secsel
2900 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2901 -outline {{}} -tags secsel \
2902 -fill [$canv2 cget
-selectbackground]]
2911 foreach row
$boldrows {
2912 if {![ishighlighted
$row]} {
2913 bolden
$row mainfont
2915 lappend stillbold
$row
2918 set boldrows
$stillbold
2921 proc addvhighlight
{n
} {
2922 global hlview viewcomplete curview vhl_done vhighlights commitidx
2924 if {[info exists hlview
]} {
2928 if {$n != $curview && ![info exists viewcomplete
($n)]} {
2931 set vhl_done
$commitidx($hlview)
2932 if {$vhl_done > 0} {
2937 proc delvhighlight
{} {
2938 global hlview vhighlights
2940 if {![info exists hlview
]} return
2942 catch
{unset vhighlights
}
2946 proc vhighlightmore
{} {
2947 global hlview vhl_done commitidx vhighlights curview
2949 set max
$commitidx($hlview)
2950 set vr
[visiblerows
]
2951 set r0
[lindex
$vr 0]
2952 set r1
[lindex
$vr 1]
2953 for {set i
$vhl_done} {$i < $max} {incr i
} {
2954 set id
[commitonrow
$i $hlview]
2955 if {[commitinview
$id $curview]} {
2956 set row
[rowofcommit
$id]
2957 if {$r0 <= $row && $row <= $r1} {
2958 if {![highlighted
$row]} {
2959 bolden
$row mainfontbold
2961 set vhighlights
($row) 1
2968 proc askvhighlight
{row id
} {
2969 global hlview vhighlights iddrawn
2971 if {[commitinview
$id $hlview]} {
2972 if {[info exists iddrawn
($id)] && ![ishighlighted
$row]} {
2973 bolden
$row mainfontbold
2975 set vhighlights
($row) 1
2977 set vhighlights
($row) 0
2981 proc hfiles_change
{} {
2982 global highlight_files filehighlight fhighlights fh_serial
2983 global highlight_paths gdttype
2985 if {[info exists filehighlight
]} {
2986 # delete previous highlights
2987 catch
{close
$filehighlight}
2989 catch
{unset fhighlights
}
2991 unhighlight_filelist
2993 set highlight_paths
{}
2994 after cancel do_file_hl
$fh_serial
2996 if {$highlight_files ne
{}} {
2997 after
300 do_file_hl
$fh_serial
3001 proc gdttype_change
{name ix op
} {
3002 global gdttype highlight_files findstring findpattern
3005 if {$findstring ne
{}} {
3006 if {$gdttype eq
[mc
"containing:"]} {
3007 if {$highlight_files ne
{}} {
3008 set highlight_files
{}
3013 if {$findpattern ne
{}} {
3017 set highlight_files
$findstring
3022 # enable/disable findtype/findloc menus too
3025 proc find_change
{name ix op
} {
3026 global gdttype findstring highlight_files
3029 if {$gdttype eq
[mc
"containing:"]} {
3032 if {$highlight_files ne
$findstring} {
3033 set highlight_files
$findstring
3040 proc findcom_change args
{
3041 global nhighlights boldnamerows
3042 global findpattern findtype findstring gdttype
3045 # delete previous highlights, if any
3046 foreach row
$boldnamerows {
3047 bolden_name
$row mainfont
3050 catch
{unset nhighlights
}
3053 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
3055 } elseif
{$findtype eq
[mc
"Regexp"]} {
3056 set findpattern
$findstring
3058 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3060 set findpattern
"*$e*"
3064 proc makepatterns
{l
} {
3067 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3068 if {[string index
$ee end
] eq
"/"} {
3078 proc do_file_hl
{serial
} {
3079 global highlight_files filehighlight highlight_paths gdttype fhl_list
3081 if {$gdttype eq
[mc
"touching paths:"]} {
3082 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
3083 set highlight_paths
[makepatterns
$paths]
3085 set gdtargs
[concat
-- $paths]
3086 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
3087 set gdtargs
[list
"-S$highlight_files"]
3089 # must be "containing:", i.e. we're searching commit info
3092 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
3093 set filehighlight
[open
$cmd r
+]
3094 fconfigure
$filehighlight -blocking 0
3095 filerun
$filehighlight readfhighlight
3101 proc flushhighlights
{} {
3102 global filehighlight fhl_list
3104 if {[info exists filehighlight
]} {
3106 puts
$filehighlight ""
3107 flush
$filehighlight
3111 proc askfilehighlight
{row id
} {
3112 global filehighlight fhighlights fhl_list
3114 lappend fhl_list
$id
3115 set fhighlights
($row) -1
3116 puts
$filehighlight $id
3119 proc readfhighlight
{} {
3120 global filehighlight fhighlights curview iddrawn
3121 global fhl_list find_dirn
3123 if {![info exists filehighlight
]} {
3127 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
3128 set line
[string trim
$line]
3129 set i
[lsearch
-exact $fhl_list $line]
3130 if {$i < 0} continue
3131 for {set j
0} {$j < $i} {incr j
} {
3132 set id
[lindex
$fhl_list $j]
3133 if {[commitinview
$id $curview]} {
3134 set fhighlights
([rowofcommit
$id]) 0
3137 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
3138 if {$line eq
{}} continue
3139 if {![commitinview
$line $curview]} continue
3140 set row
[rowofcommit
$line]
3141 if {[info exists iddrawn
($line)] && ![ishighlighted
$row]} {
3142 bolden
$row mainfontbold
3144 set fhighlights
($row) 1
3146 if {[eof
$filehighlight]} {
3148 puts
"oops, git diff-tree died"
3149 catch
{close
$filehighlight}
3153 if {[info exists find_dirn
]} {
3159 proc doesmatch
{f
} {
3160 global findtype findpattern
3162 if {$findtype eq
[mc
"Regexp"]} {
3163 return [regexp
$findpattern $f]
3164 } elseif
{$findtype eq
[mc
"IgnCase"]} {
3165 return [string match
-nocase $findpattern $f]
3167 return [string match
$findpattern $f]
3171 proc askfindhighlight
{row id
} {
3172 global nhighlights commitinfo iddrawn
3174 global markingmatches
3176 if {![info exists commitinfo
($id)]} {
3179 set info
$commitinfo($id)
3181 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
3182 foreach f
$info ty
$fldtypes {
3183 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
3185 if {$ty eq
[mc
"Author"]} {
3192 if {$isbold && [info exists iddrawn
($id)]} {
3193 if {![ishighlighted
$row]} {
3194 bolden
$row mainfontbold
3196 bolden_name
$row mainfontbold
3199 if {$markingmatches} {
3200 markrowmatches
$row $id
3203 set nhighlights
($row) $isbold
3206 proc markrowmatches
{row id
} {
3207 global canv canv2 linehtag linentag commitinfo findloc
3209 set headline
[lindex
$commitinfo($id) 0]
3210 set author
[lindex
$commitinfo($id) 1]
3211 $canv delete match
$row
3212 $canv2 delete match
$row
3213 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
3214 set m
[findmatches
$headline]
3216 markmatches
$canv $row $headline $linehtag($row) $m \
3217 [$canv itemcget
$linehtag($row) -font] $row
3220 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
3221 set m
[findmatches
$author]
3223 markmatches
$canv2 $row $author $linentag($row) $m \
3224 [$canv2 itemcget
$linentag($row) -font] $row
3229 proc vrel_change
{name ix op
} {
3230 global highlight_related
3233 if {$highlight_related ne
[mc
"None"]} {
3238 # prepare for testing whether commits are descendents or ancestors of a
3239 proc rhighlight_sel
{a
} {
3240 global descendent desc_todo ancestor anc_todo
3241 global highlight_related rhighlights
3243 catch
{unset descendent
}
3244 set desc_todo
[list
$a]
3245 catch
{unset ancestor
}
3246 set anc_todo
[list
$a]
3247 if {$highlight_related ne
[mc
"None"]} {
3253 proc rhighlight_none
{} {
3256 catch
{unset rhighlights
}
3260 proc is_descendent
{a
} {
3261 global curview children descendent desc_todo
3264 set la
[rowofcommit
$a]
3268 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3269 set do [lindex
$todo $i]
3270 if {[rowofcommit
$do] < $la} {
3271 lappend leftover
$do
3274 foreach nk
$children($v,$do) {
3275 if {![info exists descendent
($nk)]} {
3276 set descendent
($nk) 1
3284 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3288 set descendent
($a) 0
3289 set desc_todo
$leftover
3292 proc is_ancestor
{a
} {
3293 global curview parents ancestor anc_todo
3296 set la
[rowofcommit
$a]
3300 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3301 set do [lindex
$todo $i]
3302 if {![commitinview
$do $v] ||
[rowofcommit
$do] > $la} {
3303 lappend leftover
$do
3306 foreach np
$parents($v,$do) {
3307 if {![info exists ancestor
($np)]} {
3316 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3321 set anc_todo
$leftover
3324 proc askrelhighlight
{row id
} {
3325 global descendent highlight_related iddrawn rhighlights
3326 global selectedline ancestor
3328 if {![info exists selectedline
]} return
3330 if {$highlight_related eq
[mc
"Descendent"] ||
3331 $highlight_related eq
[mc
"Not descendent"]} {
3332 if {![info exists descendent
($id)]} {
3335 if {$descendent($id) == ($highlight_related eq
[mc
"Descendent"])} {
3338 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
3339 $highlight_related eq
[mc
"Not ancestor"]} {
3340 if {![info exists ancestor
($id)]} {
3343 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
3347 if {[info exists iddrawn
($id)]} {
3348 if {$isbold && ![ishighlighted
$row]} {
3349 bolden
$row mainfontbold
3352 set rhighlights
($row) $isbold
3355 # Graph layout functions
3357 proc shortids
{ids
} {
3360 if {[llength
$id] > 1} {
3361 lappend res
[shortids
$id]
3362 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
3363 lappend res
[string range
$id 0 7]
3374 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
3375 if {($n & $mask) != 0} {
3376 set ret
[concat
$ret $o]
3378 set o
[concat
$o $o]
3383 proc ordertoken
{id
} {
3384 global ordertok curview varcid varcstart varctok curview parents children
3385 global nullid nullid2
3387 if {[info exists ordertok
($id)]} {
3388 return $ordertok($id)
3393 if {[info exists varcid
($curview,$id)]} {
3394 set a
$varcid($curview,$id)
3395 set p
[lindex
$varcstart($curview) $a]
3397 set p
[lindex
$children($curview,$id) 0]
3399 if {[info exists ordertok
($p)]} {
3400 set tok
$ordertok($p)
3403 set id
[first_real_child
$curview,$p]
3406 set tok
[lindex
$varctok($curview) $a]
3409 if {[llength
$parents($curview,$id)] == 1} {
3410 lappend todo
[list
$p {}]
3412 set j
[lsearch
-exact $parents($curview,$id) $p]
3414 puts
"oops didn't find [shortids $p] in parents of [shortids $id]"
3416 lappend todo
[list
$p [strrep
$j]]
3419 for {set i
[llength
$todo]} {[incr i
-1] >= 0} {} {
3420 set p
[lindex
$todo $i 0]
3421 append tok
[lindex
$todo $i 1]
3422 set ordertok
($p) $tok
3424 set ordertok
($origid) $tok
3428 # Work out where id should go in idlist so that order-token
3429 # values increase from left to right
3430 proc idcol
{idlist id
{i
0}} {
3431 set t
[ordertoken
$id]
3435 if {$i >= [llength
$idlist] ||
$t < [ordertoken
[lindex
$idlist $i]]} {
3436 if {$i > [llength
$idlist]} {
3437 set i
[llength
$idlist]
3439 while {[incr i
-1] >= 0 && $t < [ordertoken
[lindex
$idlist $i]]} {}
3442 if {$t > [ordertoken
[lindex
$idlist $i]]} {
3443 while {[incr i
] < [llength
$idlist] &&
3444 $t >= [ordertoken
[lindex
$idlist $i]]} {}
3450 proc initlayout
{} {
3451 global rowidlist rowisopt rowfinal displayorder parentlist
3452 global numcommits canvxmax canv
3454 global colormap rowtextx
3464 set canvxmax
[$canv cget
-width]
3465 catch
{unset colormap
}
3466 catch
{unset rowtextx
}
3470 proc setcanvscroll
{} {
3471 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3473 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3474 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
3475 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
3476 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
3479 proc visiblerows
{} {
3480 global canv numcommits linespc
3482 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3483 if {$ymax eq
{} ||
$ymax == 0} return
3485 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
3486 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
3490 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
3491 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
3492 if {$r1 >= $numcommits} {
3493 set r1
[expr {$numcommits - 1}]
3495 return [list
$r0 $r1]
3498 proc layoutmore
{} {
3499 global commitidx viewcomplete curview
3500 global numcommits pending_select selectedline curview
3501 global selectfirst lastscrollset commitinterest
3503 set canshow
$commitidx($curview)
3504 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3505 if {$numcommits == 0} {
3509 set prev
$numcommits
3510 set numcommits
$canshow
3511 set t
[clock clicks
-milliseconds]
3512 if {$prev < 100 ||
$viewcomplete($curview) ||
$t - $lastscrollset > 500} {
3513 set lastscrollset
$t
3516 set rows
[visiblerows
]
3517 set r1
[lindex
$rows 1]
3518 if {$r1 >= $canshow} {
3519 set r1
[expr {$canshow - 1}]
3524 if {[info exists pending_select
] &&
3525 [commitinview
$pending_select $curview]} {
3526 selectline
[rowofcommit
$pending_select] 1
3529 if {[info exists selectedline
] ||
[info exists pending_select
]} {
3532 set l
[first_real_row
]
3539 proc doshowlocalchanges
{} {
3540 global curview mainheadid
3542 if {[commitinview
$mainheadid $curview]} {
3545 lappend commitinterest
($mainheadid) {dodiffindex
}
3549 proc dohidelocalchanges
{} {
3550 global nullid nullid2 lserial curview
3552 if {[commitinview
$nullid $curview]} {
3553 removerow
$nullid $curview
3555 if {[commitinview
$nullid2 $curview]} {
3556 removerow
$nullid2 $curview
3561 # spawn off a process to do git diff-index --cached HEAD
3562 proc dodiffindex
{} {
3563 global lserial showlocalchanges
3565 if {!$showlocalchanges} return
3567 set fd
[open
"|git diff-index --cached HEAD" r
]
3568 fconfigure
$fd -blocking 0
3569 filerun
$fd [list readdiffindex
$fd $lserial]
3572 proc readdiffindex
{fd serial
} {
3573 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3576 if {[gets
$fd line
] < 0} {
3582 # we only need to see one line and we don't really care what it says...
3585 if {$serial != $lserial} {
3589 # now see if there are any local changes not checked in to the index
3590 set fd
[open
"|git diff-files" r
]
3591 fconfigure
$fd -blocking 0
3592 filerun
$fd [list readdifffiles
$fd $serial]
3594 if {$isdiff && ![commitinview
$nullid2 $curview]} {
3595 # add the line for the changes in the index to the graph
3596 set hl
[mc
"Local changes checked in to index but not committed"]
3597 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
3598 set commitdata
($nullid2) "\n $hl\n"
3599 if {[commitinview
$nullid $curview]} {
3600 removerow
$nullid $curview
3602 insertrow
$nullid2 $mainheadid $curview
3603 } elseif
{!$isdiff && [commitinview
$nullid2 $curview]} {
3604 removerow
$nullid2 $curview
3609 proc readdifffiles
{fd serial
} {
3610 global mainheadid nullid nullid2 curview
3611 global commitinfo commitdata lserial
3614 if {[gets
$fd line
] < 0} {
3620 # we only need to see one line and we don't really care what it says...
3623 if {$serial != $lserial} {
3627 if {$isdiff && ![commitinview
$nullid $curview]} {
3628 # add the line for the local diff to the graph
3629 set hl
[mc
"Local uncommitted changes, not checked in to index"]
3630 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
3631 set commitdata
($nullid) "\n $hl\n"
3632 if {[commitinview
$nullid2 $curview]} {
3637 insertrow
$nullid $p $curview
3638 } elseif
{!$isdiff && [commitinview
$nullid $curview]} {
3639 removerow
$nullid $curview
3644 proc nextuse
{id row
} {
3645 global curview children
3647 if {[info exists children
($curview,$id)]} {
3648 foreach kid
$children($curview,$id) {
3649 if {![commitinview
$kid $curview]} {
3652 if {[rowofcommit
$kid] > $row} {
3653 return [rowofcommit
$kid]
3657 if {[commitinview
$id $curview]} {
3658 return [rowofcommit
$id]
3663 proc prevuse
{id row
} {
3664 global curview children
3667 if {[info exists children
($curview,$id)]} {
3668 foreach kid
$children($curview,$id) {
3669 if {![commitinview
$kid $curview]} break
3670 if {[rowofcommit
$kid] < $row} {
3671 set ret
[rowofcommit
$kid]
3678 proc make_idlist
{row
} {
3679 global displayorder parentlist uparrowlen downarrowlen mingaplen
3680 global commitidx curview children
3682 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
3686 set ra
[expr {$row - $downarrowlen}]
3690 set rb
[expr {$row + $uparrowlen}]
3691 if {$rb > $commitidx($curview)} {
3692 set rb
$commitidx($curview)
3694 make_disporder
$r [expr {$rb + 1}]
3696 for {} {$r < $ra} {incr r
} {
3697 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3698 foreach p
[lindex
$parentlist $r] {
3699 if {$p eq
$nextid} continue
3700 set rn
[nextuse
$p $r]
3702 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3703 lappend ids
[list
[ordertoken
$p] $p]
3707 for {} {$r < $row} {incr r
} {
3708 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3709 foreach p
[lindex
$parentlist $r] {
3710 if {$p eq
$nextid} continue
3711 set rn
[nextuse
$p $r]
3712 if {$rn < 0 ||
$rn >= $row} {
3713 lappend ids
[list
[ordertoken
$p] $p]
3717 set id
[lindex
$displayorder $row]
3718 lappend ids
[list
[ordertoken
$id] $id]
3720 foreach p
[lindex
$parentlist $r] {
3721 set firstkid
[lindex
$children($curview,$p) 0]
3722 if {[rowofcommit
$firstkid] < $row} {
3723 lappend ids
[list
[ordertoken
$p] $p]
3727 set id
[lindex
$displayorder $r]
3729 set firstkid
[lindex
$children($curview,$id) 0]
3730 if {$firstkid ne
{} && [rowofcommit
$firstkid] < $row} {
3731 lappend ids
[list
[ordertoken
$id] $id]
3736 foreach idx
[lsort
-unique $ids] {
3737 lappend idlist
[lindex
$idx 1]
3742 proc rowsequal
{a b
} {
3743 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3744 set a
[lreplace
$a $i $i]
3746 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3747 set b
[lreplace
$b $i $i]
3749 return [expr {$a eq
$b}]
3752 proc makeupline
{id row rend
col} {
3753 global rowidlist uparrowlen downarrowlen mingaplen
3755 for {set r
$rend} {1} {set r
$rstart} {
3756 set rstart
[prevuse
$id $r]
3757 if {$rstart < 0} return
3758 if {$rstart < $row} break
3760 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3761 set rstart
[expr {$rend - $uparrowlen - 1}]
3763 for {set r
$rstart} {[incr r
] <= $row} {} {
3764 set idlist
[lindex
$rowidlist $r]
3765 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3766 set col [idcol
$idlist $id $col]
3767 lset rowidlist
$r [linsert
$idlist $col $id]
3773 proc layoutrows
{row endrow
} {
3774 global rowidlist rowisopt rowfinal displayorder
3775 global uparrowlen downarrowlen maxwidth mingaplen
3776 global children parentlist
3777 global commitidx viewcomplete curview
3779 make_disporder
[expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3782 set rm1
[expr {$row - 1}]
3783 foreach id
[lindex
$rowidlist $rm1] {
3788 set final
[lindex
$rowfinal $rm1]
3790 for {} {$row < $endrow} {incr row
} {
3791 set rm1
[expr {$row - 1}]
3792 if {$rm1 < 0 ||
$idlist eq
{}} {
3793 set idlist
[make_idlist
$row]
3796 set id
[lindex
$displayorder $rm1]
3797 set col [lsearch
-exact $idlist $id]
3798 set idlist
[lreplace
$idlist $col $col]
3799 foreach p
[lindex
$parentlist $rm1] {
3800 if {[lsearch
-exact $idlist $p] < 0} {
3801 set col [idcol
$idlist $p $col]
3802 set idlist
[linsert
$idlist $col $p]
3803 # if not the first child, we have to insert a line going up
3804 if {$id ne
[lindex
$children($curview,$p) 0]} {
3805 makeupline
$p $rm1 $row $col
3809 set id
[lindex
$displayorder $row]
3810 if {$row > $downarrowlen} {
3811 set termrow
[expr {$row - $downarrowlen - 1}]
3812 foreach p
[lindex
$parentlist $termrow] {
3813 set i
[lsearch
-exact $idlist $p]
3814 if {$i < 0} continue
3815 set nr
[nextuse
$p $termrow]
3816 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3817 set idlist
[lreplace
$idlist $i $i]
3821 set col [lsearch
-exact $idlist $id]
3823 set col [idcol
$idlist $id]
3824 set idlist
[linsert
$idlist $col $id]
3825 if {$children($curview,$id) ne
{}} {
3826 makeupline
$id $rm1 $row $col
3829 set r
[expr {$row + $uparrowlen - 1}]
3830 if {$r < $commitidx($curview)} {
3832 foreach p
[lindex
$parentlist $r] {
3833 if {[lsearch
-exact $idlist $p] >= 0} continue
3834 set fk
[lindex
$children($curview,$p) 0]
3835 if {[rowofcommit
$fk] < $row} {
3836 set x
[idcol
$idlist $p $x]
3837 set idlist
[linsert
$idlist $x $p]
3840 if {[incr r
] < $commitidx($curview)} {
3841 set p
[lindex
$displayorder $r]
3842 if {[lsearch
-exact $idlist $p] < 0} {
3843 set fk
[lindex
$children($curview,$p) 0]
3844 if {$fk ne
{} && [rowofcommit
$fk] < $row} {
3845 set x
[idcol
$idlist $p $x]
3846 set idlist
[linsert
$idlist $x $p]
3852 if {$final && !$viewcomplete($curview) &&
3853 $row + $uparrowlen + $mingaplen + $downarrowlen
3854 >= $commitidx($curview)} {
3857 set l
[llength
$rowidlist]
3859 lappend rowidlist
$idlist
3861 lappend rowfinal
$final
3862 } elseif
{$row < $l} {
3863 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3864 lset rowidlist
$row $idlist
3867 lset rowfinal
$row $final
3869 set pad
[ntimes
[expr {$row - $l}] {}]
3870 set rowidlist
[concat
$rowidlist $pad]
3871 lappend rowidlist
$idlist
3872 set rowfinal
[concat
$rowfinal $pad]
3873 lappend rowfinal
$final
3874 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3880 proc changedrow
{row
} {
3881 global displayorder iddrawn rowisopt need_redisplay
3883 set l
[llength
$rowisopt]
3885 lset rowisopt
$row 0
3886 if {$row + 1 < $l} {
3887 lset rowisopt
[expr {$row + 1}] 0
3888 if {$row + 2 < $l} {
3889 lset rowisopt
[expr {$row + 2}] 0
3893 set id
[lindex
$displayorder $row]
3894 if {[info exists iddrawn
($id)]} {
3895 set need_redisplay
1
3899 proc insert_pad
{row
col npad
} {
3902 set pad
[ntimes
$npad {}]
3903 set idlist
[lindex
$rowidlist $row]
3904 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3905 set aft
[lrange
$idlist $col end
]
3906 set i
[lsearch
-exact $aft {}]
3908 set aft
[lreplace
$aft $i $i]
3910 lset rowidlist
$row [concat
$bef $pad $aft]
3914 proc optimize_rows
{row
col endrow
} {
3915 global rowidlist rowisopt displayorder curview children
3920 for {} {$row < $endrow} {incr row
; set col 0} {
3921 if {[lindex
$rowisopt $row]} continue
3923 set y0
[expr {$row - 1}]
3924 set ym
[expr {$row - 2}]
3925 set idlist
[lindex
$rowidlist $row]
3926 set previdlist
[lindex
$rowidlist $y0]
3927 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3929 set pprevidlist
[lindex
$rowidlist $ym]
3930 if {$pprevidlist eq
{}} continue
3936 for {} {$col < [llength
$idlist]} {incr
col} {
3937 set id
[lindex
$idlist $col]
3938 if {[lindex
$previdlist $col] eq
$id} continue
3943 set x0
[lsearch
-exact $previdlist $id]
3944 if {$x0 < 0} continue
3945 set z
[expr {$x0 - $col}]
3949 set xm
[lsearch
-exact $pprevidlist $id]
3951 set z0
[expr {$xm - $x0}]
3955 # if row y0 is the first child of $id then it's not an arrow
3956 if {[lindex
$children($curview,$id) 0] ne
3957 [lindex
$displayorder $y0]} {
3961 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3962 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3965 # Looking at lines from this row to the previous row,
3966 # make them go straight up if they end in an arrow on
3967 # the previous row; otherwise make them go straight up
3969 if {$z < -1 ||
($z < 0 && $isarrow)} {
3970 # Line currently goes left too much;
3971 # insert pads in the previous row, then optimize it
3972 set npad
[expr {-1 - $z + $isarrow}]
3973 insert_pad
$y0 $x0 $npad
3975 optimize_rows
$y0 $x0 $row
3977 set previdlist
[lindex
$rowidlist $y0]
3978 set x0
[lsearch
-exact $previdlist $id]
3979 set z
[expr {$x0 - $col}]
3981 set pprevidlist
[lindex
$rowidlist $ym]
3982 set xm
[lsearch
-exact $pprevidlist $id]
3983 set z0
[expr {$xm - $x0}]
3985 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3986 # Line currently goes right too much;
3987 # insert pads in this line
3988 set npad
[expr {$z - 1 + $isarrow}]
3989 insert_pad
$row $col $npad
3990 set idlist
[lindex
$rowidlist $row]
3992 set z
[expr {$x0 - $col}]
3995 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3996 # this line links to its first child on row $row-2
3997 set id
[lindex
$displayorder $ym]
3998 set xc
[lsearch
-exact $pprevidlist $id]
4000 set z0
[expr {$xc - $x0}]
4003 # avoid lines jigging left then immediately right
4004 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
4005 insert_pad
$y0 $x0 1
4007 optimize_rows
$y0 $x0 $row
4008 set previdlist
[lindex
$rowidlist $y0]
4012 # Find the first column that doesn't have a line going right
4013 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
4014 set id
[lindex
$idlist $col]
4015 if {$id eq
{}} break
4016 set x0
[lsearch
-exact $previdlist $id]
4018 # check if this is the link to the first child
4019 set kid
[lindex
$displayorder $y0]
4020 if {[lindex
$children($curview,$id) 0] eq
$kid} {
4021 # it is, work out offset to child
4022 set x0
[lsearch
-exact $previdlist $kid]
4025 if {$x0 <= $col} break
4027 # Insert a pad at that column as long as it has a line and
4028 # isn't the last column
4029 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
4030 set idlist
[linsert
$idlist $col {}]
4031 lset rowidlist
$row $idlist
4039 global canvx0 linespc
4040 return [expr {$canvx0 + $col * $linespc}]
4044 global canvy0 linespc
4045 return [expr {$canvy0 + $row * $linespc}]
4048 proc linewidth
{id
} {
4049 global thickerline lthickness
4052 if {[info exists thickerline
] && $id eq
$thickerline} {
4053 set wid
[expr {2 * $lthickness}]
4058 proc rowranges
{id
} {
4059 global curview children uparrowlen downarrowlen
4062 set kids
$children($curview,$id)
4068 foreach child
$kids {
4069 if {![commitinview
$child $curview]} break
4070 set row
[rowofcommit
$child]
4071 if {![info exists prev
]} {
4072 lappend ret
[expr {$row + 1}]
4074 if {$row <= $prevrow} {
4075 puts
"oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4077 # see if the line extends the whole way from prevrow to row
4078 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4079 [lsearch
-exact [lindex
$rowidlist \
4080 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
4081 # it doesn't, see where it ends
4082 set r
[expr {$prevrow + $downarrowlen}]
4083 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4084 while {[incr r
-1] > $prevrow &&
4085 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4087 while {[incr r
] <= $row &&
4088 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4092 # see where it starts up again
4093 set r
[expr {$row - $uparrowlen}]
4094 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4095 while {[incr r
] < $row &&
4096 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4098 while {[incr r
-1] >= $prevrow &&
4099 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4105 if {$child eq
$id} {
4114 proc drawlineseg
{id row endrow arrowlow
} {
4115 global rowidlist displayorder iddrawn linesegs
4116 global canv colormap linespc curview maxlinelen parentlist
4118 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
4119 set le
[expr {$row + 1}]
4122 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
4128 set x
[lindex
$displayorder $le]
4133 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
4134 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
4150 if {[info exists linesegs
($id)]} {
4151 set lines
$linesegs($id)
4153 set r0
[lindex
$li 0]
4155 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
4165 set li
[lindex
$lines [expr {$i-1}]]
4166 set r1
[lindex
$li 1]
4167 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
4172 set x
[lindex
$cols [expr {$le - $row}]]
4173 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
4174 set dir
[expr {$xp - $x}]
4176 set ith
[lindex
$lines $i 2]
4177 set coords
[$canv coords
$ith]
4178 set ah
[$canv itemcget
$ith -arrow]
4179 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
4180 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
4181 if {$x2 ne
{} && $x - $x2 == $dir} {
4182 set coords
[lrange
$coords 0 end-2
]
4185 set coords
[list
[xc
$le $x] [yc
$le]]
4188 set itl
[lindex
$lines [expr {$i-1}] 2]
4189 set al
[$canv itemcget
$itl -arrow]
4190 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
4191 } elseif
{$arrowlow} {
4192 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
4193 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
4197 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
4198 for {set y
$le} {[incr y
-1] > $row} {} {
4200 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
4201 set ndir
[expr {$xp - $x}]
4202 if {$dir != $ndir ||
$xp < 0} {
4203 lappend coords
[xc
$y $x] [yc
$y]
4209 # join parent line to first child
4210 set ch
[lindex
$displayorder $row]
4211 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
4213 puts
"oops: drawlineseg: child $ch not on row $row"
4214 } elseif
{$xc != $x} {
4215 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
4216 set d
[expr {int
(0.5 * $linespc)}]
4219 set x2
[expr {$x1 - $d}]
4221 set x2
[expr {$x1 + $d}]
4224 set y1
[expr {$y2 + $d}]
4225 lappend coords
$x1 $y1 $x2 $y2
4226 } elseif
{$xc < $x - 1} {
4227 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
4228 } elseif
{$xc > $x + 1} {
4229 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
4233 lappend coords
[xc
$row $x] [yc
$row]
4235 set xn
[xc
$row $xp]
4237 lappend coords
$xn $yn
4241 set t
[$canv create line
$coords -width [linewidth
$id] \
4242 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
4245 set lines
[linsert
$lines $i [list
$row $le $t]]
4247 $canv coords
$ith $coords
4248 if {$arrow ne
$ah} {
4249 $canv itemconf
$ith -arrow $arrow
4251 lset lines
$i 0 $row
4254 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
4255 set ndir
[expr {$xo - $xp}]
4256 set clow
[$canv coords
$itl]
4257 if {$dir == $ndir} {
4258 set clow
[lrange
$clow 2 end
]
4260 set coords
[concat
$coords $clow]
4262 lset lines
[expr {$i-1}] 1 $le
4264 # coalesce two pieces
4266 set b
[lindex
$lines [expr {$i-1}] 0]
4267 set e
[lindex
$lines $i 1]
4268 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
4270 $canv coords
$itl $coords
4271 if {$arrow ne
$al} {
4272 $canv itemconf
$itl -arrow $arrow
4276 set linesegs
($id) $lines
4280 proc drawparentlinks
{id row
} {
4281 global rowidlist canv colormap curview parentlist
4282 global idpos linespc
4284 set rowids
[lindex
$rowidlist $row]
4285 set col [lsearch
-exact $rowids $id]
4286 if {$col < 0} return
4287 set olds
[lindex
$parentlist $row]
4288 set row2
[expr {$row + 1}]
4289 set x
[xc
$row $col]
4292 set d
[expr {int
(0.5 * $linespc)}]
4293 set ymid
[expr {$y + $d}]
4294 set ids
[lindex
$rowidlist $row2]
4295 # rmx = right-most X coord used
4298 set i
[lsearch
-exact $ids $p]
4300 puts
"oops, parent $p of $id not in list"
4303 set x2
[xc
$row2 $i]
4307 set j
[lsearch
-exact $rowids $p]
4309 # drawlineseg will do this one for us
4313 # should handle duplicated parents here...
4314 set coords
[list
$x $y]
4316 # if attaching to a vertical segment, draw a smaller
4317 # slant for visual distinctness
4320 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
4322 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
4324 } elseif
{$i < $col && $i < $j} {
4325 # segment slants towards us already
4326 lappend coords
[xc
$row $j] $y
4328 if {$i < $col - 1} {
4329 lappend coords
[expr {$x2 + $linespc}] $y
4330 } elseif
{$i > $col + 1} {
4331 lappend coords
[expr {$x2 - $linespc}] $y
4333 lappend coords
$x2 $y2
4336 lappend coords
$x2 $y2
4338 set t
[$canv create line
$coords -width [linewidth
$p] \
4339 -fill $colormap($p) -tags lines.
$p]
4343 if {$rmx > [lindex
$idpos($id) 1]} {
4344 lset idpos
($id) 1 $rmx
4349 proc drawlines
{id
} {
4352 $canv itemconf lines.
$id -width [linewidth
$id]
4355 proc drawcmittext
{id row
col} {
4356 global linespc canv canv2 canv3 fgcolor curview
4357 global cmitlisted commitinfo rowidlist parentlist
4358 global rowtextx idpos idtags idheads idotherrefs
4359 global linehtag linentag linedtag selectedline
4360 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4362 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4363 set listed
$cmitlisted($curview,$id)
4364 if {$id eq
$nullid} {
4366 } elseif
{$id eq
$nullid2} {
4369 set ofill
[expr {$listed != 0?
"blue": "white"}]
4371 set x
[xc
$row $col]
4373 set orad
[expr {$linespc / 3}]
4375 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
4376 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4377 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4378 } elseif
{$listed == 2} {
4379 # triangle pointing left for left-side commits
4380 set t
[$canv create polygon \
4381 [expr {$x - $orad}] $y \
4382 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4383 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4384 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4386 # triangle pointing right for right-side commits
4387 set t
[$canv create polygon \
4388 [expr {$x + $orad - 1}] $y \
4389 [expr {$x - $orad}] [expr {$y - $orad}] \
4390 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4391 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4394 $canv bind $t <1> {selcanvline
{} %x
%y
}
4395 set rmx
[llength
[lindex
$rowidlist $row]]
4396 set olds
[lindex
$parentlist $row]
4398 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
4400 set i
[lsearch
-exact $nextids $p]
4406 set xt
[xc
$row $rmx]
4407 set rowtextx
($row) $xt
4408 set idpos
($id) [list
$x $xt $y]
4409 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
4410 ||
[info exists idotherrefs
($id)]} {
4411 set xt
[drawtags
$id $x $xt $y]
4413 set headline
[lindex
$commitinfo($id) 0]
4414 set name
[lindex
$commitinfo($id) 1]
4415 set date [lindex
$commitinfo($id) 2]
4416 set date [formatdate
$date]
4419 set isbold
[ishighlighted
$row]
4421 lappend boldrows
$row
4422 set font mainfontbold
4424 lappend boldnamerows
$row
4425 set nfont mainfontbold
4428 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
4429 -text $headline -font $font -tags text
]
4430 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
4431 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
4432 -text $name -font $nfont -tags text
]
4433 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
4434 -text $date -font mainfont
-tags text
]
4435 if {[info exists selectedline
] && $selectedline == $row} {
4438 set xr
[expr {$xt + [font measure
$font $headline]}]
4439 if {$xr > $canvxmax} {
4445 proc drawcmitrow
{row
} {
4446 global displayorder rowidlist nrows_drawn
4447 global iddrawn markingmatches
4448 global commitinfo numcommits
4449 global filehighlight fhighlights findpattern nhighlights
4450 global hlview vhighlights
4451 global highlight_related rhighlights
4453 if {$row >= $numcommits} return
4455 set id
[lindex
$displayorder $row]
4456 if {[info exists hlview
] && ![info exists vhighlights
($row)]} {
4457 askvhighlight
$row $id
4459 if {[info exists filehighlight
] && ![info exists fhighlights
($row)]} {
4460 askfilehighlight
$row $id
4462 if {$findpattern ne
{} && ![info exists nhighlights
($row)]} {
4463 askfindhighlight
$row $id
4465 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($row)]} {
4466 askrelhighlight
$row $id
4468 if {![info exists iddrawn
($id)]} {
4469 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
4471 puts
"oops, row $row id $id not in list"
4474 if {![info exists commitinfo
($id)]} {
4478 drawcmittext
$id $row $col
4482 if {$markingmatches} {
4483 markrowmatches
$row $id
4487 proc drawcommits
{row
{endrow
{}}} {
4488 global numcommits iddrawn displayorder curview need_redisplay
4489 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4494 if {$endrow eq
{}} {
4497 if {$endrow >= $numcommits} {
4498 set endrow
[expr {$numcommits - 1}]
4501 set rl1
[expr {$row - $downarrowlen - 3}]
4505 set ro1
[expr {$row - 3}]
4509 set r2
[expr {$endrow + $uparrowlen + 3}]
4510 if {$r2 > $numcommits} {
4513 for {set r
$rl1} {$r < $r2} {incr r
} {
4514 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
4518 set rl1
[expr {$r + 1}]
4524 optimize_rows
$ro1 0 $r2
4525 if {$need_redisplay ||
$nrows_drawn > 2000} {
4530 # make the lines join to already-drawn rows either side
4531 set r
[expr {$row - 1}]
4532 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
4535 set er
[expr {$endrow + 1}]
4536 if {$er >= $numcommits ||
4537 ![info exists iddrawn
([lindex
$displayorder $er])]} {
4540 for {} {$r <= $er} {incr r
} {
4541 set id
[lindex
$displayorder $r]
4542 set wasdrawn
[info exists iddrawn
($id)]
4544 if {$r == $er} break
4545 set nextid
[lindex
$displayorder [expr {$r + 1}]]
4546 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
4547 drawparentlinks
$id $r
4549 set rowids
[lindex
$rowidlist $r]
4550 foreach lid
$rowids {
4551 if {$lid eq
{}} continue
4552 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
4554 # see if this is the first child of any of its parents
4555 foreach p
[lindex
$parentlist $r] {
4556 if {[lsearch
-exact $rowids $p] < 0} {
4557 # make this line extend up to the child
4558 set lineend
($p) [drawlineseg
$p $r $er 0]
4562 set lineend
($lid) [drawlineseg
$lid $r $er 1]
4568 proc undolayout
{row
} {
4569 global uparrowlen mingaplen downarrowlen
4570 global rowidlist rowisopt rowfinal need_redisplay
4572 set r
[expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4576 if {[llength
$rowidlist] > $r} {
4578 set rowidlist
[lrange
$rowidlist 0 $r]
4579 set rowfinal
[lrange
$rowfinal 0 $r]
4580 set rowisopt
[lrange
$rowisopt 0 $r]
4581 set need_redisplay
1
4586 proc drawvisible
{} {
4587 global canv linespc curview vrowmod selectedline targetrow targetid
4588 global need_redisplay cscroll numcommits
4590 set fs
[$canv yview
]
4591 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4592 if {$ymax eq
{} ||
$ymax == 0} return
4593 set f0
[lindex
$fs 0]
4594 set f1
[lindex
$fs 1]
4595 set y0
[expr {int
($f0 * $ymax)}]
4596 set y1
[expr {int
($f1 * $ymax)}]
4598 if {[info exists targetid
]} {
4599 if {[commitinview
$targetid $curview]} {
4600 set r
[rowofcommit
$targetid]
4601 if {$r != $targetrow} {
4602 # Fix up the scrollregion and change the scrolling position
4603 # now that our target row has moved.
4604 set diff [expr {($r - $targetrow) * $linespc}]
4607 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4610 set f0
[expr {$y0 / $ymax}]
4611 set f1
[expr {$y1 / $ymax}]
4612 allcanvs yview moveto
$f0
4613 $cscroll set $f0 $f1
4614 set need_redisplay
1
4621 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
4622 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
4623 if {$endrow >= $vrowmod($curview)} {
4624 update_arcrows
$curview
4626 if {[info exists selectedline
] &&
4627 $row <= $selectedline && $selectedline <= $endrow} {
4628 set targetrow
$selectedline
4630 set targetrow
[expr {int
(($row + $endrow) / 2)}]
4632 if {$targetrow >= $numcommits} {
4633 set targetrow
[expr {$numcommits - 1}]
4635 set targetid
[commitonrow
$targetrow]
4636 drawcommits
$row $endrow
4639 proc clear_display
{} {
4640 global iddrawn linesegs need_redisplay nrows_drawn
4641 global vhighlights fhighlights nhighlights rhighlights
4644 catch
{unset iddrawn
}
4645 catch
{unset linesegs
}
4646 catch
{unset vhighlights
}
4647 catch
{unset fhighlights
}
4648 catch
{unset nhighlights
}
4649 catch
{unset rhighlights
}
4650 set need_redisplay
0
4654 proc findcrossings
{id
} {
4655 global rowidlist parentlist numcommits displayorder
4659 foreach
{s e
} [rowranges
$id] {
4660 if {$e >= $numcommits} {
4661 set e
[expr {$numcommits - 1}]
4663 if {$e <= $s} continue
4664 for {set row
$e} {[incr row
-1] >= $s} {} {
4665 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
4667 set olds
[lindex
$parentlist $row]
4668 set kid
[lindex
$displayorder $row]
4669 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
4670 if {$kidx < 0} continue
4671 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
4673 set px
[lsearch
-exact $nextrow $p]
4674 if {$px < 0} continue
4675 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
4676 if {[lsearch
-exact $ccross $p] >= 0} continue
4677 if {$x == $px + ($kidx < $px?
-1: 1)} {
4679 } elseif
{[lsearch
-exact $cross $p] < 0} {
4686 return [concat
$ccross {{}} $cross]
4689 proc assigncolor
{id
} {
4690 global colormap colors nextcolor
4691 global parents children children curview
4693 if {[info exists colormap
($id)]} return
4694 set ncolors
[llength
$colors]
4695 if {[info exists children
($curview,$id)]} {
4696 set kids
$children($curview,$id)
4700 if {[llength
$kids] == 1} {
4701 set child
[lindex
$kids 0]
4702 if {[info exists colormap
($child)]
4703 && [llength
$parents($curview,$child)] == 1} {
4704 set colormap
($id) $colormap($child)
4710 foreach x
[findcrossings
$id] {
4712 # delimiter between corner crossings and other crossings
4713 if {[llength
$badcolors] >= $ncolors - 1} break
4714 set origbad
$badcolors
4716 if {[info exists colormap
($x)]
4717 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
4718 lappend badcolors
$colormap($x)
4721 if {[llength
$badcolors] >= $ncolors} {
4722 set badcolors
$origbad
4724 set origbad
$badcolors
4725 if {[llength
$badcolors] < $ncolors - 1} {
4726 foreach child
$kids {
4727 if {[info exists colormap
($child)]
4728 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
4729 lappend badcolors
$colormap($child)
4731 foreach p
$parents($curview,$child) {
4732 if {[info exists colormap
($p)]
4733 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
4734 lappend badcolors
$colormap($p)
4738 if {[llength
$badcolors] >= $ncolors} {
4739 set badcolors
$origbad
4742 for {set i
0} {$i <= $ncolors} {incr i
} {
4743 set c
[lindex
$colors $nextcolor]
4744 if {[incr nextcolor
] >= $ncolors} {
4747 if {[lsearch
-exact $badcolors $c]} break
4749 set colormap
($id) $c
4752 proc bindline
{t id
} {
4755 $canv bind $t <Enter
> "lineenter %x %y $id"
4756 $canv bind $t <Motion
> "linemotion %x %y $id"
4757 $canv bind $t <Leave
> "lineleave $id"
4758 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4761 proc drawtags
{id x xt y1
} {
4762 global idtags idheads idotherrefs mainhead
4763 global linespc lthickness
4764 global canv rowtextx curview fgcolor bgcolor
4769 if {[info exists idtags
($id)]} {
4770 set marks
$idtags($id)
4771 set ntags
[llength
$marks]
4773 if {[info exists idheads
($id)]} {
4774 set marks
[concat
$marks $idheads($id)]
4775 set nheads
[llength
$idheads($id)]
4777 if {[info exists idotherrefs
($id)]} {
4778 set marks
[concat
$marks $idotherrefs($id)]
4784 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4785 set yt
[expr {$y1 - 0.5 * $linespc}]
4786 set yb
[expr {$yt + $linespc - 1}]
4790 foreach tag
$marks {
4792 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4793 set wid
[font measure mainfontbold
$tag]
4795 set wid
[font measure mainfont
$tag]
4799 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4801 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4802 -width $lthickness -fill black
-tags tag.
$id]
4804 foreach tag
$marks x
$xvals wid
$wvals {
4805 set xl
[expr {$x + $delta}]
4806 set xr
[expr {$x + $delta + $wid + $lthickness}]
4808 if {[incr ntags
-1] >= 0} {
4810 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4811 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4812 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4813 $canv bind $t <1> [list showtag
$tag 1]
4814 set rowtextx
([rowofcommit
$id]) [expr {$xr + $linespc}]
4816 # draw a head or other ref
4817 if {[incr nheads
-1] >= 0} {
4819 if {$tag eq
$mainhead} {
4820 set font mainfontbold
4825 set xl
[expr {$xl - $delta/2}]
4826 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4827 -width 1 -outline black
-fill $col -tags tag.
$id
4828 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4829 set rwid
[font measure mainfont
$remoteprefix]
4830 set xi
[expr {$x + 1}]
4831 set yti
[expr {$yt + 1}]
4832 set xri
[expr {$x + $rwid}]
4833 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4834 -width 0 -fill "#ffddaa" -tags tag.
$id
4837 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4838 -font $font -tags [list tag.
$id text
]]
4840 $canv bind $t <1> [list showtag
$tag 1]
4841 } elseif
{$nheads >= 0} {
4842 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4848 proc xcoord
{i level
ln} {
4849 global canvx0 xspc1 xspc2
4851 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4852 if {$i > 0 && $i == $level} {
4853 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4854 } elseif
{$i > $level} {
4855 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4860 proc show_status
{msg
} {
4864 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4865 -tags text
-fill $fgcolor
4868 # Don't change the text pane cursor if it is currently the hand cursor,
4869 # showing that we are over a sha1 ID link.
4870 proc settextcursor
{c
} {
4871 global ctext curtextcursor
4873 if {[$ctext cget
-cursor] == $curtextcursor} {
4874 $ctext config
-cursor $c
4876 set curtextcursor
$c
4879 proc nowbusy
{what
{name
{}}} {
4880 global isbusy busyname statusw
4882 if {[array names isbusy
] eq
{}} {
4883 . config
-cursor watch
4887 set busyname
($what) $name
4889 $statusw conf
-text $name
4893 proc notbusy
{what
} {
4894 global isbusy maincursor textcursor busyname statusw
4898 if {$busyname($what) ne
{} &&
4899 [$statusw cget
-text] eq
$busyname($what)} {
4900 $statusw conf
-text {}
4903 if {[array names isbusy
] eq
{}} {
4904 . config
-cursor $maincursor
4905 settextcursor
$textcursor
4909 proc findmatches
{f
} {
4910 global findtype findstring
4911 if {$findtype == [mc
"Regexp"]} {
4912 set matches
[regexp
-indices -all -inline $findstring $f]
4915 if {$findtype == [mc
"IgnCase"]} {
4916 set f
[string tolower
$f]
4917 set fs
[string tolower
$fs]
4921 set l
[string length
$fs]
4922 while {[set j
[string first
$fs $f $i]] >= 0} {
4923 lappend matches
[list
$j [expr {$j+$l-1}]]
4924 set i
[expr {$j + $l}]
4930 proc dofind
{{dirn
1} {wrap
1}} {
4931 global findstring findstartline findcurline selectedline numcommits
4932 global gdttype filehighlight fh_serial find_dirn findallowwrap
4934 if {[info exists find_dirn
]} {
4935 if {$find_dirn == $dirn} return
4939 if {$findstring eq
{} ||
$numcommits == 0} return
4940 if {![info exists selectedline
]} {
4941 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4943 set findstartline
$selectedline
4945 set findcurline
$findstartline
4946 nowbusy finding
[mc
"Searching"]
4947 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4948 after cancel do_file_hl
$fh_serial
4949 do_file_hl
$fh_serial
4952 set findallowwrap
$wrap
4956 proc stopfinding
{} {
4957 global find_dirn findcurline fprogcoord
4959 if {[info exists find_dirn
]} {
4969 global commitdata commitinfo numcommits findpattern findloc
4970 global findstartline findcurline findallowwrap
4971 global find_dirn gdttype fhighlights fprogcoord
4972 global curview varcorder vrownum varccommits vrowmod
4974 if {![info exists find_dirn
]} {
4977 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4980 if {$find_dirn > 0} {
4982 if {$l >= $numcommits} {
4985 if {$l <= $findstartline} {
4986 set lim
[expr {$findstartline + 1}]
4989 set moretodo
$findallowwrap
4996 if {$l >= $findstartline} {
4997 set lim
[expr {$findstartline - 1}]
5000 set moretodo
$findallowwrap
5003 set n
[expr {($lim - $l) * $find_dirn}]
5008 if {$l + ($find_dirn > 0?
$n: 1) > $vrowmod($curview)} {
5009 update_arcrows
$curview
5013 set ai
[bsearch
$vrownum($curview) $l]
5014 set a
[lindex
$varcorder($curview) $ai]
5015 set arow
[lindex
$vrownum($curview) $ai]
5016 set ids
[lindex
$varccommits($curview,$a)]
5017 set arowend
[expr {$arow + [llength
$ids]}]
5018 if {$gdttype eq
[mc
"containing:"]} {
5019 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5020 if {$l < $arow ||
$l >= $arowend} {
5022 set a
[lindex
$varcorder($curview) $ai]
5023 set arow
[lindex
$vrownum($curview) $ai]
5024 set ids
[lindex
$varccommits($curview,$a)]
5025 set arowend
[expr {$arow + [llength
$ids]}]
5027 set id
[lindex
$ids [expr {$l - $arow}]]
5028 # shouldn't happen unless git log doesn't give all the commits...
5029 if {![info exists commitdata
($id)] ||
5030 ![doesmatch
$commitdata($id)]} {
5033 if {![info exists commitinfo
($id)]} {
5036 set info
$commitinfo($id)
5037 foreach f
$info ty
$fldtypes {
5038 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
5047 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
5048 if {$l < $arow ||
$l >= $arowend} {
5050 set a
[lindex
$varcorder($curview) $ai]
5051 set arow
[lindex
$vrownum($curview) $ai]
5052 set ids
[lindex
$varccommits($curview,$a)]
5053 set arowend
[expr {$arow + [llength
$ids]}]
5055 set id
[lindex
$ids [expr {$l - $arow}]]
5056 if {![info exists fhighlights
($l)]} {
5057 # this sets fhighlights($l) to -1
5058 askfilehighlight
$l $id
5060 if {$fhighlights($l) > 0} {
5064 if {$fhighlights($l) < 0} {
5067 set findcurline
[expr {$l - $find_dirn}]
5072 if {$found ||
($domore && !$moretodo)} {
5088 set findcurline
[expr {$l - $find_dirn}]
5090 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
5094 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
5099 proc findselectline
{l
} {
5100 global findloc commentend ctext findcurline markingmatches gdttype
5102 set markingmatches
1
5105 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
5106 # highlight the matches in the comments
5107 set f
[$ctext get
1.0 $commentend]
5108 set matches
[findmatches
$f]
5109 foreach match
$matches {
5110 set start
[lindex
$match 0]
5111 set end
[expr {[lindex
$match 1] + 1}]
5112 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
5118 # mark the bits of a headline or author that match a find string
5119 proc markmatches
{canv l str tag matches font row
} {
5122 set bbox
[$canv bbox
$tag]
5123 set x0
[lindex
$bbox 0]
5124 set y0
[lindex
$bbox 1]
5125 set y1
[lindex
$bbox 3]
5126 foreach match
$matches {
5127 set start
[lindex
$match 0]
5128 set end
[lindex
$match 1]
5129 if {$start > $end} continue
5130 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
5131 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
5132 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
5133 [expr {$x0+$xlen+2}] $y1 \
5134 -outline {} -tags [list match
$l matches
] -fill yellow
]
5136 if {[info exists selectedline
] && $row == $selectedline} {
5137 $canv raise
$t secsel
5142 proc unmarkmatches
{} {
5143 global markingmatches
5145 allcanvs delete matches
5146 set markingmatches
0
5150 proc selcanvline
{w x y
} {
5151 global canv canvy0 ctext linespc
5153 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5154 if {$ymax == {}} return
5155 set yfrac
[lindex
[$canv yview
] 0]
5156 set y
[expr {$y + $yfrac * $ymax}]
5157 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
5162 set xmax
[lindex
[$canv cget
-scrollregion] 2]
5163 set xleft
[expr {[lindex
[$canv xview
] 0] * $xmax}]
5164 if {![info exists rowtextx
($l)] ||
$xleft + $x < $rowtextx($l)} return
5170 proc commit_descriptor
{p
} {
5172 if {![info exists commitinfo
($p)]} {
5176 if {[llength
$commitinfo($p)] > 1} {
5177 set l
[lindex
$commitinfo($p) 0]
5182 # append some text to the ctext widget, and make any SHA1 ID
5183 # that we know about be a clickable link.
5184 proc appendwithlinks
{text tags
} {
5185 global ctext linknum curview pendinglinks
5187 set start
[$ctext index
"end - 1c"]
5188 $ctext insert end
$text $tags
5189 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
5193 set linkid
[string range
$text $s $e]
5195 $ctext tag delete link
$linknum
5196 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
5197 setlink
$linkid link
$linknum
5202 proc setlink
{id lk
} {
5203 global curview ctext pendinglinks commitinterest
5205 if {[commitinview
$id $curview]} {
5206 $ctext tag conf
$lk -foreground blue
-underline 1
5207 $ctext tag
bind $lk <1> [list selectline
[rowofcommit
$id] 1]
5208 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
5209 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
5211 lappend pendinglinks
($id) $lk
5212 lappend commitinterest
($id) {makelink
%I
}
5216 proc makelink
{id
} {
5219 if {![info exists pendinglinks
($id)]} return
5220 foreach lk
$pendinglinks($id) {
5223 unset pendinglinks
($id)
5226 proc linkcursor
{w inc
} {
5227 global linkentercount curtextcursor
5229 if {[incr linkentercount
$inc] > 0} {
5230 $w configure
-cursor hand2
5232 $w configure
-cursor $curtextcursor
5233 if {$linkentercount < 0} {
5234 set linkentercount
0
5239 proc viewnextline
{dir
} {
5243 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5244 set wnow
[$canv yview
]
5245 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5246 set newtop
[expr {$wtop + $dir * $linespc}]
5249 } elseif
{$newtop > $ymax} {
5252 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5255 # add a list of tag or branch names at position pos
5256 # returns the number of names inserted
5257 proc appendrefs
{pos ids var
} {
5258 global ctext linknum curview
$var maxrefs
5260 if {[catch
{$ctext index
$pos}]} {
5263 $ctext conf
-state normal
5264 $ctext delete
$pos "$pos lineend"
5267 foreach tag
[set $var\
($id\
)] {
5268 lappend tags
[list
$tag $id]
5271 if {[llength
$tags] > $maxrefs} {
5272 $ctext insert
$pos "many ([llength $tags])"
5274 set tags
[lsort
-index 0 -decreasing $tags]
5277 set id
[lindex
$ti 1]
5280 $ctext tag delete
$lk
5281 $ctext insert
$pos $sep
5282 $ctext insert
$pos [lindex
$ti 0] $lk
5287 $ctext conf
-state disabled
5288 return [llength
$tags]
5291 # called when we have finished computing the nearby tags
5292 proc dispneartags
{delay
} {
5293 global selectedline currentid showneartags tagphase
5295 if {![info exists selectedline
] ||
!$showneartags} return
5296 after cancel dispnexttag
5298 after
200 dispnexttag
5301 after idle dispnexttag
5306 proc dispnexttag
{} {
5307 global selectedline currentid showneartags tagphase ctext
5309 if {![info exists selectedline
] ||
!$showneartags} return
5310 switch
-- $tagphase {
5312 set dtags
[desctags
$currentid]
5314 appendrefs precedes
$dtags idtags
5318 set atags
[anctags
$currentid]
5320 appendrefs follows
$atags idtags
5324 set dheads
[descheads
$currentid]
5325 if {$dheads ne
{}} {
5326 if {[appendrefs branch
$dheads idheads
] > 1
5327 && [$ctext get
"branch -3c"] eq
"h"} {
5328 # turn "Branch" into "Branches"
5329 $ctext conf
-state normal
5330 $ctext insert
"branch -2c" "es"
5331 $ctext conf
-state disabled
5336 if {[incr tagphase
] <= 2} {
5337 after idle dispnexttag
5341 proc make_secsel
{l
} {
5342 global linehtag linentag linedtag canv canv2 canv3
5344 if {![info exists linehtag
($l)]} return
5346 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
5347 -tags secsel
-fill [$canv cget
-selectbackground]]
5349 $canv2 delete secsel
5350 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
5351 -tags secsel
-fill [$canv2 cget
-selectbackground]]
5353 $canv3 delete secsel
5354 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
5355 -tags secsel
-fill [$canv3 cget
-selectbackground]]
5359 proc selectline
{l isnew
} {
5360 global canv ctext commitinfo selectedline
5361 global canvy0 linespc parents children curview
5362 global currentid sha1entry
5363 global commentend idtags linknum
5364 global mergemax numcommits pending_select
5365 global cmitmode showneartags allcommits
5367 catch
{unset pending_select
}
5372 if {$l < 0 ||
$l >= $numcommits} return
5373 set y
[expr {$canvy0 + $l * $linespc}]
5374 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5375 set ytop
[expr {$y - $linespc - 1}]
5376 set ybot
[expr {$y + $linespc + 1}]
5377 set wnow
[$canv yview
]
5378 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5379 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
5380 set wh
[expr {$wbot - $wtop}]
5382 if {$ytop < $wtop} {
5383 if {$ybot < $wtop} {
5384 set newtop
[expr {$y - $wh / 2.0}]
5387 if {$newtop > $wtop - $linespc} {
5388 set newtop
[expr {$wtop - $linespc}]
5391 } elseif
{$ybot > $wbot} {
5392 if {$ytop > $wbot} {
5393 set newtop
[expr {$y - $wh / 2.0}]
5395 set newtop
[expr {$ybot - $wh}]
5396 if {$newtop < $wtop + $linespc} {
5397 set newtop
[expr {$wtop + $linespc}]
5401 if {$newtop != $wtop} {
5405 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5411 set id
[commitonrow
$l]
5413 addtohistory
[list selbyid
$id]
5418 $sha1entry delete
0 end
5419 $sha1entry insert
0 $id
5420 $sha1entry selection from
0
5421 $sha1entry selection to end
5424 $ctext conf
-state normal
5427 set info
$commitinfo($id)
5428 set date [formatdate
[lindex
$info 2]]
5429 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
5430 set date [formatdate
[lindex
$info 4]]
5431 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
5432 if {[info exists idtags
($id)]} {
5433 $ctext insert end
[mc
"Tags:"]
5434 foreach tag
$idtags($id) {
5435 $ctext insert end
" $tag"
5437 $ctext insert end
"\n"
5441 set olds
$parents($curview,$id)
5442 if {[llength
$olds] > 1} {
5445 if {$np >= $mergemax} {
5450 $ctext insert end
"[mc "Parent
"]: " $tag
5451 appendwithlinks
[commit_descriptor
$p] {}
5456 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
5460 foreach c
$children($curview,$id) {
5461 append headers
"[mc "Child
"]: [commit_descriptor $c]"
5464 # make anything that looks like a SHA1 ID be a clickable link
5465 appendwithlinks
$headers {}
5466 if {$showneartags} {
5467 if {![info exists allcommits
]} {
5470 $ctext insert end
"[mc "Branch
"]: "
5471 $ctext mark
set branch
"end -1c"
5472 $ctext mark gravity branch left
5473 $ctext insert end
"\n[mc "Follows
"]: "
5474 $ctext mark
set follows
"end -1c"
5475 $ctext mark gravity follows left
5476 $ctext insert end
"\n[mc "Precedes
"]: "
5477 $ctext mark
set precedes
"end -1c"
5478 $ctext mark gravity precedes left
5479 $ctext insert end
"\n"
5482 $ctext insert end
"\n"
5483 set comment
[lindex
$info 5]
5484 if {[string first
"\r" $comment] >= 0} {
5485 set comment
[string map
{"\r" "\n "} $comment]
5487 appendwithlinks
$comment {comment
}
5489 $ctext tag remove found
1.0 end
5490 $ctext conf
-state disabled
5491 set commentend
[$ctext index
"end - 1c"]
5493 init_flist
[mc
"Comments"]
5494 if {$cmitmode eq
"tree"} {
5496 } elseif
{[llength
$olds] <= 1} {
5503 proc selfirstline
{} {
5508 proc sellastline
{} {
5511 set l
[expr {$numcommits - 1}]
5515 proc selnextline
{dir
} {
5518 if {![info exists selectedline
]} return
5519 set l
[expr {$selectedline + $dir}]
5524 proc selnextpage
{dir
} {
5525 global canv linespc selectedline numcommits
5527 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
5531 allcanvs yview scroll
[expr {$dir * $lpp}] units
5533 if {![info exists selectedline
]} return
5534 set l
[expr {$selectedline + $dir * $lpp}]
5537 } elseif
{$l >= $numcommits} {
5538 set l
[expr $numcommits - 1]
5544 proc unselectline
{} {
5545 global selectedline currentid
5547 catch
{unset selectedline
}
5548 catch
{unset currentid
}
5549 allcanvs delete secsel
5553 proc reselectline
{} {
5556 if {[info exists selectedline
]} {
5557 selectline
$selectedline 0
5561 proc addtohistory
{cmd
} {
5562 global
history historyindex curview
5564 set elt
[list
$curview $cmd]
5565 if {$historyindex > 0
5566 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
5570 if {$historyindex < [llength
$history]} {
5571 set history [lreplace
$history $historyindex end
$elt]
5573 lappend
history $elt
5576 if {$historyindex > 1} {
5577 .tf.bar.leftbut conf
-state normal
5579 .tf.bar.leftbut conf
-state disabled
5581 .tf.bar.rightbut conf
-state disabled
5587 set view
[lindex
$elt 0]
5588 set cmd
[lindex
$elt 1]
5589 if {$curview != $view} {
5596 global
history historyindex
5599 if {$historyindex > 1} {
5600 incr historyindex
-1
5601 godo
[lindex
$history [expr {$historyindex - 1}]]
5602 .tf.bar.rightbut conf
-state normal
5604 if {$historyindex <= 1} {
5605 .tf.bar.leftbut conf
-state disabled
5610 global
history historyindex
5613 if {$historyindex < [llength
$history]} {
5614 set cmd
[lindex
$history $historyindex]
5617 .tf.bar.leftbut conf
-state normal
5619 if {$historyindex >= [llength
$history]} {
5620 .tf.bar.rightbut conf
-state disabled
5625 global treefilelist treeidlist diffids diffmergeid treepending
5626 global nullid nullid2
5629 catch
{unset diffmergeid
}
5630 if {![info exists treefilelist
($id)]} {
5631 if {![info exists treepending
]} {
5632 if {$id eq
$nullid} {
5633 set cmd
[list | git ls-files
]
5634 } elseif
{$id eq
$nullid2} {
5635 set cmd
[list | git ls-files
--stage -t]
5637 set cmd
[list | git ls-tree
-r $id]
5639 if {[catch
{set gtf
[open
$cmd r
]}]} {
5643 set treefilelist
($id) {}
5644 set treeidlist
($id) {}
5645 fconfigure
$gtf -blocking 0
5646 filerun
$gtf [list gettreeline
$gtf $id]
5653 proc gettreeline
{gtf id
} {
5654 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5657 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
5658 if {$diffids eq
$nullid} {
5661 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
5662 set i
[string first
"\t" $line]
5663 if {$i < 0} continue
5664 set sha1
[lindex
$line 2]
5665 set fname
[string range
$line [expr {$i+1}] end
]
5666 if {[string index
$fname 0] eq
"\""} {
5667 set fname
[lindex
$fname 0]
5669 lappend treeidlist
($id) $sha1
5671 lappend treefilelist
($id) $fname
5674 return [expr {$nl >= 1000?
2: 1}]
5678 if {$cmitmode ne
"tree"} {
5679 if {![info exists diffmergeid
]} {
5680 gettreediffs
$diffids
5682 } elseif
{$id ne
$diffids} {
5691 global treefilelist treeidlist diffids nullid nullid2
5692 global ctext commentend
5694 set i
[lsearch
-exact $treefilelist($diffids) $f]
5696 puts
"oops, $f not in list for id $diffids"
5699 if {$diffids eq
$nullid} {
5700 if {[catch
{set bf
[open
$f r
]} err
]} {
5701 puts
"oops, can't read $f: $err"
5705 set blob
[lindex
$treeidlist($diffids) $i]
5706 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5707 puts
"oops, error reading blob $blob: $err"
5711 fconfigure
$bf -blocking 0
5712 filerun
$bf [list getblobline
$bf $diffids]
5713 $ctext config
-state normal
5714 clear_ctext
$commentend
5715 $ctext insert end
"\n"
5716 $ctext insert end
"$f\n" filesep
5717 $ctext config
-state disabled
5718 $ctext yview
$commentend
5722 proc getblobline
{bf id
} {
5723 global diffids cmitmode ctext
5725 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5729 $ctext config
-state normal
5731 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5732 $ctext insert end
"$line\n"
5735 # delete last newline
5736 $ctext delete
"end - 2c" "end - 1c"
5740 $ctext config
-state disabled
5741 return [expr {$nl >= 1000?
2: 1}]
5744 proc mergediff
{id
} {
5745 global diffmergeid mdifffd
5748 global limitdiffs viewfiles curview
5752 # this doesn't seem to actually affect anything...
5753 set cmd
[concat | git diff-tree
--no-commit-id --cc $id]
5754 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5755 set cmd
[concat
$cmd -- $viewfiles($curview)]
5757 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5758 error_popup
"[mc "Error getting merge diffs
:"] $err"
5761 fconfigure
$mdf -blocking 0
5762 set mdifffd
($id) $mdf
5763 set np
[llength
$parents($curview,$id)]
5765 filerun
$mdf [list getmergediffline
$mdf $id $np]
5768 proc getmergediffline
{mdf id np
} {
5769 global diffmergeid ctext cflist mergemax
5770 global difffilestart mdifffd
5772 $ctext conf
-state normal
5774 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5775 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5776 ||
$mdf != $mdifffd($id)} {
5780 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5781 # start of a new file
5782 $ctext insert end
"\n"
5783 set here
[$ctext index
"end - 1c"]
5784 lappend difffilestart
$here
5785 add_flist
[list
$fname]
5786 set l
[expr {(78 - [string length
$fname]) / 2}]
5787 set pad
[string range
"----------------------------------------" 1 $l]
5788 $ctext insert end
"$pad $fname $pad\n" filesep
5789 } elseif
{[regexp
{^@@
} $line]} {
5790 $ctext insert end
"$line\n" hunksep
5791 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5794 # parse the prefix - one ' ', '-' or '+' for each parent
5799 for {set j
0} {$j < $np} {incr j
} {
5800 set c
[string range
$line $j $j]
5803 } elseif
{$c == "-"} {
5805 } elseif
{$c == "+"} {
5814 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5815 # line doesn't appear in result, parents in $minuses have the line
5816 set num
[lindex
$minuses 0]
5817 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5818 # line appears in result, parents in $pluses don't have the line
5819 lappend tags mresult
5820 set num
[lindex
$spaces 0]
5823 if {$num >= $mergemax} {
5828 $ctext insert end
"$line\n" $tags
5831 $ctext conf
-state disabled
5836 return [expr {$nr >= 1000?
2: 1}]
5839 proc startdiff
{ids
} {
5840 global treediffs diffids treepending diffmergeid nullid nullid2
5844 catch
{unset diffmergeid
}
5845 if {![info exists treediffs
($ids)] ||
5846 [lsearch
-exact $ids $nullid] >= 0 ||
5847 [lsearch
-exact $ids $nullid2] >= 0} {
5848 if {![info exists treepending
]} {
5856 proc path_filter
{filter name
} {
5858 set l
[string length
$p]
5859 if {[string index
$p end
] eq
"/"} {
5860 if {[string compare
-length $l $p $name] == 0} {
5864 if {[string compare
-length $l $p $name] == 0 &&
5865 ([string length
$name] == $l ||
5866 [string index
$name $l] eq
"/")} {
5874 proc addtocflist
{ids
} {
5877 add_flist
$treediffs($ids)
5881 proc diffcmd
{ids flags
} {
5882 global nullid nullid2
5884 set i
[lsearch
-exact $ids $nullid]
5885 set j
[lsearch
-exact $ids $nullid2]
5887 if {[llength
$ids] > 1 && $j < 0} {
5888 # comparing working directory with some specific revision
5889 set cmd
[concat | git diff-index
$flags]
5891 lappend cmd
-R [lindex
$ids 1]
5893 lappend cmd
[lindex
$ids 0]
5896 # comparing working directory with index
5897 set cmd
[concat | git diff-files
$flags]
5902 } elseif
{$j >= 0} {
5903 set cmd
[concat | git diff-index
--cached $flags]
5904 if {[llength
$ids] > 1} {
5905 # comparing index with specific revision
5907 lappend cmd
-R [lindex
$ids 1]
5909 lappend cmd
[lindex
$ids 0]
5912 # comparing index with HEAD
5916 set cmd
[concat | git diff-tree
-r $flags $ids]
5921 proc gettreediffs
{ids
} {
5922 global treediff treepending
5924 set treepending
$ids
5926 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5927 fconfigure
$gdtf -blocking 0
5928 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5931 proc gettreediffline
{gdtf ids
} {
5932 global treediff treediffs treepending diffids diffmergeid
5933 global cmitmode viewfiles curview limitdiffs
5936 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5937 set i
[string first
"\t" $line]
5939 set file [string range
$line [expr {$i+1}] end
]
5940 if {[string index
$file 0] eq
"\""} {
5941 set file [lindex
$file 0]
5943 lappend treediff
$file
5947 return [expr {$nr >= 1000?
2: 1}]
5950 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5952 foreach f
$treediff {
5953 if {[path_filter
$viewfiles($curview) $f]} {
5957 set treediffs
($ids) $flist
5959 set treediffs
($ids) $treediff
5962 if {$cmitmode eq
"tree"} {
5964 } elseif
{$ids != $diffids} {
5965 if {![info exists diffmergeid
]} {
5966 gettreediffs
$diffids
5974 # empty string or positive integer
5975 proc diffcontextvalidate
{v
} {
5976 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5979 proc diffcontextchange
{n1 n2 op
} {
5980 global diffcontextstring diffcontext
5982 if {[string is integer
-strict $diffcontextstring]} {
5983 if {$diffcontextstring > 0} {
5984 set diffcontext
$diffcontextstring
5990 proc getblobdiffs
{ids
} {
5991 global blobdifffd diffids env
5992 global diffinhdr treediffs
5994 global limitdiffs viewfiles curview
5996 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5997 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5998 set cmd
[concat
$cmd -- $viewfiles($curview)]
6000 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
6001 puts
"error getting diffs: $err"
6005 fconfigure
$bdf -blocking 0
6006 set blobdifffd
($ids) $bdf
6007 filerun
$bdf [list getblobdiffline
$bdf $diffids]
6010 proc setinlist
{var i val
} {
6013 while {[llength
[set $var]] < $i} {
6016 if {[llength
[set $var]] == $i} {
6023 proc makediffhdr
{fname ids
} {
6024 global ctext curdiffstart treediffs
6026 set i
[lsearch
-exact $treediffs($ids) $fname]
6028 setinlist difffilestart
$i $curdiffstart
6030 set l
[expr {(78 - [string length
$fname]) / 2}]
6031 set pad
[string range
"----------------------------------------" 1 $l]
6032 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
6035 proc getblobdiffline
{bdf ids
} {
6036 global diffids blobdifffd ctext curdiffstart
6037 global diffnexthead diffnextnote difffilestart
6038 global diffinhdr treediffs
6041 $ctext conf
-state normal
6042 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
6043 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
6047 if {![string compare
-length 11 "diff --git " $line]} {
6048 # trim off "diff --git "
6049 set line
[string range
$line 11 end
]
6051 # start of a new file
6052 $ctext insert end
"\n"
6053 set curdiffstart
[$ctext index
"end - 1c"]
6054 $ctext insert end
"\n" filesep
6055 # If the name hasn't changed the length will be odd,
6056 # the middle char will be a space, and the two bits either
6057 # side will be a/name and b/name, or "a/name" and "b/name".
6058 # If the name has changed we'll get "rename from" and
6059 # "rename to" or "copy from" and "copy to" lines following this,
6060 # and we'll use them to get the filenames.
6061 # This complexity is necessary because spaces in the filename(s)
6062 # don't get escaped.
6063 set l
[string length
$line]
6064 set i
[expr {$l / 2}]
6065 if {!(($l & 1) && [string index
$line $i] eq
" " &&
6066 [string range
$line 2 [expr {$i - 1}]] eq \
6067 [string range
$line [expr {$i + 3}] end
])} {
6070 # unescape if quoted and chop off the a/ from the front
6071 if {[string index
$line 0] eq
"\""} {
6072 set fname
[string range
[lindex
$line 0] 2 end
]
6074 set fname
[string range
$line 2 [expr {$i - 1}]]
6076 makediffhdr
$fname $ids
6078 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
6079 $line match f1l f1c f2l f2c rest
]} {
6080 $ctext insert end
"$line\n" hunksep
6083 } elseif
{$diffinhdr} {
6084 if {![string compare
-length 12 "rename from " $line]} {
6085 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
6086 if {[string index
$fname 0] eq
"\""} {
6087 set fname
[lindex
$fname 0]
6089 set i
[lsearch
-exact $treediffs($ids) $fname]
6091 setinlist difffilestart
$i $curdiffstart
6093 } elseif
{![string compare
-length 10 $line "rename to "] ||
6094 ![string compare
-length 8 $line "copy to "]} {
6095 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
6096 if {[string index
$fname 0] eq
"\""} {
6097 set fname
[lindex
$fname 0]
6099 makediffhdr
$fname $ids
6100 } elseif
{[string compare
-length 3 $line "---"] == 0} {
6103 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
6107 $ctext insert end
"$line\n" filesep
6110 set x
[string range
$line 0 0]
6111 if {$x == "-" ||
$x == "+"} {
6112 set tag
[expr {$x == "+"}]
6113 $ctext insert end
"$line\n" d
$tag
6114 } elseif
{$x == " "} {
6115 $ctext insert end
"$line\n"
6117 # "\ No newline at end of file",
6118 # or something else we don't recognize
6119 $ctext insert end
"$line\n" hunksep
6123 $ctext conf
-state disabled
6128 return [expr {$nr >= 1000?
2: 1}]
6131 proc changediffdisp
{} {
6132 global ctext diffelide
6134 $ctext tag conf d0
-elide [lindex
$diffelide 0]
6135 $ctext tag conf d1
-elide [lindex
$diffelide 1]
6139 global difffilestart ctext
6140 set prev
[lindex
$difffilestart 0]
6141 set here
[$ctext index @
0,0]
6142 foreach loc
$difffilestart {
6143 if {[$ctext compare
$loc >= $here]} {
6153 global difffilestart ctext
6154 set here
[$ctext index @
0,0]
6155 foreach loc
$difffilestart {
6156 if {[$ctext compare
$loc > $here]} {
6163 proc clear_ctext
{{first
1.0}} {
6164 global ctext smarktop smarkbot
6167 set l
[lindex
[split $first .
] 0]
6168 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
6171 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
6174 $ctext delete
$first end
6175 if {$first eq
"1.0"} {
6176 catch
{unset pendinglinks
}
6180 proc settabs
{{firstab
{}}} {
6181 global firsttabstop tabstop ctext have_tk85
6183 if {$firstab ne
{} && $have_tk85} {
6184 set firsttabstop
$firstab
6186 set w
[font measure textfont
"0"]
6187 if {$firsttabstop != 0} {
6188 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
6189 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6190 } elseif
{$have_tk85 ||
$tabstop != 8} {
6191 $ctext conf
-tabs [expr {$tabstop * $w}]
6193 $ctext conf
-tabs {}
6197 proc incrsearch
{name ix op
} {
6198 global ctext searchstring searchdirn
6200 $ctext tag remove found
1.0 end
6201 if {[catch
{$ctext index anchor
}]} {
6202 # no anchor set, use start of selection, or of visible area
6203 set sel
[$ctext tag ranges sel
]
6205 $ctext mark
set anchor
[lindex
$sel 0]
6206 } elseif
{$searchdirn eq
"-forwards"} {
6207 $ctext mark
set anchor @
0,0
6209 $ctext mark
set anchor @
0,[winfo height
$ctext]
6212 if {$searchstring ne
{}} {
6213 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
6222 global sstring ctext searchstring searchdirn
6225 $sstring icursor end
6226 set searchdirn
-forwards
6227 if {$searchstring ne
{}} {
6228 set sel
[$ctext tag ranges sel
]
6230 set start
"[lindex $sel 0] + 1c"
6231 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6234 set match
[$ctext search
-count mlen
-- $searchstring $start]
6235 $ctext tag remove sel
1.0 end
6241 set mend
"$match + $mlen c"
6242 $ctext tag add sel
$match $mend
6243 $ctext mark
unset anchor
6247 proc dosearchback
{} {
6248 global sstring ctext searchstring searchdirn
6251 $sstring icursor end
6252 set searchdirn
-backwards
6253 if {$searchstring ne
{}} {
6254 set sel
[$ctext tag ranges sel
]
6256 set start
[lindex
$sel 0]
6257 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6258 set start @
0,[winfo height
$ctext]
6260 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
6261 $ctext tag remove sel
1.0 end
6267 set mend
"$match + $ml c"
6268 $ctext tag add sel
$match $mend
6269 $ctext mark
unset anchor
6273 proc searchmark
{first last
} {
6274 global ctext searchstring
6278 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
6279 if {$match eq
{}} break
6280 set mend
"$match + $mlen c"
6281 $ctext tag add found
$match $mend
6285 proc searchmarkvisible
{doall
} {
6286 global ctext smarktop smarkbot
6288 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
6289 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
6290 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
6291 # no overlap with previous
6292 searchmark
$topline $botline
6293 set smarktop
$topline
6294 set smarkbot
$botline
6296 if {$topline < $smarktop} {
6297 searchmark
$topline [expr {$smarktop-1}]
6298 set smarktop
$topline
6300 if {$botline > $smarkbot} {
6301 searchmark
[expr {$smarkbot+1}] $botline
6302 set smarkbot
$botline
6307 proc scrolltext
{f0 f1
} {
6310 .bleft.sb
set $f0 $f1
6311 if {$searchstring ne
{}} {
6317 global linespc charspc canvx0 canvy0
6318 global xspc1 xspc2 lthickness
6320 set linespc
[font metrics mainfont
-linespace]
6321 set charspc
[font measure mainfont
"m"]
6322 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
6323 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
6324 set lthickness
[expr {int
($linespc / 9) + 1}]
6325 set xspc1
(0) $linespc
6333 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6334 if {$ymax eq
{} ||
$ymax == 0} return
6335 set span
[$canv yview
]
6338 allcanvs yview moveto
[lindex
$span 0]
6340 if {[info exists selectedline
]} {
6341 selectline
$selectedline 0
6342 allcanvs yview moveto
[lindex
$span 0]
6346 proc parsefont
{f n
} {
6349 set fontattr
($f,family
) [lindex
$n 0]
6351 if {$s eq
{} ||
$s == 0} {
6354 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
6356 set fontattr
($f,size
) $s
6357 set fontattr
($f,weight
) normal
6358 set fontattr
($f,slant
) roman
6359 foreach style
[lrange
$n 2 end
] {
6362 "bold" {set fontattr
($f,weight
) $style}
6364 "italic" {set fontattr
($f,slant
) $style}
6369 proc fontflags
{f
{isbold
0}} {
6372 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
6373 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
6374 -slant $fontattr($f,slant
)]
6380 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
6381 if {$fontattr($f,weight
) eq
"bold"} {
6384 if {$fontattr($f,slant
) eq
"italic"} {
6390 proc incrfont
{inc
} {
6391 global mainfont textfont ctext canv cflist showrefstop
6392 global stopped entries fontattr
6395 set s
$fontattr(mainfont
,size
)
6400 set fontattr
(mainfont
,size
) $s
6401 font config mainfont
-size $s
6402 font config mainfontbold
-size $s
6403 set mainfont
[fontname mainfont
]
6404 set s
$fontattr(textfont
,size
)
6409 set fontattr
(textfont
,size
) $s
6410 font config textfont
-size $s
6411 font config textfontbold
-size $s
6412 set textfont
[fontname textfont
]
6419 global sha1entry sha1string
6420 if {[string length
$sha1string] == 40} {
6421 $sha1entry delete
0 end
6425 proc sha1change
{n1 n2 op
} {
6426 global sha1string currentid sha1but
6427 if {$sha1string == {}
6428 ||
([info exists currentid
] && $sha1string == $currentid)} {
6433 if {[$sha1but cget
-state] == $state} return
6434 if {$state == "normal"} {
6435 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
6437 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
6441 proc gotocommit
{} {
6442 global sha1string tagids headids curview varcid
6444 if {$sha1string == {}
6445 ||
([info exists currentid
] && $sha1string == $currentid)} return
6446 if {[info exists tagids
($sha1string)]} {
6447 set id
$tagids($sha1string)
6448 } elseif
{[info exists headids
($sha1string)]} {
6449 set id
$headids($sha1string)
6451 set id
[string tolower
$sha1string]
6452 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
6453 set matches
[array names varcid
"$curview,$id*"]
6454 if {$matches ne
{}} {
6455 if {[llength
$matches] > 1} {
6456 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
6459 set id
[lindex
[split [lindex
$matches 0] ","] 1]
6463 if {[commitinview
$id $curview]} {
6464 selectline
[rowofcommit
$id] 1
6467 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
6468 set msg
[mc
"SHA1 id %s is not known" $sha1string]
6470 set msg
[mc
"Tag/Head %s is not known" $sha1string]
6475 proc lineenter
{x y id
} {
6476 global hoverx hovery hoverid hovertimer
6477 global commitinfo canv
6479 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6483 if {[info exists hovertimer
]} {
6484 after cancel
$hovertimer
6486 set hovertimer
[after
500 linehover
]
6490 proc linemotion
{x y id
} {
6491 global hoverx hovery hoverid hovertimer
6493 if {[info exists hoverid
] && $id == $hoverid} {
6496 if {[info exists hovertimer
]} {
6497 after cancel
$hovertimer
6499 set hovertimer
[after
500 linehover
]
6503 proc lineleave
{id
} {
6504 global hoverid hovertimer canv
6506 if {[info exists hoverid
] && $id == $hoverid} {
6508 if {[info exists hovertimer
]} {
6509 after cancel
$hovertimer
6517 global hoverx hovery hoverid hovertimer
6518 global canv linespc lthickness
6521 set text
[lindex
$commitinfo($hoverid) 0]
6522 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6523 if {$ymax == {}} return
6524 set yfrac
[lindex
[$canv yview
] 0]
6525 set x
[expr {$hoverx + 2 * $linespc}]
6526 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6527 set x0
[expr {$x - 2 * $lthickness}]
6528 set y0
[expr {$y - 2 * $lthickness}]
6529 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
6530 set y1
[expr {$y + $linespc + 2 * $lthickness}]
6531 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
6532 -fill \
#ffff80 -outline black -width 1 -tags hover]
6534 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
6539 proc clickisonarrow
{id y
} {
6542 set ranges
[rowranges
$id]
6543 set thresh
[expr {2 * $lthickness + 6}]
6544 set n
[expr {[llength
$ranges] - 1}]
6545 for {set i
1} {$i < $n} {incr i
} {
6546 set row
[lindex
$ranges $i]
6547 if {abs
([yc
$row] - $y) < $thresh} {
6554 proc arrowjump
{id n y
} {
6557 # 1 <-> 2, 3 <-> 4, etc...
6558 set n
[expr {(($n - 1) ^
1) + 1}]
6559 set row
[lindex
[rowranges
$id] $n]
6561 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6562 if {$ymax eq
{} ||
$ymax <= 0} return
6563 set view
[$canv yview
]
6564 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
6565 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
6569 allcanvs yview moveto
$yfrac
6572 proc lineclick
{x y id isnew
} {
6573 global ctext commitinfo children canv thickerline curview
6575 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6580 # draw this line thicker than normal
6584 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6585 if {$ymax eq
{}} return
6586 set yfrac
[lindex
[$canv yview
] 0]
6587 set y
[expr {$y + $yfrac * $ymax}]
6589 set dirn
[clickisonarrow
$id $y]
6591 arrowjump
$id $dirn $y
6596 addtohistory
[list lineclick
$x $y $id 0]
6598 # fill the details pane with info about this line
6599 $ctext conf
-state normal
6602 $ctext insert end
"[mc "Parent
"]:\t"
6603 $ctext insert end
$id link0
6605 set info
$commitinfo($id)
6606 $ctext insert end
"\n\t[lindex $info 0]\n"
6607 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
6608 set date [formatdate
[lindex
$info 2]]
6609 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
6610 set kids
$children($curview,$id)
6612 $ctext insert end
"\n[mc "Children
"]:"
6614 foreach child
$kids {
6616 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
6617 set info
$commitinfo($child)
6618 $ctext insert end
"\n\t"
6619 $ctext insert end
$child link
$i
6620 setlink
$child link
$i
6621 $ctext insert end
"\n\t[lindex $info 0]"
6622 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
6623 set date [formatdate
[lindex
$info 2]]
6624 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
6627 $ctext conf
-state disabled
6631 proc normalline
{} {
6633 if {[info exists thickerline
]} {
6642 if {[commitinview
$id $curview]} {
6643 selectline
[rowofcommit
$id] 1
6649 if {![info exists startmstime
]} {
6650 set startmstime
[clock clicks
-milliseconds]
6652 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
6655 proc rowmenu
{x y id
} {
6656 global rowctxmenu selectedline rowmenuid curview
6657 global nullid nullid2 fakerowmenu mainhead
6661 if {![info exists selectedline
]
6662 ||
[rowofcommit
$id] eq
$selectedline} {
6667 if {$id ne
$nullid && $id ne
$nullid2} {
6668 set menu
$rowctxmenu
6669 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6671 set menu
$fakerowmenu
6673 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6674 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6675 $menu entryconfigure
[mc
"Make patch"] -state $state
6676 tk_popup
$menu $x $y
6679 proc diffvssel
{dirn
} {
6680 global rowmenuid selectedline
6682 if {![info exists selectedline
]} return
6684 set oldid
[commitonrow
$selectedline]
6685 set newid
$rowmenuid
6687 set oldid
$rowmenuid
6688 set newid
[commitonrow
$selectedline]
6690 addtohistory
[list doseldiff
$oldid $newid]
6691 doseldiff
$oldid $newid
6694 proc doseldiff
{oldid newid
} {
6698 $ctext conf
-state normal
6700 init_flist
[mc
"Top"]
6701 $ctext insert end
"[mc "From
"] "
6702 $ctext insert end
$oldid link0
6703 setlink
$oldid link0
6704 $ctext insert end
"\n "
6705 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6706 $ctext insert end
"\n\n[mc "To
"] "
6707 $ctext insert end
$newid link1
6708 setlink
$newid link1
6709 $ctext insert end
"\n "
6710 $ctext insert end
[lindex
$commitinfo($newid) 0]
6711 $ctext insert end
"\n"
6712 $ctext conf
-state disabled
6713 $ctext tag remove found
1.0 end
6714 startdiff
[list
$oldid $newid]
6718 global rowmenuid currentid commitinfo patchtop patchnum
6720 if {![info exists currentid
]} return
6721 set oldid
$currentid
6722 set oldhead
[lindex
$commitinfo($oldid) 0]
6723 set newid
$rowmenuid
6724 set newhead
[lindex
$commitinfo($newid) 0]
6727 catch
{destroy
$top}
6729 label
$top.title
-text [mc
"Generate patch"]
6730 grid
$top.title
- -pady 10
6731 label
$top.from
-text [mc
"From:"]
6732 entry
$top.fromsha1
-width 40 -relief flat
6733 $top.fromsha1 insert
0 $oldid
6734 $top.fromsha1 conf
-state readonly
6735 grid
$top.from
$top.fromsha1
-sticky w
6736 entry
$top.fromhead
-width 60 -relief flat
6737 $top.fromhead insert
0 $oldhead
6738 $top.fromhead conf
-state readonly
6739 grid x
$top.fromhead
-sticky w
6740 label
$top.to
-text [mc
"To:"]
6741 entry
$top.tosha1
-width 40 -relief flat
6742 $top.tosha1 insert
0 $newid
6743 $top.tosha1 conf
-state readonly
6744 grid
$top.to
$top.tosha1
-sticky w
6745 entry
$top.tohead
-width 60 -relief flat
6746 $top.tohead insert
0 $newhead
6747 $top.tohead conf
-state readonly
6748 grid x
$top.tohead
-sticky w
6749 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6750 grid
$top.
rev x
-pady 10
6751 label
$top.flab
-text [mc
"Output file:"]
6752 entry
$top.fname
-width 60
6753 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6755 grid
$top.flab
$top.fname
-sticky w
6757 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6758 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6759 grid
$top.buts.gen
$top.buts.can
6760 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6761 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6762 grid
$top.buts
- -pady 10 -sticky ew
6766 proc mkpatchrev
{} {
6769 set oldid
[$patchtop.fromsha1 get
]
6770 set oldhead
[$patchtop.fromhead get
]
6771 set newid
[$patchtop.tosha1 get
]
6772 set newhead
[$patchtop.tohead get
]
6773 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6774 v
[list
$newid $newhead $oldid $oldhead] {
6775 $patchtop.
$e conf
-state normal
6776 $patchtop.
$e delete
0 end
6777 $patchtop.
$e insert
0 $v
6778 $patchtop.
$e conf
-state readonly
6783 global patchtop nullid nullid2
6785 set oldid
[$patchtop.fromsha1 get
]
6786 set newid
[$patchtop.tosha1 get
]
6787 set fname
[$patchtop.fname get
]
6788 set cmd
[diffcmd
[list
$oldid $newid] -p]
6789 # trim off the initial "|"
6790 set cmd
[lrange
$cmd 1 end
]
6791 lappend cmd
>$fname &
6792 if {[catch
{eval exec $cmd} err
]} {
6793 error_popup
"[mc "Error creating
patch:"] $err"
6795 catch
{destroy
$patchtop}
6799 proc mkpatchcan
{} {
6802 catch
{destroy
$patchtop}
6807 global rowmenuid mktagtop commitinfo
6811 catch
{destroy
$top}
6813 label
$top.title
-text [mc
"Create tag"]
6814 grid
$top.title
- -pady 10
6815 label
$top.id
-text [mc
"ID:"]
6816 entry
$top.sha1
-width 40 -relief flat
6817 $top.sha1 insert
0 $rowmenuid
6818 $top.sha1 conf
-state readonly
6819 grid
$top.id
$top.sha1
-sticky w
6820 entry
$top.
head -width 60 -relief flat
6821 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6822 $top.
head conf
-state readonly
6823 grid x
$top.
head -sticky w
6824 label
$top.tlab
-text [mc
"Tag name:"]
6825 entry
$top.tag
-width 60
6826 grid
$top.tlab
$top.tag
-sticky w
6828 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6829 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6830 grid
$top.buts.gen
$top.buts.can
6831 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6832 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6833 grid
$top.buts
- -pady 10 -sticky ew
6838 global mktagtop env tagids idtags
6840 set id
[$mktagtop.sha1 get
]
6841 set tag
[$mktagtop.tag get
]
6843 error_popup
[mc
"No tag name specified"]
6846 if {[info exists tagids
($tag)]} {
6847 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6852 set fname
[file join $dir "refs/tags" $tag]
6853 set f
[open
$fname w
]
6857 error_popup
"[mc "Error creating tag
:"] $err"
6861 set tagids
($tag) $id
6862 lappend idtags
($id) $tag
6869 proc redrawtags
{id
} {
6870 global canv linehtag idpos currentid curview
6871 global canvxmax iddrawn
6873 if {![commitinview
$id $curview]} return
6874 if {![info exists iddrawn
($id)]} return
6875 set row
[rowofcommit
$id]
6876 $canv delete tag.
$id
6877 set xt
[eval drawtags
$id $idpos($id)]
6878 $canv coords
$linehtag($row) $xt [lindex
$idpos($id) 2]
6879 set text
[$canv itemcget
$linehtag($row) -text]
6880 set font
[$canv itemcget
$linehtag($row) -font]
6881 set xr
[expr {$xt + [font measure
$font $text]}]
6882 if {$xr > $canvxmax} {
6886 if {[info exists currentid
] && $currentid == $id} {
6894 catch
{destroy
$mktagtop}
6903 proc writecommit
{} {
6904 global rowmenuid wrcomtop commitinfo wrcomcmd
6906 set top .writecommit
6908 catch
{destroy
$top}
6910 label
$top.title
-text [mc
"Write commit to file"]
6911 grid
$top.title
- -pady 10
6912 label
$top.id
-text [mc
"ID:"]
6913 entry
$top.sha1
-width 40 -relief flat
6914 $top.sha1 insert
0 $rowmenuid
6915 $top.sha1 conf
-state readonly
6916 grid
$top.id
$top.sha1
-sticky w
6917 entry
$top.
head -width 60 -relief flat
6918 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6919 $top.
head conf
-state readonly
6920 grid x
$top.
head -sticky w
6921 label
$top.clab
-text [mc
"Command:"]
6922 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6923 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6924 label
$top.flab
-text [mc
"Output file:"]
6925 entry
$top.fname
-width 60
6926 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6927 grid
$top.flab
$top.fname
-sticky w
6929 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6930 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6931 grid
$top.buts.gen
$top.buts.can
6932 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6933 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6934 grid
$top.buts
- -pady 10 -sticky ew
6941 set id
[$wrcomtop.sha1 get
]
6942 set cmd
"echo $id | [$wrcomtop.cmd get]"
6943 set fname
[$wrcomtop.fname get
]
6944 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6945 error_popup
"[mc "Error writing commit
:"] $err"
6947 catch
{destroy
$wrcomtop}
6954 catch
{destroy
$wrcomtop}
6959 global rowmenuid mkbrtop
6962 catch
{destroy
$top}
6964 label
$top.title
-text [mc
"Create new branch"]
6965 grid
$top.title
- -pady 10
6966 label
$top.id
-text [mc
"ID:"]
6967 entry
$top.sha1
-width 40 -relief flat
6968 $top.sha1 insert
0 $rowmenuid
6969 $top.sha1 conf
-state readonly
6970 grid
$top.id
$top.sha1
-sticky w
6971 label
$top.nlab
-text [mc
"Name:"]
6972 entry
$top.name
-width 40
6973 grid
$top.nlab
$top.name
-sticky w
6975 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6976 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6977 grid
$top.buts.go
$top.buts.can
6978 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6979 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6980 grid
$top.buts
- -pady 10 -sticky ew
6985 global headids idheads
6987 set name
[$top.name get
]
6988 set id
[$top.sha1 get
]
6990 error_popup
[mc
"Please specify a name for the new branch"]
6993 catch
{destroy
$top}
6997 exec git branch
$name $id
7002 set headids
($name) $id
7003 lappend idheads
($id) $name
7012 proc cherrypick
{} {
7013 global rowmenuid curview
7016 set oldhead
[exec git rev-parse HEAD
]
7017 set dheads
[descheads
$rowmenuid]
7018 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
7019 set ok
[confirm_popup
[mc
"Commit %s is already\
7020 included in branch %s -- really re-apply it?" \
7021 [string range
$rowmenuid 0 7] $mainhead]]
7024 nowbusy cherrypick
[mc
"Cherry-picking"]
7026 # Unfortunately git-cherry-pick writes stuff to stderr even when
7027 # no error occurs, and exec takes that as an indication of error...
7028 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
7033 set newhead
[exec git rev-parse HEAD
]
7034 if {$newhead eq
$oldhead} {
7036 error_popup
[mc
"No changes committed"]
7039 addnewchild
$newhead $oldhead
7040 if {[commitinview
$oldhead $curview]} {
7041 insertrow
$newhead $oldhead $curview
7042 if {$mainhead ne
{}} {
7043 movehead
$newhead $mainhead
7044 movedhead
$newhead $mainhead
7053 global mainheadid mainhead rowmenuid confirm_ok resettype
7056 set w
".confirmreset"
7059 wm title
$w [mc
"Confirm reset"]
7060 message
$w.m
-text \
7061 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
7062 -justify center
-aspect 1000
7063 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
7064 frame
$w.f
-relief sunken
-border 2
7065 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
7066 grid
$w.f.rt
-sticky w
7068 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
7069 -text [mc
"Soft: Leave working tree and index untouched"]
7070 grid
$w.f.soft
-sticky w
7071 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
7072 -text [mc
"Mixed: Leave working tree untouched, reset index"]
7073 grid
$w.f.mixed
-sticky w
7074 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
7075 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
7076 grid
$w.f.hard
-sticky w
7077 pack
$w.f
-side top
-fill x
7078 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
7079 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
7080 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
7081 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
7082 bind $w <Visibility
> "grab $w; focus $w"
7084 if {!$confirm_ok} return
7085 if {[catch
{set fd
[open \
7086 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
7090 filerun
$fd [list readresetstat
$fd]
7091 nowbusy
reset [mc
"Resetting"]
7095 proc readresetstat
{fd
} {
7096 global mainhead mainheadid showlocalchanges rprogcoord
7098 if {[gets
$fd line
] >= 0} {
7099 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
7100 set rprogcoord
[expr {1.0 * $m / $n}]
7108 if {[catch
{close
$fd} err
]} {
7111 set oldhead
$mainheadid
7112 set newhead
[exec git rev-parse HEAD
]
7113 if {$newhead ne
$oldhead} {
7114 movehead
$newhead $mainhead
7115 movedhead
$newhead $mainhead
7116 set mainheadid
$newhead
7120 if {$showlocalchanges} {
7126 # context menu for a head
7127 proc headmenu
{x y id
head} {
7128 global headmenuid headmenuhead headctxmenu mainhead
7132 set headmenuhead
$head
7134 if {$head eq
$mainhead} {
7137 $headctxmenu entryconfigure
0 -state $state
7138 $headctxmenu entryconfigure
1 -state $state
7139 tk_popup
$headctxmenu $x $y
7143 global headmenuid headmenuhead mainhead headids
7144 global showlocalchanges mainheadid
7146 # check the tree is clean first??
7147 set oldmainhead
$mainhead
7148 nowbusy checkout
[mc
"Checking out"]
7152 exec git checkout
-q $headmenuhead
7158 set mainhead
$headmenuhead
7159 set mainheadid
$headmenuid
7160 if {[info exists headids
($oldmainhead)]} {
7161 redrawtags
$headids($oldmainhead)
7163 redrawtags
$headmenuid
7165 if {$showlocalchanges} {
7171 global headmenuid headmenuhead mainhead
7174 set head $headmenuhead
7176 # this check shouldn't be needed any more...
7177 if {$head eq
$mainhead} {
7178 error_popup
[mc
"Cannot delete the currently checked-out branch"]
7181 set dheads
[descheads
$id]
7182 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
7183 # the stuff on this branch isn't on any other branch
7184 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
7185 branch.\nReally delete branch %s?" $head $head]]} return
7189 if {[catch
{exec git branch
-D $head} err
]} {
7194 removehead
$id $head
7195 removedhead
$id $head
7202 # Display a list of tags and heads
7204 global showrefstop bgcolor fgcolor selectbgcolor
7205 global bglist fglist reflistfilter reflist maincursor
7208 set showrefstop
$top
7209 if {[winfo exists
$top]} {
7215 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
7216 text
$top.list
-background $bgcolor -foreground $fgcolor \
7217 -selectbackground $selectbgcolor -font mainfont \
7218 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7219 -width 30 -height 20 -cursor $maincursor \
7220 -spacing1 1 -spacing3 1 -state disabled
7221 $top.list tag configure highlight
-background $selectbgcolor
7222 lappend bglist
$top.list
7223 lappend fglist
$top.list
7224 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
7225 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
7226 grid
$top.list
$top.ysb
-sticky nsew
7227 grid
$top.xsb x
-sticky ew
7229 label
$top.f.l
-text "[mc "Filter
"]: " -font uifont
7230 entry
$top.f.e
-width 20 -textvariable reflistfilter
-font uifont
7231 set reflistfilter
"*"
7232 trace add variable reflistfilter
write reflistfilter_change
7233 pack
$top.f.e
-side right
-fill x
-expand 1
7234 pack
$top.f.l
-side left
7235 grid
$top.f
- -sticky ew
-pady 2
7236 button
$top.close
-command [list destroy
$top] -text [mc
"Close"] \
7239 grid columnconfigure
$top 0 -weight 1
7240 grid rowconfigure
$top 0 -weight 1
7241 bind $top.list
<1> {break}
7242 bind $top.list
<B1-Motion
> {break}
7243 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
7248 proc sel_reflist
{w x y
} {
7249 global showrefstop reflist headids tagids otherrefids
7251 if {![winfo exists
$showrefstop]} return
7252 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
7253 set ref
[lindex
$reflist [expr {$l-1}]]
7254 set n
[lindex
$ref 0]
7255 switch
-- [lindex
$ref 1] {
7256 "H" {selbyid
$headids($n)}
7257 "T" {selbyid
$tagids($n)}
7258 "o" {selbyid
$otherrefids($n)}
7260 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
7263 proc unsel_reflist
{} {
7266 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7267 $showrefstop.list tag remove highlight
0.0 end
7270 proc reflistfilter_change
{n1 n2 op
} {
7271 global reflistfilter
7273 after cancel refill_reflist
7274 after
200 refill_reflist
7277 proc refill_reflist
{} {
7278 global reflist reflistfilter showrefstop headids tagids otherrefids
7279 global curview commitinterest
7281 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7283 foreach n
[array names headids
] {
7284 if {[string match
$reflistfilter $n]} {
7285 if {[commitinview
$headids($n) $curview]} {
7286 lappend refs
[list
$n H
]
7288 set commitinterest
($headids($n)) {run refill_reflist
}
7292 foreach n
[array names tagids
] {
7293 if {[string match
$reflistfilter $n]} {
7294 if {[commitinview
$tagids($n) $curview]} {
7295 lappend refs
[list
$n T
]
7297 set commitinterest
($tagids($n)) {run refill_reflist
}
7301 foreach n
[array names otherrefids
] {
7302 if {[string match
$reflistfilter $n]} {
7303 if {[commitinview
$otherrefids($n) $curview]} {
7304 lappend refs
[list
$n o
]
7306 set commitinterest
($otherrefids($n)) {run refill_reflist
}
7310 set refs
[lsort
-index 0 $refs]
7311 if {$refs eq
$reflist} return
7313 # Update the contents of $showrefstop.list according to the
7314 # differences between $reflist (old) and $refs (new)
7315 $showrefstop.list conf
-state normal
7316 $showrefstop.list insert end
"\n"
7319 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
7320 if {$i < [llength
$reflist]} {
7321 if {$j < [llength
$refs]} {
7322 set cmp [string compare
[lindex
$reflist $i 0] \
7323 [lindex
$refs $j 0]]
7325 set cmp [string compare
[lindex
$reflist $i 1] \
7326 [lindex
$refs $j 1]]
7336 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
7344 set l
[expr {$j + 1}]
7345 $showrefstop.list image create
$l.0 -align baseline \
7346 -image reficon-
[lindex
$refs $j 1] -padx 2
7347 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
7353 # delete last newline
7354 $showrefstop.list delete end-2c end-1c
7355 $showrefstop.list conf
-state disabled
7358 # Stuff for finding nearby tags
7359 proc getallcommits
{} {
7360 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7361 global idheads idtags idotherrefs allparents tagobjid
7363 if {![info exists allcommits
]} {
7369 set allccache
[file join [gitdir
] "gitk.cache"]
7371 set f
[open
$allccache r
]
7380 set cmd
[list | git rev-list
--parents]
7381 set allcupdate
[expr {$seeds ne
{}}]
7385 set refs
[concat
[array names idheads
] [array names idtags
] \
7386 [array names idotherrefs
]]
7389 foreach name
[array names tagobjid
] {
7390 lappend tagobjs
$tagobjid($name)
7392 foreach id
[lsort
-unique $refs] {
7393 if {![info exists allparents
($id)] &&
7394 [lsearch
-exact $tagobjs $id] < 0} {
7405 set fd
[open
[concat
$cmd $ids] r
]
7406 fconfigure
$fd -blocking 0
7409 filerun
$fd [list getallclines
$fd]
7415 # Since most commits have 1 parent and 1 child, we group strings of
7416 # such commits into "arcs" joining branch/merge points (BMPs), which
7417 # are commits that either don't have 1 parent or don't have 1 child.
7419 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7420 # arcout(id) - outgoing arcs for BMP
7421 # arcids(a) - list of IDs on arc including end but not start
7422 # arcstart(a) - BMP ID at start of arc
7423 # arcend(a) - BMP ID at end of arc
7424 # growing(a) - arc a is still growing
7425 # arctags(a) - IDs out of arcids (excluding end) that have tags
7426 # archeads(a) - IDs out of arcids (excluding end) that have heads
7427 # The start of an arc is at the descendent end, so "incoming" means
7428 # coming from descendents, and "outgoing" means going towards ancestors.
7430 proc getallclines
{fd
} {
7431 global allparents allchildren idtags idheads nextarc
7432 global arcnos arcids arctags arcout arcend arcstart archeads growing
7433 global seeds allcommits cachedarcs allcupdate
7436 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
7437 set id
[lindex
$line 0]
7438 if {[info exists allparents
($id)]} {
7443 set olds
[lrange
$line 1 end
]
7444 set allparents
($id) $olds
7445 if {![info exists allchildren
($id)]} {
7446 set allchildren
($id) {}
7451 if {[llength
$olds] == 1 && [llength
$a] == 1} {
7452 lappend arcids
($a) $id
7453 if {[info exists idtags
($id)]} {
7454 lappend arctags
($a) $id
7456 if {[info exists idheads
($id)]} {
7457 lappend archeads
($a) $id
7459 if {[info exists allparents
($olds)]} {
7460 # seen parent already
7461 if {![info exists arcout
($olds)]} {
7464 lappend arcids
($a) $olds
7465 set arcend
($a) $olds
7468 lappend allchildren
($olds) $id
7469 lappend arcnos
($olds) $a
7473 foreach a
$arcnos($id) {
7474 lappend arcids
($a) $id
7481 lappend allchildren
($p) $id
7482 set a
[incr nextarc
]
7483 set arcstart
($a) $id
7490 if {[info exists allparents
($p)]} {
7491 # seen it already, may need to make a new branch
7492 if {![info exists arcout
($p)]} {
7495 lappend arcids
($a) $p
7499 lappend arcnos
($p) $a
7504 global cached_dheads cached_dtags cached_atags
7505 catch
{unset cached_dheads
}
7506 catch
{unset cached_dtags
}
7507 catch
{unset cached_atags
}
7510 return [expr {$nid >= 1000?
2: 1}]
7514 fconfigure
$fd -blocking 1
7517 # got an error reading the list of commits
7518 # if we were updating, try rereading the whole thing again
7524 error_popup
"[mc "Error reading commit topology information
;\
7525 branch and preceding
/following tag information\
7526 will be incomplete.
"]\n($err)"
7529 if {[incr allcommits
-1] == 0} {
7539 proc recalcarc
{a
} {
7540 global arctags archeads arcids idtags idheads
7544 foreach id
[lrange
$arcids($a) 0 end-1
] {
7545 if {[info exists idtags
($id)]} {
7548 if {[info exists idheads
($id)]} {
7553 set archeads
($a) $ah
7557 global arcnos arcids nextarc arctags archeads idtags idheads
7558 global arcstart arcend arcout allparents growing
7561 if {[llength
$a] != 1} {
7562 puts
"oops splitarc called but [llength $a] arcs already"
7566 set i
[lsearch
-exact $arcids($a) $p]
7568 puts
"oops splitarc $p not in arc $a"
7571 set na
[incr nextarc
]
7572 if {[info exists arcend
($a)]} {
7573 set arcend
($na) $arcend($a)
7575 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
7576 set j
[lsearch
-exact $arcnos($l) $a]
7577 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
7579 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
7580 set arcids
($a) [lrange
$arcids($a) 0 $i]
7582 set arcstart
($na) $p
7584 set arcids
($na) $tail
7585 if {[info exists growing
($a)]} {
7591 if {[llength
$arcnos($id)] == 1} {
7594 set j
[lsearch
-exact $arcnos($id) $a]
7595 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
7599 # reconstruct tags and heads lists
7600 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
7605 set archeads
($na) {}
7609 # Update things for a new commit added that is a child of one
7610 # existing commit. Used when cherry-picking.
7611 proc addnewchild
{id p
} {
7612 global allparents allchildren idtags nextarc
7613 global arcnos arcids arctags arcout arcend arcstart archeads growing
7614 global seeds allcommits
7616 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
7617 set allparents
($id) [list
$p]
7618 set allchildren
($id) {}
7621 lappend allchildren
($p) $id
7622 set a
[incr nextarc
]
7623 set arcstart
($a) $id
7626 set arcids
($a) [list
$p]
7628 if {![info exists arcout
($p)]} {
7631 lappend arcnos
($p) $a
7632 set arcout
($id) [list
$a]
7635 # This implements a cache for the topology information.
7636 # The cache saves, for each arc, the start and end of the arc,
7637 # the ids on the arc, and the outgoing arcs from the end.
7638 proc readcache
{f
} {
7639 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7640 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7645 if {$lim - $a > 500} {
7646 set lim
[expr {$a + 500}]
7650 # finish reading the cache and setting up arctags, etc.
7652 if {$line ne
"1"} {error
"bad final version"}
7654 foreach id
[array names idtags
] {
7655 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7656 [llength
$allparents($id)] == 1} {
7657 set a
[lindex
$arcnos($id) 0]
7658 if {$arctags($a) eq
{}} {
7663 foreach id
[array names idheads
] {
7664 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7665 [llength
$allparents($id)] == 1} {
7666 set a
[lindex
$arcnos($id) 0]
7667 if {$archeads($a) eq
{}} {
7672 foreach id
[lsort
-unique $possible_seeds] {
7673 if {$arcnos($id) eq
{}} {
7679 while {[incr a
] <= $lim} {
7681 if {[llength
$line] != 3} {error
"bad line"}
7682 set s
[lindex
$line 0]
7684 lappend arcout
($s) $a
7685 if {![info exists arcnos
($s)]} {
7686 lappend possible_seeds
$s
7689 set e
[lindex
$line 1]
7694 if {![info exists arcout
($e)]} {
7698 set arcids
($a) [lindex
$line 2]
7699 foreach id
$arcids($a) {
7700 lappend allparents
($s) $id
7702 lappend arcnos
($id) $a
7704 if {![info exists allparents
($s)]} {
7705 set allparents
($s) {}
7710 set nextarc
[expr {$a - 1}]
7723 global nextarc cachedarcs possible_seeds
7727 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7728 # make sure it's an integer
7729 set cachedarcs
[expr {int
([lindex
$line 1])}]
7730 if {$cachedarcs < 0} {error
"bad number of arcs"}
7732 set possible_seeds
{}
7740 proc dropcache
{err
} {
7741 global allcwait nextarc cachedarcs seeds
7743 #puts "dropping cache ($err)"
7744 foreach v
{arcnos arcout arcids arcstart arcend growing \
7745 arctags archeads allparents allchildren
} {
7756 proc writecache
{f
} {
7757 global cachearc cachedarcs allccache
7758 global arcstart arcend arcnos arcids arcout
7762 if {$lim - $a > 1000} {
7763 set lim
[expr {$a + 1000}]
7766 while {[incr a
] <= $lim} {
7767 if {[info exists arcend
($a)]} {
7768 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7770 puts
$f [list
$arcstart($a) {} $arcids($a)]
7775 catch
{file delete
$allccache}
7776 #puts "writing cache failed ($err)"
7779 set cachearc
[expr {$a - 1}]
7780 if {$a > $cachedarcs} {
7789 global nextarc cachedarcs cachearc allccache
7791 if {$nextarc == $cachedarcs} return
7793 set cachedarcs
$nextarc
7795 set f
[open
$allccache w
]
7796 puts
$f [list
1 $cachedarcs]
7801 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7802 # or 0 if neither is true.
7803 proc anc_or_desc
{a b
} {
7804 global arcout arcstart arcend arcnos cached_isanc
7806 if {$arcnos($a) eq
$arcnos($b)} {
7807 # Both are on the same arc(s); either both are the same BMP,
7808 # or if one is not a BMP, the other is also not a BMP or is
7809 # the BMP at end of the arc (and it only has 1 incoming arc).
7810 # Or both can be BMPs with no incoming arcs.
7811 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7814 # assert {[llength $arcnos($a)] == 1}
7815 set arc
[lindex
$arcnos($a) 0]
7816 set i
[lsearch
-exact $arcids($arc) $a]
7817 set j
[lsearch
-exact $arcids($arc) $b]
7818 if {$i < 0 ||
$i > $j} {
7825 if {![info exists arcout
($a)]} {
7826 set arc
[lindex
$arcnos($a) 0]
7827 if {[info exists arcend
($arc)]} {
7828 set aend
$arcend($arc)
7832 set a
$arcstart($arc)
7836 if {![info exists arcout
($b)]} {
7837 set arc
[lindex
$arcnos($b) 0]
7838 if {[info exists arcend
($arc)]} {
7839 set bend
$arcend($arc)
7843 set b
$arcstart($arc)
7853 if {[info exists cached_isanc
($a,$bend)]} {
7854 if {$cached_isanc($a,$bend)} {
7858 if {[info exists cached_isanc
($b,$aend)]} {
7859 if {$cached_isanc($b,$aend)} {
7862 if {[info exists cached_isanc
($a,$bend)]} {
7867 set todo
[list
$a $b]
7870 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7871 set x
[lindex
$todo $i]
7872 if {$anc($x) eq
{}} {
7875 foreach arc
$arcnos($x) {
7876 set xd
$arcstart($arc)
7878 set cached_isanc
($a,$bend) 1
7879 set cached_isanc
($b,$aend) 0
7881 } elseif
{$xd eq
$aend} {
7882 set cached_isanc
($b,$aend) 1
7883 set cached_isanc
($a,$bend) 0
7886 if {![info exists anc
($xd)]} {
7887 set anc
($xd) $anc($x)
7889 } elseif
{$anc($xd) ne
$anc($x)} {
7894 set cached_isanc
($a,$bend) 0
7895 set cached_isanc
($b,$aend) 0
7899 # This identifies whether $desc has an ancestor that is
7900 # a growing tip of the graph and which is not an ancestor of $anc
7901 # and returns 0 if so and 1 if not.
7902 # If we subsequently discover a tag on such a growing tip, and that
7903 # turns out to be a descendent of $anc (which it could, since we
7904 # don't necessarily see children before parents), then $desc
7905 # isn't a good choice to display as a descendent tag of
7906 # $anc (since it is the descendent of another tag which is
7907 # a descendent of $anc). Similarly, $anc isn't a good choice to
7908 # display as a ancestor tag of $desc.
7910 proc is_certain
{desc anc
} {
7911 global arcnos arcout arcstart arcend growing problems
7914 if {[llength
$arcnos($anc)] == 1} {
7915 # tags on the same arc are certain
7916 if {$arcnos($desc) eq
$arcnos($anc)} {
7919 if {![info exists arcout
($anc)]} {
7920 # if $anc is partway along an arc, use the start of the arc instead
7921 set a
[lindex
$arcnos($anc) 0]
7922 set anc
$arcstart($a)
7925 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7928 set a
[lindex
$arcnos($desc) 0]
7934 set anclist
[list
$x]
7938 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7939 set x
[lindex
$anclist $i]
7944 foreach a
$arcout($x) {
7945 if {[info exists growing
($a)]} {
7946 if {![info exists growanc
($x)] && $dl($x)} {
7952 if {[info exists dl
($y)]} {
7956 if {![info exists
done($y)]} {
7959 if {[info exists growanc
($x)]} {
7963 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7964 set z
[lindex
$xl $k]
7965 foreach c
$arcout($z) {
7966 if {[info exists arcend
($c)]} {
7968 if {[info exists dl
($v)] && $dl($v)} {
7970 if {![info exists
done($v)]} {
7973 if {[info exists growanc
($v)]} {
7983 } elseif
{$y eq
$anc ||
!$dl($x)} {
7994 foreach x
[array names growanc
] {
8003 proc validate_arctags
{a
} {
8004 global arctags idtags
8008 foreach id
$arctags($a) {
8010 if {![info exists idtags
($id)]} {
8011 set na
[lreplace
$na $i $i]
8018 proc validate_archeads
{a
} {
8019 global archeads idheads
8022 set na
$archeads($a)
8023 foreach id
$archeads($a) {
8025 if {![info exists idheads
($id)]} {
8026 set na
[lreplace
$na $i $i]
8030 set archeads
($a) $na
8033 # Return the list of IDs that have tags that are descendents of id,
8034 # ignoring IDs that are descendents of IDs already reported.
8035 proc desctags
{id
} {
8036 global arcnos arcstart arcids arctags idtags allparents
8037 global growing cached_dtags
8039 if {![info exists allparents
($id)]} {
8042 set t1
[clock clicks
-milliseconds]
8044 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8045 # part-way along an arc; check that arc first
8046 set a
[lindex
$arcnos($id) 0]
8047 if {$arctags($a) ne
{}} {
8049 set i
[lsearch
-exact $arcids($a) $id]
8051 foreach t
$arctags($a) {
8052 set j
[lsearch
-exact $arcids($a) $t]
8060 set id
$arcstart($a)
8061 if {[info exists idtags
($id)]} {
8065 if {[info exists cached_dtags
($id)]} {
8066 return $cached_dtags($id)
8073 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8074 set id
[lindex
$todo $i]
8076 set ta
[info exists hastaggedancestor
($id)]
8080 # ignore tags on starting node
8081 if {!$ta && $i > 0} {
8082 if {[info exists idtags
($id)]} {
8085 } elseif
{[info exists cached_dtags
($id)]} {
8086 set tagloc
($id) $cached_dtags($id)
8090 foreach a
$arcnos($id) {
8092 if {!$ta && $arctags($a) ne
{}} {
8094 if {$arctags($a) ne
{}} {
8095 lappend tagloc
($id) [lindex
$arctags($a) end
]
8098 if {$ta ||
$arctags($a) ne
{}} {
8099 set tomark
[list
$d]
8100 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8101 set dd [lindex
$tomark $j]
8102 if {![info exists hastaggedancestor
($dd)]} {
8103 if {[info exists
done($dd)]} {
8104 foreach b
$arcnos($dd) {
8105 lappend tomark
$arcstart($b)
8107 if {[info exists tagloc
($dd)]} {
8110 } elseif
{[info exists queued
($dd)]} {
8113 set hastaggedancestor
($dd) 1
8117 if {![info exists queued
($d)]} {
8120 if {![info exists hastaggedancestor
($d)]} {
8127 foreach id
[array names tagloc
] {
8128 if {![info exists hastaggedancestor
($id)]} {
8129 foreach t
$tagloc($id) {
8130 if {[lsearch
-exact $tags $t] < 0} {
8136 set t2
[clock clicks
-milliseconds]
8139 # remove tags that are descendents of other tags
8140 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8141 set a
[lindex
$tags $i]
8142 for {set j
0} {$j < $i} {incr j
} {
8143 set b
[lindex
$tags $j]
8144 set r
[anc_or_desc
$a $b]
8146 set tags
[lreplace
$tags $j $j]
8149 } elseif
{$r == -1} {
8150 set tags
[lreplace
$tags $i $i]
8157 if {[array names growing
] ne
{}} {
8158 # graph isn't finished, need to check if any tag could get
8159 # eclipsed by another tag coming later. Simply ignore any
8160 # tags that could later get eclipsed.
8163 if {[is_certain
$t $origid]} {
8167 if {$tags eq
$ctags} {
8168 set cached_dtags
($origid) $tags
8173 set cached_dtags
($origid) $tags
8175 set t3
[clock clicks
-milliseconds]
8176 if {0 && $t3 - $t1 >= 100} {
8177 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
8178 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8184 global arcnos arcids arcout arcend arctags idtags allparents
8185 global growing cached_atags
8187 if {![info exists allparents
($id)]} {
8190 set t1
[clock clicks
-milliseconds]
8192 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8193 # part-way along an arc; check that arc first
8194 set a
[lindex
$arcnos($id) 0]
8195 if {$arctags($a) ne
{}} {
8197 set i
[lsearch
-exact $arcids($a) $id]
8198 foreach t
$arctags($a) {
8199 set j
[lsearch
-exact $arcids($a) $t]
8205 if {![info exists arcend
($a)]} {
8209 if {[info exists idtags
($id)]} {
8213 if {[info exists cached_atags
($id)]} {
8214 return $cached_atags($id)
8222 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8223 set id
[lindex
$todo $i]
8225 set td
[info exists hastaggeddescendent
($id)]
8229 # ignore tags on starting node
8230 if {!$td && $i > 0} {
8231 if {[info exists idtags
($id)]} {
8234 } elseif
{[info exists cached_atags
($id)]} {
8235 set tagloc
($id) $cached_atags($id)
8239 foreach a
$arcout($id) {
8240 if {!$td && $arctags($a) ne
{}} {
8242 if {$arctags($a) ne
{}} {
8243 lappend tagloc
($id) [lindex
$arctags($a) 0]
8246 if {![info exists arcend
($a)]} continue
8248 if {$td ||
$arctags($a) ne
{}} {
8249 set tomark
[list
$d]
8250 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8251 set dd [lindex
$tomark $j]
8252 if {![info exists hastaggeddescendent
($dd)]} {
8253 if {[info exists
done($dd)]} {
8254 foreach b
$arcout($dd) {
8255 if {[info exists arcend
($b)]} {
8256 lappend tomark
$arcend($b)
8259 if {[info exists tagloc
($dd)]} {
8262 } elseif
{[info exists queued
($dd)]} {
8265 set hastaggeddescendent
($dd) 1
8269 if {![info exists queued
($d)]} {
8272 if {![info exists hastaggeddescendent
($d)]} {
8278 set t2
[clock clicks
-milliseconds]
8281 foreach id
[array names tagloc
] {
8282 if {![info exists hastaggeddescendent
($id)]} {
8283 foreach t
$tagloc($id) {
8284 if {[lsearch
-exact $tags $t] < 0} {
8291 # remove tags that are ancestors of other tags
8292 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8293 set a
[lindex
$tags $i]
8294 for {set j
0} {$j < $i} {incr j
} {
8295 set b
[lindex
$tags $j]
8296 set r
[anc_or_desc
$a $b]
8298 set tags
[lreplace
$tags $j $j]
8301 } elseif
{$r == 1} {
8302 set tags
[lreplace
$tags $i $i]
8309 if {[array names growing
] ne
{}} {
8310 # graph isn't finished, need to check if any tag could get
8311 # eclipsed by another tag coming later. Simply ignore any
8312 # tags that could later get eclipsed.
8315 if {[is_certain
$origid $t]} {
8319 if {$tags eq
$ctags} {
8320 set cached_atags
($origid) $tags
8325 set cached_atags
($origid) $tags
8327 set t3
[clock clicks
-milliseconds]
8328 if {0 && $t3 - $t1 >= 100} {
8329 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
8330 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8335 # Return the list of IDs that have heads that are descendents of id,
8336 # including id itself if it has a head.
8337 proc descheads
{id
} {
8338 global arcnos arcstart arcids archeads idheads cached_dheads
8341 if {![info exists allparents
($id)]} {
8345 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8346 # part-way along an arc; check it first
8347 set a
[lindex
$arcnos($id) 0]
8348 if {$archeads($a) ne
{}} {
8349 validate_archeads
$a
8350 set i
[lsearch
-exact $arcids($a) $id]
8351 foreach t
$archeads($a) {
8352 set j
[lsearch
-exact $arcids($a) $t]
8357 set id
$arcstart($a)
8363 for {set i
0} {$i < [llength
$todo]} {incr i
} {
8364 set id
[lindex
$todo $i]
8365 if {[info exists cached_dheads
($id)]} {
8366 set ret
[concat
$ret $cached_dheads($id)]
8368 if {[info exists idheads
($id)]} {
8371 foreach a
$arcnos($id) {
8372 if {$archeads($a) ne
{}} {
8373 validate_archeads
$a
8374 if {$archeads($a) ne
{}} {
8375 set ret
[concat
$ret $archeads($a)]
8379 if {![info exists seen
($d)]} {
8386 set ret
[lsort
-unique $ret]
8387 set cached_dheads
($origid) $ret
8388 return [concat
$ret $aret]
8391 proc addedtag
{id
} {
8392 global arcnos arcout cached_dtags cached_atags
8394 if {![info exists arcnos
($id)]} return
8395 if {![info exists arcout
($id)]} {
8396 recalcarc
[lindex
$arcnos($id) 0]
8398 catch
{unset cached_dtags
}
8399 catch
{unset cached_atags
}
8402 proc addedhead
{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 removedhead
{hid
head} {
8413 global cached_dheads
8415 catch
{unset cached_dheads
}
8418 proc movedhead
{hid
head} {
8419 global arcnos arcout cached_dheads
8421 if {![info exists arcnos
($hid)]} return
8422 if {![info exists arcout
($hid)]} {
8423 recalcarc
[lindex
$arcnos($hid) 0]
8425 catch
{unset cached_dheads
}
8428 proc changedrefs
{} {
8429 global cached_dheads cached_dtags cached_atags
8430 global arctags archeads arcnos arcout idheads idtags
8432 foreach id
[concat
[array names idheads
] [array names idtags
]] {
8433 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
8434 set a
[lindex
$arcnos($id) 0]
8435 if {![info exists donearc
($a)]} {
8441 catch
{unset cached_dtags
}
8442 catch
{unset cached_atags
}
8443 catch
{unset cached_dheads
}
8446 proc rereadrefs
{} {
8447 global idtags idheads idotherrefs mainheadid
8449 set refids
[concat
[array names idtags
] \
8450 [array names idheads
] [array names idotherrefs
]]
8451 foreach id
$refids {
8452 if {![info exists ref
($id)]} {
8453 set ref
($id) [listrefs
$id]
8456 set oldmainhead
$mainheadid
8459 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
8460 [array names idheads
] [array names idotherrefs
]]]
8461 foreach id
$refids {
8462 set v
[listrefs
$id]
8463 if {![info exists ref
($id)] ||
$ref($id) != $v ||
8464 ($id eq
$oldmainhead && $id ne
$mainheadid) ||
8465 ($id eq
$mainheadid && $id ne
$oldmainhead)} {
8472 proc listrefs
{id
} {
8473 global idtags idheads idotherrefs
8476 if {[info exists idtags
($id)]} {
8480 if {[info exists idheads
($id)]} {
8484 if {[info exists idotherrefs
($id)]} {
8485 set z
$idotherrefs($id)
8487 return [list
$x $y $z]
8490 proc showtag
{tag isnew
} {
8491 global ctext tagcontents tagids linknum tagobjid
8494 addtohistory
[list showtag
$tag 0]
8496 $ctext conf
-state normal
8500 if {![info exists tagcontents
($tag)]} {
8502 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
8505 if {[info exists tagcontents
($tag)]} {
8506 set text
$tagcontents($tag)
8508 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
8510 appendwithlinks
$text {}
8511 $ctext conf
-state disabled
8522 proc mkfontdisp
{font top
which} {
8523 global fontattr fontpref
$font
8525 set fontpref
($font) [set $font]
8526 button
$top.
${font}but
-text $which -font optionfont \
8527 -command [list choosefont
$font $which]
8528 label
$top.
$font -relief flat
-font $font \
8529 -text $fontattr($font,family
) -justify left
8530 grid x
$top.
${font}but
$top.
$font -sticky w
8533 proc choosefont
{font
which} {
8534 global fontparam fontlist fonttop fontattr
8536 set fontparam
(which) $which
8537 set fontparam
(font
) $font
8538 set fontparam
(family
) [font actual
$font -family]
8539 set fontparam
(size
) $fontattr($font,size
)
8540 set fontparam
(weight
) $fontattr($font,weight
)
8541 set fontparam
(slant
) $fontattr($font,slant
)
8544 if {![winfo exists
$top]} {
8546 eval font config sample
[font actual
$font]
8548 wm title
$top [mc
"Gitk font chooser"]
8549 label
$top.l
-textvariable fontparam
(which) -font uifont
8550 pack
$top.l
-side top
8551 set fontlist
[lsort
[font families
]]
8553 listbox
$top.f.fam
-listvariable fontlist \
8554 -yscrollcommand [list
$top.f.sb
set]
8555 bind $top.f.fam
<<ListboxSelect>> selfontfam
8556 scrollbar $top.f.sb -command [list $top.f.fam yview]
8557 pack $top.f.sb -side right -fill y
8558 pack $top.f.fam -side left -fill both -expand 1
8559 pack $top.f -side top -fill both -expand 1
8561 spinbox $top.g.size -from 4 -to 40 -width 4 \
8562 -textvariable fontparam(size) \
8563 -validatecommand {string is integer -strict %s}
8564 checkbutton $top.g.bold -padx 5 \
8565 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8566 -variable fontparam(weight) -onvalue bold -offvalue normal
8567 checkbutton $top.g.ital -padx 5 \
8568 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8569 -variable fontparam(slant) -onvalue italic -offvalue roman
8570 pack $top.g.size $top.g.bold $top.g.ital -side left
8571 pack $top.g -side top
8572 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8574 $top.c create text 100 25 -anchor center -text $which -font sample \
8575 -fill black -tags text
8576 bind $top.c <Configure> [list centertext $top.c]
8577 pack $top.c -side top -fill x
8579 button $top.buts.ok -text [mc "OK"] -command fontok -default active \
8581 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal \
8583 grid $top.buts.ok $top.buts.can
8584 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8585 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8586 pack $top.buts -side bottom -fill x
8587 trace add variable fontparam write chg_fontparam
8590 $top.c itemconf text -text $which
8592 set i [lsearch -exact $fontlist $fontparam(family)]
8594 $top.f.fam selection set $i
8599 proc centertext {w} {
8600 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8604 global fontparam fontpref prefstop
8606 set f $fontparam(font)
8607 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8608 if {$fontparam(weight) eq "bold"} {
8609 lappend fontpref($f) "bold"
8611 if {$fontparam(slant) eq "italic"} {
8612 lappend fontpref($f) "italic"
8615 $w conf -text $fontparam(family) -font $fontpref($f)
8621 global fonttop fontparam
8623 if {[info exists fonttop]} {
8624 catch {destroy $fonttop}
8625 catch {font delete sample}
8631 proc selfontfam {} {
8632 global fonttop fontparam
8634 set i [$fonttop.f.fam curselection]
8636 set fontparam(family) [$fonttop.f.fam get $i]
8640 proc chg_fontparam {v sub op} {
8643 font config sample -$sub $fontparam($sub)
8647 global maxwidth maxgraphpct
8648 global oldprefs prefstop showneartags showlocalchanges
8649 global bgcolor fgcolor ctext diffcolors selectbgcolor
8650 global uifont tabstop limitdiffs
8654 if {[winfo exists $top]} {
8658 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8659 limitdiffs tabstop} {
8660 set oldprefs($v) [set $v]
8663 wm title $top [mc "Gitk preferences"]
8664 label $top.ldisp -text [mc "Commit list display options"]
8665 $top.ldisp configure -font uifont
8666 grid $top.ldisp - -sticky w -pady 10
8667 label $top.spacer -text " "
8668 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8670 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8671 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8672 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8674 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8675 grid x $top.maxpctl $top.maxpct -sticky w
8676 frame $top.showlocal
8677 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8678 checkbutton $top.showlocal.b -variable showlocalchanges
8679 pack $top.showlocal.b $top.showlocal.l -side left
8680 grid x $top.showlocal -sticky w
8682 label $top.ddisp -text [mc "Diff display options"]
8683 $top.ddisp configure -font uifont
8684 grid $top.ddisp - -sticky w -pady 10
8685 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8686 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8687 grid x $top.tabstopl $top.tabstop -sticky w
8689 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8690 checkbutton $top.ntag.b -variable showneartags
8691 pack $top.ntag.b $top.ntag.l -side left
8692 grid x $top.ntag -sticky w
8694 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8695 checkbutton $top.ldiff.b -variable limitdiffs
8696 pack $top.ldiff.b $top.ldiff.l -side left
8697 grid x $top.ldiff -sticky w
8699 label $top.cdisp -text [mc "Colors: press to choose"]
8700 $top.cdisp configure -font uifont
8701 grid $top.cdisp - -sticky w -pady 10
8702 label $top.bg -padx 40 -relief sunk -background $bgcolor
8703 button $top.bgbut -text [mc "Background"] -font optionfont \
8704 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8705 grid x $top.bgbut $top.bg -sticky w
8706 label $top.fg -padx 40 -relief sunk -background $fgcolor
8707 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8708 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8709 grid x $top.fgbut $top.fg -sticky w
8710 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8711 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8712 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8713 [list $ctext tag conf d0 -foreground]]
8714 grid x $top.diffoldbut $top.diffold -sticky w
8715 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8716 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8717 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8718 [list $ctext tag conf d1 -foreground]]
8719 grid x $top.diffnewbut $top.diffnew -sticky w
8720 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8721 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8722 -command [list choosecolor diffcolors 2 $top.hunksep \
8723 "diff hunk header" \
8724 [list $ctext tag conf hunksep -foreground]]
8725 grid x $top.hunksepbut $top.hunksep -sticky w
8726 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8727 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8728 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8729 grid x $top.selbgbut $top.selbgsep -sticky w
8731 label $top.cfont -text [mc "Fonts: press to choose"]
8732 $top.cfont configure -font uifont
8733 grid $top.cfont - -sticky w -pady 10
8734 mkfontdisp mainfont $top [mc "Main font"]
8735 mkfontdisp textfont $top [mc "Diff display font"]
8736 mkfontdisp uifont $top [mc "User interface font"]
8739 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8740 $top.buts.ok configure -font uifont
8741 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8742 $top.buts.can configure -font uifont
8743 grid $top.buts.ok $top.buts.can
8744 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8745 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8746 grid $top.buts - - -pady 10 -sticky ew
8747 bind $top <Visibility> "focus $top.buts.ok"
8750 proc choosecolor {v vi w x cmd} {
8753 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8754 -title [mc "Gitk: choose color for %s" $x]]
8755 if {$c eq {}} return
8756 $w conf -background $c
8762 global bglist cflist
8764 $w configure -selectbackground $c
8766 $cflist tag configure highlight \
8767 -background [$cflist cget -selectbackground]
8768 allcanvs itemconf secsel -fill $c
8775 $w conf -background $c
8783 $w conf -foreground $c
8785 allcanvs itemconf text -fill $c
8786 $canv itemconf circle -outline $c
8790 global oldprefs prefstop
8792 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8793 limitdiffs tabstop} {
8795 set $v $oldprefs($v)
8797 catch {destroy $prefstop}
8803 global maxwidth maxgraphpct
8804 global oldprefs prefstop showneartags showlocalchanges
8805 global fontpref mainfont textfont uifont
8806 global limitdiffs treediffs
8808 catch {destroy $prefstop}
8812 if {$mainfont ne $fontpref(mainfont)} {
8813 set mainfont $fontpref(mainfont)
8814 parsefont mainfont $mainfont
8815 eval font configure mainfont [fontflags mainfont]
8816 eval font configure mainfontbold [fontflags mainfont 1]
8820 if {$textfont ne $fontpref(textfont)} {
8821 set textfont $fontpref(textfont)
8822 parsefont textfont $textfont
8823 eval font configure textfont [fontflags textfont]
8824 eval font configure textfontbold [fontflags textfont 1]
8826 if {$uifont ne $fontpref(uifont)} {
8827 set uifont $fontpref(uifont)
8828 parsefont uifont $uifont
8829 eval font configure uifont [fontflags uifont]
8832 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8833 if {$showlocalchanges} {
8839 if {$limitdiffs != $oldprefs(limitdiffs)} {
8840 # treediffs elements are limited by path
8841 catch {unset treediffs}
8843 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8844 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8846 } elseif {$showneartags != $oldprefs(showneartags) ||
8847 $limitdiffs != $oldprefs(limitdiffs)} {
8852 proc formatdate {d} {
8853 global datetimeformat
8855 set d [clock format $d -format $datetimeformat]
8860 # This list of encoding names and aliases is distilled from
8861 # http://www.iana.org/assignments/character-sets.
8862 # Not all of them are supported by Tcl.
8863 set encoding_aliases {
8864 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8865 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8866 { ISO-10646-UTF-1 csISO10646UTF1 }
8867 { ISO_646.basic:1983 ref csISO646basic1983 }
8868 { INVARIANT csINVARIANT }
8869 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8870 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8871 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8872 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8873 { NATS-DANO iso-ir-9-1 csNATSDANO }
8874 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8875 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8876 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8877 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8878 { ISO-2022-KR csISO2022KR }
8880 { ISO-2022-JP csISO2022JP }
8881 { ISO-2022-JP-2 csISO2022JP2 }
8882 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8884 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8885 { IT iso-ir-15 ISO646-IT csISO15Italian }
8886 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8887 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8888 { greek7-old iso-ir-18 csISO18Greek7Old }
8889 { latin-greek iso-ir-19 csISO19LatinGreek }
8890 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8891 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8892 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8893 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8894 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8895 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8896 { INIS iso-ir-49 csISO49INIS }
8897 { INIS-8 iso-ir-50 csISO50INIS8 }
8898 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8899 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8900 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8901 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8902 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8903 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8905 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8906 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8907 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8908 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8909 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8910 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8911 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8912 { greek7 iso-ir-88 csISO88Greek7 }
8913 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8914 { iso-ir-90 csISO90 }
8915 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8916 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8917 csISO92JISC62991984b }
8918 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8919 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8920 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8921 csISO95JIS62291984handadd }
8922 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8923 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8924 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8925 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8927 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8928 { T.61-7bit iso-ir-102 csISO102T617bit }
8929 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8930 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8931 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8932 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8933 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8934 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8935 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8936 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8937 arabic csISOLatinArabic }
8938 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8939 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8940 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8941 greek greek8 csISOLatinGreek }
8942 { T.101-G2 iso-ir-128 csISO128T101G2 }
8943 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8945 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8946 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8947 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8948 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8949 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8950 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8951 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8952 csISOLatinCyrillic }
8953 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8954 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8955 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8956 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8957 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8958 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8959 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8960 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8961 { ISO_10367-box iso-ir-155 csISO10367Box }
8962 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8963 { latin-lap lap iso-ir-158 csISO158Lap }
8964 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8965 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8968 { JIS_X0201 X0201 csHalfWidthKatakana }
8969 { KSC5636 ISO646-KR csKSC5636 }
8970 { ISO-10646-UCS-2 csUnicode }
8971 { ISO-10646-UCS-4 csUCS4 }
8972 { DEC-MCS dec csDECMCS }
8973 { hp-roman8 roman8 r8 csHPRoman8 }
8974 { macintosh mac csMacintosh }
8975 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8977 { IBM038 EBCDIC-INT cp038 csIBM038 }
8978 { IBM273 CP273 csIBM273 }
8979 { IBM274 EBCDIC-BE CP274 csIBM274 }
8980 { IBM275 EBCDIC-BR cp275 csIBM275 }
8981 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8982 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8983 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8984 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8985 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8986 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8987 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8988 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8989 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8990 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8991 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8992 { IBM437 cp437 437 csPC8CodePage437 }
8993 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8994 { IBM775 cp775 csPC775Baltic }
8995 { IBM850 cp850 850 csPC850Multilingual }
8996 { IBM851 cp851 851 csIBM851 }
8997 { IBM852 cp852 852 csPCp852 }
8998 { IBM855 cp855 855 csIBM855 }
8999 { IBM857 cp857 857 csIBM857 }
9000 { IBM860 cp860 860 csIBM860 }
9001 { IBM861 cp861 861 cp-is csIBM861 }
9002 { IBM862 cp862 862 csPC862LatinHebrew }
9003 { IBM863 cp863 863 csIBM863 }
9004 { IBM864 cp864 csIBM864 }
9005 { IBM865 cp865 865 csIBM865 }
9006 { IBM866 cp866 866 csIBM866 }
9007 { IBM868 CP868 cp-ar csIBM868 }
9008 { IBM869 cp869 869 cp-gr csIBM869 }
9009 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9010 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9011 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9012 { IBM891 cp891 csIBM891 }
9013 { IBM903 cp903 csIBM903 }
9014 { IBM904 cp904 904 csIBBM904 }
9015 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9016 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9017 { IBM1026 CP1026 csIBM1026 }
9018 { EBCDIC-AT-DE csIBMEBCDICATDE }
9019 { EBCDIC-AT-DE-A csEBCDICATDEA }
9020 { EBCDIC-CA-FR csEBCDICCAFR }
9021 { EBCDIC-DK-NO csEBCDICDKNO }
9022 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9023 { EBCDIC-FI-SE csEBCDICFISE }
9024 { EBCDIC-FI-SE-A csEBCDICFISEA }
9025 { EBCDIC-FR csEBCDICFR }
9026 { EBCDIC-IT csEBCDICIT }
9027 { EBCDIC-PT csEBCDICPT }
9028 { EBCDIC-ES csEBCDICES }
9029 { EBCDIC-ES-A csEBCDICESA }
9030 { EBCDIC-ES-S csEBCDICESS }
9031 { EBCDIC-UK csEBCDICUK }
9032 { EBCDIC-US csEBCDICUS }
9033 { UNKNOWN-8BIT csUnknown8BiT }
9034 { MNEMONIC csMnemonic }
9039 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9040 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9041 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9042 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9043 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9044 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9045 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9046 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9047 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9048 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9049 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9050 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9051 { IBM1047 IBM-1047 }
9052 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9053 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9054 { UNICODE-1-1 csUnicode11 }
9057 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9058 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9060 { ISO-8859-15 ISO_8859-15 Latin-9 }
9061 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9062 { GBK CP936 MS936 windows-936 }
9063 { JIS_Encoding csJISEncoding }
9064 { Shift_JIS MS_Kanji csShiftJIS }
9065 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9067 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9068 { ISO-10646-UCS-Basic csUnicodeASCII }
9069 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9070 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9071 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9072 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9073 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9074 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9075 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9076 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9077 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9078 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9079 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9080 { Ventura-US csVenturaUS }
9081 { Ventura-International csVenturaInternational }
9082 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9083 { PC8-Turkish csPC8Turkish }
9084 { IBM-Symbols csIBMSymbols }
9085 { IBM-Thai csIBMThai }
9086 { HP-Legal csHPLegal }
9087 { HP-Pi-font csHPPiFont }
9088 { HP-Math8 csHPMath8 }
9089 { Adobe-Symbol-Encoding csHPPSMath }
9090 { HP-DeskTop csHPDesktop }
9091 { Ventura-Math csVenturaMath }
9092 { Microsoft-Publishing csMicrosoftPublishing }
9093 { Windows-31J csWindows31J }
9098 proc tcl_encoding {enc} {
9099 global encoding_aliases
9100 set names [encoding names]
9101 set lcnames [string tolower $names]
9102 set enc [string tolower $enc]
9103 set i [lsearch -exact $lcnames $enc]
9105 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9106 if {[regsub {^iso[-_]} $enc iso encx]} {
9107 set i [lsearch -exact $lcnames $encx]
9111 foreach l $encoding_aliases {
9112 set ll [string tolower $l]
9113 if {[lsearch -exact $ll $enc] < 0} continue
9114 # look through the aliases for one that tcl knows about
9116 set i [lsearch -exact $lcnames $e]
9118 if {[regsub {^iso[-_]} $e iso ex]} {
9119 set i [lsearch -exact $lcnames $ex]
9128 return [lindex $names $i]
9133 # First check that Tcl/Tk is recent enough
9134 if {[catch {package require Tk 8.4} err]} {
9135 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9136 Gitk requires at least Tcl/Tk 8.4."]
9142 set wrcomcmd "git diff-tree --stdin -p --pretty"
9146 set gitencoding [exec git config --get i18n.commitencoding]
9148 if {$gitencoding == ""} {
9149 set gitencoding "utf-8"
9151 set tclencoding [tcl_encoding $gitencoding]
9152 if {$tclencoding == {}} {
9153 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9156 set mainfont {Helvetica 9}
9157 set textfont {Courier 9}
9158 set uifont {Helvetica 9 bold}
9160 set findmergefiles 0
9168 set cmitmode "patch"
9169 set wrapcomment "none"
9173 set showlocalchanges 1
9175 set datetimeformat "%Y-%m-%d %H:%M:%S"
9177 set colors {green red blue magenta darkgrey brown orange}
9180 set diffcolors {red "#00a000" blue}
9182 set selectbgcolor gray85
9184 ## For msgcat loading, first locate the installation location.
9185 if { [info exists ::env(GITK_MSGSDIR)] } {
9186 ## Msgsdir was manually set in the environment.
9187 set gitk_msgsdir $::env(GITK_MSGSDIR)
9189 ## Let's guess the prefix from argv0.
9190 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9191 set gitk_libdir [file join $gitk_prefix share gitk lib]
9192 set gitk_msgsdir [file join $gitk_libdir msgs]
9196 ## Internationalization (i18n) through msgcat and gettext. See
9197 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9198 package require msgcat
9199 namespace import ::msgcat::mc
9200 ## And eventually load the actual message catalog
9201 ::msgcat::mcload $gitk_msgsdir
9203 catch {source ~/.gitk}
9205 font create optionfont -family sans-serif -size -12
9207 parsefont mainfont $mainfont
9208 eval font create mainfont [fontflags mainfont]
9209 eval font create mainfontbold [fontflags mainfont 1]
9211 parsefont textfont $textfont
9212 eval font create textfont [fontflags textfont]
9213 eval font create textfontbold [fontflags textfont 1]
9215 parsefont uifont $uifont
9216 eval font create uifont [fontflags uifont]
9218 # check that we can find a .git directory somewhere...
9219 if {[catch {set gitdir [gitdir]}]} {
9220 show_error {} . [mc "Cannot find a git repository here."]
9223 if {![file isdirectory $gitdir]} {
9224 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9230 set cmdline_files {}
9235 "-d" { set datemode 1 }
9238 lappend revtreeargs $arg
9241 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9245 lappend revtreeargs $arg
9251 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9252 # no -- on command line, but some arguments (other than -d)
9254 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9255 set cmdline_files [split $f "\n"]
9256 set n [llength $cmdline_files]
9257 set revtreeargs [lrange $revtreeargs 0 end-$n]
9258 # Unfortunately git rev-parse doesn't produce an error when
9259 # something is both a revision and a filename. To be consistent
9260 # with git log and git rev-list, check revtreeargs for filenames.
9261 foreach arg $revtreeargs {
9262 if {[file exists $arg]} {
9263 show_error {} . [mc "Ambiguous argument '%s': both revision\
9269 # unfortunately we get both stdout and stderr in $err,
9270 # so look for "fatal:".
9271 set i [string first "fatal:" $err]
9273 set err [string range $err [expr {$i + 6}] end]
9275 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9281 # find the list of unmerged files
9285 set fd [open "| git ls-files -u" r]
9287 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9290 while {[gets $fd line] >= 0} {
9291 set i [string first "\t" $line]
9292 if {$i < 0} continue
9293 set fname [string range $line [expr {$i+1}] end]
9294 if {[lsearch -exact $mlist $fname] >= 0} continue
9296 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9297 lappend mlist $fname
9302 if {$nr_unmerged == 0} {
9303 show_error {} . [mc "No files selected: --merge specified but\
9304 no files are unmerged."]
9306 show_error {} . [mc "No files selected: --merge specified but\
9307 no unmerged files are within file limit."]
9311 set cmdline_files $mlist
9314 set nullid "0000000000000000000000000000000000000000"
9315 set nullid2 "0000000000000000000000000000000000000001"
9317 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9324 set highlight_paths {}
9326 set searchdirn -forwards
9330 set markingmatches 0
9331 set linkentercount 0
9332 set need_redisplay 0
9339 set selectedhlview [mc "None"]
9340 set highlight_related [mc "None"]
9341 set highlight_files {}
9354 # wait for the window to become visible
9356 wm title . "[file tail $argv0]: [file tail [pwd]]"
9359 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9360 # create a view for the files/dirs specified on the command line
9364 set viewname(1) [mc "Command line"]
9365 set viewfiles(1) $cmdline_files
9366 set viewargs(1) $revtreeargs
9369 .bar.view entryconf [mc "Edit view..."] -state normal
9370 .bar.view entryconf [mc "Delete view"] -state normal
9373 if {[info exists permviews]} {
9374 foreach v $permviews {
9377 set viewname($n) [lindex $v 0]
9378 set viewfiles($n) [lindex $v 1]
9379 set viewargs($n) [lindex $v 2]