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
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
}
261 # This makes a string representation of a positive integer which
262 # sorts as a string in numerical order
265 return [format
"%x" $n]
266 } elseif
{$n < 256} {
267 return [format
"x%.2x" $n]
268 } elseif
{$n < 65536} {
269 return [format
"y%.4x" $n]
271 return [format
"z%.8x" $n]
274 # Procedures used in reordering commits from git log (without
275 # --topo-order) into the order for display.
277 proc varcinit
{view
} {
278 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
279 global vtokmod varcmod vrowmod varcix vlastins
281 set varcstart
($view) {{}}
282 set vupptr
($view) {0}
283 set vdownptr
($view) {0}
284 set vleftptr
($view) {0}
285 set vbackptr
($view) {0}
286 set varctok
($view) {{}}
287 set varcrow
($view) {{}}
288 set vtokmod
($view) {}
291 set varcix
($view) {{}}
292 set vlastins
($view) {0}
295 proc resetvarcs
{view
} {
296 global varcid varccommits parents children vseedcount ordertok
298 foreach vid
[array names varcid
$view,*] {
303 # some commits might have children but haven't been seen yet
304 foreach vid
[array names children
$view,*] {
307 foreach va
[array names varccommits
$view,*] {
308 unset varccommits
($va)
310 foreach vd
[array names vseedcount
$view,*] {
311 unset vseedcount
($vd)
313 catch
{unset ordertok
}
316 proc newvarc
{view id
} {
317 global varcid varctok parents children datemode
318 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
319 global commitdata commitinfo vseedcount varccommits vlastins
321 set a
[llength
$varctok($view)]
323 if {[llength
$children($vid)] == 0 ||
$datemode} {
324 if {![info exists commitinfo
($id)]} {
325 parsecommit
$id $commitdata($id) 1
327 set cdate
[lindex
$commitinfo($id) 4]
328 if {![string is integer
-strict $cdate]} {
331 if {![info exists vseedcount
($view,$cdate)]} {
332 set vseedcount
($view,$cdate) -1
334 set c
[incr vseedcount
($view,$cdate)]
335 set cdate
[expr {$cdate ^
0xffffffff}]
336 set tok
"s[strrep $cdate][strrep $c]"
341 if {[llength
$children($vid)] > 0} {
342 set kid
[lindex
$children($vid) end
]
343 set k
$varcid($view,$kid)
344 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
347 set tok
[lindex
$varctok($view) $k]
351 set i
[lsearch
-exact $parents($view,$ki) $id]
352 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
353 append tok
[strrep
$j]
355 set c
[lindex
$vlastins($view) $ka]
356 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
358 set b
[lindex
$vdownptr($view) $ka]
360 set b
[lindex
$vleftptr($view) $c]
362 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
364 set b
[lindex
$vleftptr($view) $c]
367 lset vdownptr
($view) $ka $a
368 lappend vbackptr
($view) 0
370 lset vleftptr
($view) $c $a
371 lappend vbackptr
($view) $c
373 lset vlastins
($view) $ka $a
374 lappend vupptr
($view) $ka
375 lappend vleftptr
($view) $b
377 lset vbackptr
($view) $b $a
379 lappend varctok
($view) $tok
380 lappend varcstart
($view) $id
381 lappend vdownptr
($view) 0
382 lappend varcrow
($view) {}
383 lappend varcix
($view) {}
384 set varccommits
($view,$a) {}
385 lappend vlastins
($view) 0
389 proc splitvarc
{p v
} {
390 global varcid varcstart varccommits varctok
391 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
393 set oa
$varcid($v,$p)
394 set ac
$varccommits($v,$oa)
395 set i
[lsearch
-exact $varccommits($v,$oa) $p]
397 set na
[llength
$varctok($v)]
398 # "%" sorts before "0"...
399 set tok
"[lindex $varctok($v) $oa]%[strrep $i]"
400 lappend varctok
($v) $tok
401 lappend varcrow
($v) {}
402 lappend varcix
($v) {}
403 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
404 set varccommits
($v,$na) [lrange
$ac $i end
]
405 lappend varcstart
($v) $p
406 foreach id
$varccommits($v,$na) {
407 set varcid
($v,$id) $na
409 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
410 lset vdownptr
($v) $oa $na
411 lappend vupptr
($v) $oa
412 lappend vleftptr
($v) 0
413 lappend vbackptr
($v) 0
414 lappend vlastins
($v) 0
415 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
416 lset vupptr
($v) $b $na
420 proc renumbervarc
{a v
} {
421 global parents children varctok varcstart varccommits
422 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
424 set t1
[clock clicks
-milliseconds]
430 if {[info exists isrelated
($a)]} {
432 set id
[lindex
$varccommits($v,$a) end
]
433 foreach p
$parents($v,$id) {
434 if {[info exists varcid
($v,$p)]} {
435 set isrelated
($varcid($v,$p)) 1
440 set b
[lindex
$vdownptr($v) $a]
443 set b
[lindex
$vleftptr($v) $a]
445 set a
[lindex
$vupptr($v) $a]
451 if {![info exists kidchanged
($a)]} continue
452 set id
[lindex
$varcstart($v) $a]
453 if {[llength
$children($v,$id)] > 1} {
454 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
457 set oldtok
[lindex
$varctok($v) $a]
464 if {[llength
$children($v,$id)] > 0} {
465 set kid
[lindex
$children($v,$id) end
]
466 set k
$varcid($v,$kid)
467 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
470 set tok
[lindex
$varctok($v) $k]
474 set i
[lsearch
-exact $parents($v,$ki) $id]
475 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
476 append tok
[strrep
$j]
478 if {$tok eq
$oldtok} {
481 set id
[lindex
$varccommits($v,$a) end
]
482 foreach p
$parents($v,$id) {
483 if {[info exists varcid
($v,$p)]} {
484 set kidchanged
($varcid($v,$p)) 1
489 lset varctok
($v) $a $tok
490 set b
[lindex
$vupptr($v) $a]
492 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
495 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
498 set c
[lindex
$vbackptr($v) $a]
499 set d
[lindex
$vleftptr($v) $a]
501 lset vdownptr
($v) $b $d
503 lset vleftptr
($v) $c $d
506 lset vbackptr
($v) $d $c
508 lset vupptr
($v) $a $ka
509 set c
[lindex
$vlastins($v) $ka]
511 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
513 set b
[lindex
$vdownptr($v) $ka]
515 set b
[lindex
$vleftptr($v) $c]
518 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
520 set b
[lindex
$vleftptr($v) $c]
523 lset vdownptr
($v) $ka $a
524 lset vbackptr
($v) $a 0
526 lset vleftptr
($v) $c $a
527 lset vbackptr
($v) $a $c
529 lset vleftptr
($v) $a $b
531 lset vbackptr
($v) $b $a
533 lset vlastins
($v) $ka $a
536 foreach id
[array names sortkids
] {
537 if {[llength
$children($v,$id)] > 1} {
538 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
542 set t2
[clock clicks
-milliseconds]
543 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
546 proc fix_reversal
{p a v
} {
547 global varcid varcstart varctok vupptr
549 set pa
$varcid($v,$p)
550 if {$p ne
[lindex
$varcstart($v) $pa]} {
552 set pa
$varcid($v,$p)
554 # seeds always need to be renumbered
555 if {[lindex
$vupptr($v) $pa] == 0 ||
556 [string compare
[lindex
$varctok($v) $a] \
557 [lindex
$varctok($v) $pa]] > 0} {
562 proc insertrow
{id p v
} {
563 global varcid varccommits parents children cmitlisted
564 global commitidx varctok vtokmod
567 set i
[lsearch
-exact $varccommits($v,$a) $p]
569 puts
"oops: insertrow can't find [shortids $p] on arc $a"
572 set children
($v,$id) {}
573 set parents
($v,$id) [list
$p]
574 set varcid
($v,$id) $a
575 lappend children
($v,$p) $id
576 set cmitlisted
($v,$id) 1
578 # note we deliberately don't update varcstart($v) even if $i == 0
579 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
580 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
586 proc removerow
{id v
} {
587 global varcid varccommits parents children commitidx
588 global varctok vtokmod cmitlisted currentid selectedline
590 if {[llength
$parents($v,$id)] != 1} {
591 puts
"oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
594 set p
[lindex
$parents($v,$id) 0]
595 set a
$varcid($v,$id)
596 set i
[lsearch
-exact $varccommits($v,$a) $id]
598 puts
"oops: removerow can't find [shortids $id] on arc $a"
602 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
603 unset parents
($v,$id)
604 unset children
($v,$id)
605 unset cmitlisted
($v,$id)
606 incr commitidx
($v) -1
607 set j
[lsearch
-exact $children($v,$p) $id]
609 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
611 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
614 if {[info exist currentid
] && $id eq
$currentid} {
621 proc vtokcmp
{v a b
} {
622 global varctok varcid
624 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
625 [lindex
$varctok($v) $varcid($v,$b)]]
628 proc modify_arc
{v a
{lim
{}}} {
629 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
630 global vhighlights nhighlights fhighlights rhighlights
632 set vtokmod
($v) [lindex
$varctok($v) $a]
634 if {$v == $curview} {
635 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
636 set a
[lindex
$vupptr($v) $a]
642 set lim
[llength
$varccommits($v,$a)]
644 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
649 catch
{unset nhighlights
}
650 catch
{unset fhighlights
}
651 catch
{unset vhighlights
}
652 catch
{unset rhighlights
}
655 proc update_arcrows
{v
} {
656 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
657 global varcid vrownum varcorder varcix varccommits
658 global vupptr vdownptr vleftptr varctok
659 global displayorder parentlist curview cached_commitrow
661 set narctot
[expr {[llength
$varctok($v)] - 1}]
663 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
664 # go up the tree until we find something that has a row number,
665 # or we get to a seed
666 set a
[lindex
$vupptr($v) $a]
669 set a
[lindex
$vdownptr($v) 0]
672 set varcorder
($v) [list
$a]
674 lset varcrow
($v) $a 0
678 set arcn
[lindex
$varcix($v) $a]
679 # see if a is the last arc; if so, nothing to do
680 if {$arcn == $narctot - 1} {
683 if {[llength
$vrownum($v)] > $arcn + 1} {
684 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
685 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
687 set row
[lindex
$varcrow($v) $a]
689 if {$v == $curview} {
690 if {[llength
$displayorder] > $vrowmod($v)} {
691 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
692 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
694 catch
{unset cached_commitrow
}
698 incr row
[llength
$varccommits($v,$a)]
699 # go down if possible
700 set b
[lindex
$vdownptr($v) $a]
702 # if not, go left, or go up until we can go left
704 set b
[lindex
$vleftptr($v) $a]
706 set a
[lindex
$vupptr($v) $a]
712 lappend vrownum
($v) $row
713 lappend varcorder
($v) $a
714 lset varcix
($v) $a $arcn
715 lset varcrow
($v) $a $row
717 set vtokmod
($v) [lindex
$varctok($v) $p]
720 if {[info exists currentid
]} {
721 set selectedline
[rowofcommit
$currentid]
725 # Test whether view $v contains commit $id
726 proc commitinview
{id v
} {
729 return [info exists varcid
($v,$id)]
732 # Return the row number for commit $id in the current view
733 proc rowofcommit
{id
} {
734 global varcid varccommits varcrow curview cached_commitrow
735 global varctok vtokmod
738 if {![info exists varcid
($v,$id)]} {
739 puts
"oops rowofcommit no arc for [shortids $id]"
742 set a
$varcid($v,$id)
743 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
746 if {[info exists cached_commitrow
($id)]} {
747 return $cached_commitrow($id)
749 set i
[lsearch
-exact $varccommits($v,$a) $id]
751 puts
"oops didn't find commit [shortids $id] in arc $a"
754 incr i
[lindex
$varcrow($v) $a]
755 set cached_commitrow
($id) $i
759 proc bsearch
{l elt
} {
760 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
765 while {$hi - $lo > 1} {
766 set mid
[expr {int
(($lo + $hi) / 2)}]
767 set t
[lindex
$l $mid]
770 } elseif
{$elt > $t} {
779 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
780 proc make_disporder
{start end
} {
781 global vrownum curview commitidx displayorder parentlist
782 global varccommits varcorder parents vrowmod varcrow
783 global d_valid_start d_valid_end
785 if {$end > $vrowmod($curview)} {
786 update_arcrows
$curview
788 set ai
[bsearch
$vrownum($curview) $start]
789 set start
[lindex
$vrownum($curview) $ai]
790 set narc
[llength
$vrownum($curview)]
791 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
792 set a
[lindex
$varcorder($curview) $ai]
793 set l
[llength
$displayorder]
794 set al
[llength
$varccommits($curview,$a)]
797 set pad
[ntimes
[expr {$r - $l}] {}]
798 set displayorder
[concat
$displayorder $pad]
799 set parentlist
[concat
$parentlist $pad]
801 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
802 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
804 foreach id
$varccommits($curview,$a) {
805 lappend displayorder
$id
806 lappend parentlist
$parents($curview,$id)
808 } elseif
{[lindex
$displayorder $r] eq
{}} {
810 foreach id
$varccommits($curview,$a) {
811 lset displayorder
$i $id
812 lset parentlist
$i $parents($curview,$id)
820 proc commitonrow
{row
} {
823 set id
[lindex
$displayorder $row]
825 make_disporder
$row [expr {$row + 1}]
826 set id
[lindex
$displayorder $row]
831 proc closevarcs
{v
} {
832 global varctok varccommits varcid parents children
833 global cmitlisted commitidx commitinterest vtokmod
835 set missing_parents
0
837 set narcs
[llength
$varctok($v)]
838 for {set a
1} {$a < $narcs} {incr a
} {
839 set id
[lindex
$varccommits($v,$a) end
]
840 foreach p
$parents($v,$id) {
841 if {[info exists varcid
($v,$p)]} continue
842 # add p as a new commit
844 set cmitlisted
($v,$p) 0
845 set parents
($v,$p) {}
846 if {[llength
$children($v,$p)] == 1 &&
847 [llength
$parents($v,$id)] == 1} {
850 set b
[newvarc
$v $p]
853 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
856 lappend varccommits
($v,$b) $p
858 if {[info exists commitinterest
($p)]} {
859 foreach
script $commitinterest($p) {
860 lappend scripts
[string map
[list
"%I" $p] $script]
862 unset commitinterest
($id)
866 if {$missing_parents > 0} {
873 proc getcommitlines
{fd inst view
} {
874 global cmitlisted commitinterest leftover
875 global commitidx commitdata datemode
876 global parents children curview hlview
877 global vnextroot idpending ordertok
878 global varccommits varcid varctok vtokmod
880 set stuff
[read $fd 500000]
881 # git log doesn't terminate the last commit with a null...
882 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
889 global commfd viewcomplete viewactive viewname progresscoords
892 set i
[lsearch
-exact $viewinstances($view) $inst]
894 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
896 # set it blocking so we wait for the process to terminate
897 fconfigure
$fd -blocking 1
898 if {[catch
{close
$fd} err
]} {
900 if {$view != $curview} {
901 set fv
" for the \"$viewname($view)\" view"
903 if {[string range
$err 0 4] == "usage"} {
904 set err
"Gitk: error reading commits$fv:\
905 bad arguments to git rev-list."
906 if {$viewname($view) eq
"Command line"} {
908 " (Note: arguments to gitk are passed to git rev-list\
909 to allow selection of commits to be displayed.)"
912 set err
"Error reading commits$fv: $err"
916 if {[incr viewactive
($view) -1] <= 0} {
917 set viewcomplete
($view) 1
918 # Check if we have seen any ids listed as parents that haven't
919 # appeared in the list
922 set progresscoords
{0 0}
925 if {$view == $curview} {
926 run chewcommits
$view
934 set i
[string first
"\0" $stuff $start]
936 append leftover
($inst) [string range
$stuff $start end
]
940 set cmit
$leftover($inst)
941 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
942 set leftover
($inst) {}
944 set cmit
[string range
$stuff $start [expr {$i - 1}]]
946 set start
[expr {$i + 1}]
947 set j
[string first
"\n" $cmit]
950 if {$j >= 0 && [string match
"commit *" $cmit]} {
951 set ids
[string range
$cmit 7 [expr {$j - 1}]]
952 if {[string match
{[-<>]*} $ids]} {
953 switch
-- [string index
$ids 0] {
958 set ids
[string range
$ids 1 end
]
962 if {[string length
$id] != 40} {
970 if {[string length
$shortcmit] > 80} {
971 set shortcmit
"[string range $shortcmit 0 80]..."
973 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
976 set id [lindex $ids 0]
978 if {!$listed && [info exists parents($vid)]} continue
980 set olds [lrange $ids 1 end]
984 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
985 set cmitlisted($vid) $listed
986 set parents($vid) $olds
988 if {![info exists children($vid)]} {
989 set children($vid) {}
990 } elseif {[llength $children($vid)] == 1} {
991 set k [lindex $children($vid) 0]
992 if {[llength $parents($view,$k)] == 1 &&
994 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
995 set a $varcid($view,$k)
1000 set a [newvarc $view $id]
1003 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1006 lappend varccommits($view,$a) $id
1010 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1012 if {[llength [lappend children($vp) $id]] > 1 &&
1013 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1014 set children($vp) [lsort -command [list vtokcmp $view] \
1016 catch {unset ordertok}
1018 if {[info exists varcid($view,$p)]} {
1019 fix_reversal $p $a $view
1025 incr commitidx($view)
1026 if {[info exists commitinterest($id)]} {
1027 foreach script $commitinterest($id) {
1028 lappend scripts [string map [list "%I" $id] $script]
1030 unset commitinterest($id)
1035 run chewcommits $view
1036 foreach s $scripts {
1039 if {$view == $curview} {
1040 # update progress bar
1041 global progressdirn progresscoords proglastnc
1042 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1043 set proglastnc $commitidx($view)
1044 set l [lindex $progresscoords 0]
1045 set r [lindex $progresscoords 1]
1046 if {$progressdirn} {
1047 set r [expr {$r + $inc}]
1053 set l [expr {$r - 0.2}]
1056 set l [expr {$l - $inc}]
1061 set r [expr {$l + 0.2}]
1063 set progresscoords [list $l $r]
1070 proc chewcommits {view} {
1071 global curview hlview viewcomplete
1072 global pending_select
1074 if {$view == $curview} {
1076 if {$viewcomplete($view)} {
1077 global commitidx varctok
1078 global numcommits startmsecs
1079 global mainheadid commitinfo nullid
1081 if {[info exists pending_select]} {
1082 set row [first_real_row]
1085 if {$commitidx($curview) > 0} {
1086 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1087 #puts "overall $ms ms for $numcommits commits"
1088 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1090 show_status [mc "No commits selected"]
1095 if {[info exists hlview] && $view == $hlview} {
1101 proc readcommit {id} {
1102 if {[catch {set contents [exec git cat-file commit $id]}]} return
1103 parsecommit $id $contents 0
1106 proc parsecommit {id contents listed} {
1107 global commitinfo cdate
1116 set hdrend [string first "\n\n" $contents]
1118 # should never happen...
1119 set hdrend [string length $contents]
1121 set header [string range $contents 0 [expr {$hdrend - 1}]]
1122 set comment [string range $contents [expr {$hdrend + 2}] end]
1123 foreach line [split $header "\n"] {
1124 set tag [lindex $line 0]
1125 if {$tag == "author"} {
1126 set audate [lindex $line end-1]
1127 set auname [lrange $line 1 end-2]
1128 } elseif {$tag == "committer"} {
1129 set comdate [lindex $line end-1]
1130 set comname [lrange $line 1 end-2]
1134 # take the first non-blank line of the comment as the headline
1135 set headline [string trimleft $comment]
1136 set i [string first "\n" $headline]
1138 set headline [string range $headline 0 $i]
1140 set headline [string trimright $headline]
1141 set i [string first "\r" $headline]
1143 set headline [string trimright [string range $headline 0 $i]]
1146 # git rev-list indents the comment by 4 spaces;
1147 # if we got this via git cat-file, add the indentation
1149 foreach line [split $comment "\n"] {
1150 append newcomment " "
1151 append newcomment $line
1152 append newcomment "\n"
1154 set comment $newcomment
1156 if {$comdate != {}} {
1157 set cdate($id) $comdate
1159 set commitinfo($id) [list $headline $auname $audate \
1160 $comname $comdate $comment]
1163 proc getcommit {id} {
1164 global commitdata commitinfo
1166 if {[info exists commitdata($id)]} {
1167 parsecommit $id $commitdata($id) 1
1170 if {![info exists commitinfo($id)]} {
1171 set commitinfo($id) [list [mc "No commit information available"]]
1178 global tagids idtags headids idheads tagobjid
1179 global otherrefids idotherrefs mainhead mainheadid
1181 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1184 set refd [open [list | git show-ref -d] r]
1185 while {[gets $refd line] >= 0} {
1186 if {[string index $line 40] ne " "} continue
1187 set id [string range $line 0 39]
1188 set ref [string range $line 41 end]
1189 if {![string match "refs/*" $ref]} continue
1190 set name [string range $ref 5 end]
1191 if {[string match "remotes/*" $name]} {
1192 if {![string match "*/HEAD" $name]} {
1193 set headids($name) $id
1194 lappend idheads($id) $name
1196 } elseif {[string match "heads/*" $name]} {
1197 set name [string range $name 6 end]
1198 set headids($name) $id
1199 lappend idheads($id) $name
1200 } elseif {[string match "tags/*" $name]} {
1201 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1202 # which is what we want since the former is the commit ID
1203 set name [string range $name 5 end]
1204 if {[string match "*^{}" $name]} {
1205 set name [string range $name 0 end-3]
1207 set tagobjid($name) $id
1209 set tagids($name) $id
1210 lappend idtags($id) $name
1212 set otherrefids($name) $id
1213 lappend idotherrefs($id) $name
1220 set thehead [exec git symbolic-ref HEAD]
1221 if {[string match "refs/heads/*" $thehead]} {
1222 set mainhead [string range $thehead 11 end]
1223 if {[info exists headids($mainhead)]} {
1224 set mainheadid $headids($mainhead)
1230 # skip over fake commits
1231 proc first_real_row {} {
1232 global nullid nullid2 numcommits
1234 for {set row 0} {$row < $numcommits} {incr row} {
1235 set id [commitonrow $row]
1236 if {$id ne $nullid && $id ne $nullid2} {
1243 # update things for a head moved to a child of its previous location
1244 proc movehead {id name} {
1245 global headids idheads
1247 removehead $headids($name) $name
1248 set headids($name) $id
1249 lappend idheads($id) $name
1252 # update things when a head has been removed
1253 proc removehead {id name} {
1254 global headids idheads
1256 if {$idheads($id) eq $name} {
1259 set i [lsearch -exact $idheads($id) $name]
1261 set idheads($id) [lreplace $idheads($id) $i $i]
1264 unset headids($name)
1267 proc show_error {w top msg} {
1268 message $w.m -text $msg -justify center -aspect 400
1269 pack $w.m -side top -fill x -padx 20 -pady 20
1270 button $w.ok -text [mc OK] -command "destroy $top"
1271 pack $w.ok -side bottom -fill x
1272 bind $top <Visibility> "grab $top; focus $top"
1273 bind $top <Key-Return> "destroy $top"
1277 proc error_popup msg {
1281 show_error $w $w $msg
1284 proc confirm_popup msg {
1290 message $w.m -text $msg -justify center -aspect 400
1291 pack $w.m -side top -fill x -padx 20 -pady 20
1292 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1293 pack $w.ok -side left -fill x
1294 button $w.cancel -text [mc Cancel] -command "destroy $w"
1295 pack $w.cancel -side right -fill x
1296 bind $w <Visibility> "grab $w; focus $w"
1301 proc makewindow {} {
1302 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1304 global findtype findtypemenu findloc findstring fstring geometry
1305 global entries sha1entry sha1string sha1but
1306 global diffcontextstring diffcontext
1307 global maincursor textcursor curtextcursor
1308 global rowctxmenu fakerowmenu mergemax wrapcomment
1309 global highlight_files gdttype
1310 global searchstring sstring
1311 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1312 global headctxmenu progresscanv progressitem progresscoords statusw
1313 global fprogitem fprogcoord lastprogupdate progupdatepending
1314 global rprogitem rprogcoord
1318 .bar add cascade -label [mc "File"] -menu .bar.file
1319 .bar configure -font uifont
1321 .bar.file add command -label [mc "Update"] -command updatecommits
1322 .bar.file add command -label [mc "Reload"] -command reloadcommits
1323 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1324 .bar.file add command -label [mc "List references"] -command showrefs
1325 .bar.file add command -label [mc "Quit"] -command doquit
1326 .bar.file configure -font uifont
1328 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1329 .bar.edit add command -label [mc "Preferences"] -command doprefs
1330 .bar.edit configure -font uifont
1332 menu .bar.view -font uifont
1333 .bar add cascade -label [mc "View"] -menu .bar.view
1334 .bar.view add command -label [mc "New view..."] -command {newview 0}
1335 .bar.view add command -label [mc "Edit view..."] -command editview \
1337 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1338 .bar.view add separator
1339 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1340 -variable selectedview -value 0
1343 .bar add cascade -label [mc "Help"] -menu .bar.help
1344 .bar.help add command -label [mc "About gitk"] -command about
1345 .bar.help add command -label [mc "Key bindings"] -command keys
1346 .bar.help configure -font uifont
1347 . configure -menu .bar
1349 # the gui has upper and lower half, parts of a paned window.
1350 panedwindow .ctop -orient vertical
1352 # possibly use assumed geometry
1353 if {![info exists geometry(pwsash0)]} {
1354 set geometry(topheight) [expr {15 * $linespc}]
1355 set geometry(topwidth) [expr {80 * $charspc}]
1356 set geometry(botheight) [expr {15 * $linespc}]
1357 set geometry(botwidth) [expr {50 * $charspc}]
1358 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1359 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1362 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1363 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1365 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1367 # create three canvases
1368 set cscroll .tf.histframe.csb
1369 set canv .tf.histframe.pwclist.canv
1371 -selectbackground $selectbgcolor \
1372 -background $bgcolor -bd 0 \
1373 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1374 .tf.histframe.pwclist add $canv
1375 set canv2 .tf.histframe.pwclist.canv2
1377 -selectbackground $selectbgcolor \
1378 -background $bgcolor -bd 0 -yscrollincr $linespc
1379 .tf.histframe.pwclist add $canv2
1380 set canv3 .tf.histframe.pwclist.canv3
1382 -selectbackground $selectbgcolor \
1383 -background $bgcolor -bd 0 -yscrollincr $linespc
1384 .tf.histframe.pwclist add $canv3
1385 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1386 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1388 # a scroll bar to rule them
1389 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1390 pack $cscroll -side right -fill y
1391 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1392 lappend bglist $canv $canv2 $canv3
1393 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1395 # we have two button bars at bottom of top frame. Bar 1
1397 frame .tf.lbar -height 15
1399 set sha1entry .tf.bar.sha1
1400 set entries $sha1entry
1401 set sha1but .tf.bar.sha1label
1402 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1403 -command gotocommit -width 8 -font uifont
1404 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1405 pack .tf.bar.sha1label -side left
1406 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1407 trace add variable sha1string write sha1change
1408 pack $sha1entry -side left -pady 2
1410 image create bitmap bm-left -data {
1411 #define left_width 16
1412 #define left_height 16
1413 static unsigned char left_bits[] = {
1414 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1415 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1416 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1418 image create bitmap bm-right -data {
1419 #define right_width 16
1420 #define right_height 16
1421 static unsigned char right_bits[] = {
1422 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1423 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1424 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1426 button .tf.bar.leftbut -image bm-left -command goback \
1427 -state disabled -width 26
1428 pack .tf.bar.leftbut -side left -fill y
1429 button .tf.bar.rightbut -image bm-right -command goforw \
1430 -state disabled -width 26
1431 pack .tf.bar.rightbut -side left -fill y
1433 # Status label and progress bar
1434 set statusw .tf.bar.status
1435 label $statusw -width 15 -relief sunken -font uifont
1436 pack $statusw -side left -padx 5
1437 set h [expr {[font metrics uifont -linespace] + 2}]
1438 set progresscanv .tf.bar.progress
1439 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1440 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1441 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1442 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1443 pack $progresscanv -side right -expand 1 -fill x
1444 set progresscoords {0 0}
1447 bind $progresscanv <Configure> adjustprogress
1448 set lastprogupdate [clock clicks -milliseconds]
1449 set progupdatepending 0
1451 # build up the bottom bar of upper window
1452 label .tf.lbar.flabel -text "[mc "Find"] " -font uifont
1453 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1} -font uifont
1454 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1} -font uifont
1455 label .tf.lbar.flab2 -text " [mc "commit"] " -font uifont
1456 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1458 set gdttype [mc "containing:"]
1459 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1460 [mc "containing:"] \
1461 [mc "touching paths:"] \
1462 [mc "adding/removing string:"]]
1463 trace add variable gdttype write gdttype_change
1464 $gm conf -font uifont
1465 .tf.lbar.gdttype conf -font uifont
1466 pack .tf.lbar.gdttype -side left -fill y
1469 set fstring .tf.lbar.findstring
1470 lappend entries $fstring
1471 entry $fstring -width 30 -font textfont -textvariable findstring
1472 trace add variable findstring write find_change
1473 set findtype [mc "Exact"]
1474 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1475 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1476 trace add variable findtype write findcom_change
1477 .tf.lbar.findtype configure -font uifont
1478 .tf.lbar.findtype.menu configure -font uifont
1479 set findloc [mc "All fields"]
1480 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1481 [mc "Comments"] [mc "Author"] [mc "Committer"]
1482 trace add variable findloc write find_change
1483 .tf.lbar.findloc configure -font uifont
1484 .tf.lbar.findloc.menu configure -font uifont
1485 pack .tf.lbar.findloc -side right
1486 pack .tf.lbar.findtype -side right
1487 pack $fstring -side left -expand 1 -fill x
1489 # Finish putting the upper half of the viewer together
1490 pack .tf.lbar -in .tf -side bottom -fill x
1491 pack .tf.bar -in .tf -side bottom -fill x
1492 pack .tf.histframe -fill both -side top -expand 1
1494 .ctop paneconfigure .tf -height $geometry(topheight)
1495 .ctop paneconfigure .tf -width $geometry(topwidth)
1497 # now build up the bottom
1498 panedwindow .pwbottom -orient horizontal
1500 # lower left, a text box over search bar, scroll bar to the right
1501 # if we know window height, then that will set the lower text height, otherwise
1502 # we set lower text height which will drive window height
1503 if {[info exists geometry(main)]} {
1504 frame .bleft -width $geometry(botwidth)
1506 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1511 button .bleft.top.search -text [mc "Search"] -command dosearch \
1513 pack .bleft.top.search -side left -padx 5
1514 set sstring .bleft.top.sstring
1515 entry $sstring -width 20 -font textfont -textvariable searchstring
1516 lappend entries $sstring
1517 trace add variable searchstring write incrsearch
1518 pack $sstring -side left -expand 1 -fill x
1519 radiobutton .bleft.mid.diff -text [mc "Diff"] -font uifont \
1520 -command changediffdisp -variable diffelide -value {0 0}
1521 radiobutton .bleft.mid.old -text [mc "Old version"] -font uifont \
1522 -command changediffdisp -variable diffelide -value {0 1}
1523 radiobutton .bleft.mid.new -text [mc "New version"] -font uifont \
1524 -command changediffdisp -variable diffelide -value {1 0}
1525 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: " \
1527 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1528 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1529 -from 1 -increment 1 -to 10000000 \
1530 -validate all -validatecommand "diffcontextvalidate %P" \
1531 -textvariable diffcontextstring
1532 .bleft.mid.diffcontext set $diffcontext
1533 trace add variable diffcontextstring write diffcontextchange
1534 lappend entries .bleft.mid.diffcontext
1535 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1536 set ctext .bleft.ctext
1537 text $ctext -background $bgcolor -foreground $fgcolor \
1538 -state disabled -font textfont \
1539 -yscrollcommand scrolltext -wrap none
1541 $ctext conf -tabstyle wordprocessor
1543 scrollbar .bleft.sb -command "$ctext yview"
1544 pack .bleft.top -side top -fill x
1545 pack .bleft.mid -side top -fill x
1546 pack .bleft.sb -side right -fill y
1547 pack $ctext -side left -fill both -expand 1
1548 lappend bglist $ctext
1549 lappend fglist $ctext
1551 $ctext tag conf comment -wrap $wrapcomment
1552 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1553 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1554 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1555 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1556 $ctext tag conf m0 -fore red
1557 $ctext tag conf m1 -fore blue
1558 $ctext tag conf m2 -fore green
1559 $ctext tag conf m3 -fore purple
1560 $ctext tag conf m4 -fore brown
1561 $ctext tag conf m5 -fore "#009090"
1562 $ctext tag conf m6 -fore magenta
1563 $ctext tag conf m7 -fore "#808000"
1564 $ctext tag conf m8 -fore "#009000"
1565 $ctext tag conf m9 -fore "#ff0080"
1566 $ctext tag conf m10 -fore cyan
1567 $ctext tag conf m11 -fore "#b07070"
1568 $ctext tag conf m12 -fore "#70b0f0"
1569 $ctext tag conf m13 -fore "#70f0b0"
1570 $ctext tag conf m14 -fore "#f0b070"
1571 $ctext tag conf m15 -fore "#ff70b0"
1572 $ctext tag conf mmax -fore darkgrey
1574 $ctext tag conf mresult -font textfontbold
1575 $ctext tag conf msep -font textfontbold
1576 $ctext tag conf found -back yellow
1578 .pwbottom add .bleft
1579 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1584 radiobutton .bright.mode.patch -text [mc "Patch"] \
1585 -command reselectline -variable cmitmode -value "patch"
1586 .bright.mode.patch configure -font uifont
1587 radiobutton .bright.mode.tree -text [mc "Tree"] \
1588 -command reselectline -variable cmitmode -value "tree"
1589 .bright.mode.tree configure -font uifont
1590 grid .bright.mode.patch .bright.mode.tree -sticky ew
1591 pack .bright.mode -side top -fill x
1592 set cflist .bright.cfiles
1593 set indent [font measure mainfont "nn"]
1595 -selectbackground $selectbgcolor \
1596 -background $bgcolor -foreground $fgcolor \
1598 -tabs [list $indent [expr {2 * $indent}]] \
1599 -yscrollcommand ".bright.sb set" \
1600 -cursor [. cget -cursor] \
1601 -spacing1 1 -spacing3 1
1602 lappend bglist $cflist
1603 lappend fglist $cflist
1604 scrollbar .bright.sb -command "$cflist yview"
1605 pack .bright.sb -side right -fill y
1606 pack $cflist -side left -fill both -expand 1
1607 $cflist tag configure highlight \
1608 -background [$cflist cget -selectbackground]
1609 $cflist tag configure bold -font mainfontbold
1611 .pwbottom add .bright
1614 # restore window position if known
1615 if {[info exists geometry(main)]} {
1616 wm geometry . "$geometry(main)"
1619 if {[tk windowingsystem] eq {aqua}} {
1625 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1626 pack .ctop -fill both -expand 1
1627 bindall <1> {selcanvline %W %x %y}
1628 #bindall <B1-Motion> {selcanvline %W %x %y}
1629 if {[tk windowingsystem] == "win32"} {
1630 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1631 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1633 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1634 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1635 if {[tk windowingsystem] eq "aqua"} {
1636 bindall <MouseWheel> {
1637 set delta [expr {- (%D)}]
1638 allcanvs yview scroll $delta units
1642 bindall <2> "canvscan mark %W %x %y"
1643 bindall <B2-Motion> "canvscan dragto %W %x %y"
1644 bindkey <Home> selfirstline
1645 bindkey <End> sellastline
1646 bind . <Key-Up> "selnextline -1"
1647 bind . <Key-Down> "selnextline 1"
1648 bind . <Shift-Key-Up> "dofind -1 0"
1649 bind . <Shift-Key-Down> "dofind 1 0"
1650 bindkey <Key-Right> "goforw"
1651 bindkey <Key-Left> "goback"
1652 bind . <Key-Prior> "selnextpage -1"
1653 bind . <Key-Next> "selnextpage 1"
1654 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1655 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1656 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1657 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1658 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1659 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1660 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1661 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1662 bindkey <Key-space> "$ctext yview scroll 1 pages"
1663 bindkey p "selnextline -1"
1664 bindkey n "selnextline 1"
1667 bindkey i "selnextline -1"
1668 bindkey k "selnextline 1"
1671 bindkey b "$ctext yview scroll -1 pages"
1672 bindkey d "$ctext yview scroll 18 units"
1673 bindkey u "$ctext yview scroll -18 units"
1674 bindkey / {dofind 1 1}
1675 bindkey <Key-Return> {dofind 1 1}
1676 bindkey ? {dofind -1 1}
1678 bindkey <F5> updatecommits
1679 bind . <$M1B-q> doquit
1680 bind . <$M1B-f> {dofind 1 1}
1681 bind . <$M1B-g> {dofind 1 0}
1682 bind . <$M1B-r> dosearchback
1683 bind . <$M1B-s> dosearch
1684 bind . <$M1B-equal> {incrfont 1}
1685 bind . <$M1B-KP_Add> {incrfont 1}
1686 bind . <$M1B-minus> {incrfont -1}
1687 bind . <$M1B-KP_Subtract> {incrfont -1}
1688 wm protocol . WM_DELETE_WINDOW doquit
1689 bind . <Button-1> "click %W"
1690 bind $fstring <Key-Return> {dofind 1 1}
1691 bind $sha1entry <Key-Return> gotocommit
1692 bind $sha1entry <<PasteSelection>> clearsha1
1693 bind $cflist <1> {sel_flist %W %x %y; break}
1694 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1695 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1696 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1698 set maincursor [. cget -cursor]
1699 set textcursor [$ctext cget -cursor]
1700 set curtextcursor $textcursor
1702 set rowctxmenu .rowctxmenu
1703 menu $rowctxmenu -tearoff 0
1704 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1705 -command {diffvssel 0}
1706 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1707 -command {diffvssel 1}
1708 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1709 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1710 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1711 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1712 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1714 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1717 set fakerowmenu .fakerowmenu
1718 menu $fakerowmenu -tearoff 0
1719 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1720 -command {diffvssel 0}
1721 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1722 -command {diffvssel 1}
1723 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1724 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1725 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1726 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1728 set headctxmenu .headctxmenu
1729 menu $headctxmenu -tearoff 0
1730 $headctxmenu add command -label [mc "Check out this branch"] \
1732 $headctxmenu add command -label [mc "Remove this branch"] \
1736 set flist_menu .flistctxmenu
1737 menu $flist_menu -tearoff 0
1738 $flist_menu add command -label [mc "Highlight this too"] \
1739 -command {flist_hl 0}
1740 $flist_menu add command -label [mc "Highlight this only"] \
1741 -command {flist_hl 1}
1744 # Windows sends all mouse wheel events to the current focused window, not
1745 # the one where the mouse hovers, so bind those events here and redirect
1746 # to the correct window
1747 proc windows_mousewheel_redirector {W X Y D} {
1748 global canv canv2 canv3
1749 set w [winfo containing -displayof $W $X $Y]
1751 set u [expr {$D < 0 ? 5 : -5}]
1752 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1753 allcanvs yview scroll $u units
1756 $w yview scroll $u units
1762 # mouse-2 makes all windows scan vertically, but only the one
1763 # the cursor is in scans horizontally
1764 proc canvscan {op w x y} {
1765 global canv canv2 canv3
1766 foreach c [list $canv $canv2 $canv3] {
1775 proc scrollcanv {cscroll f0 f1} {
1776 $cscroll set $f0 $f1
1781 # when we make a key binding for the toplevel, make sure
1782 # it doesn't get triggered when that key is pressed
in the
1783 # find string entry widget.
1784 proc bindkey
{ev
script} {
1787 set escript
[bind Entry
$ev]
1788 if {$escript == {}} {
1789 set escript
[bind Entry
<Key
>]
1791 foreach e
$entries {
1792 bind $e $ev "$escript; break"
1796 # set the focus back to the toplevel for any click outside
1799 global ctext entries
1800 foreach e
[concat
$entries $ctext] {
1801 if {$w == $e} return
1806 # Adjust the progress bar for a change in requested extent or canvas size
1807 proc adjustprogress
{} {
1808 global progresscanv progressitem progresscoords
1809 global fprogitem fprogcoord lastprogupdate progupdatepending
1810 global rprogitem rprogcoord
1812 set w
[expr {[winfo width
$progresscanv] - 4}]
1813 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1814 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1815 set h
[winfo height
$progresscanv]
1816 $progresscanv coords
$progressitem $x0 0 $x1 $h
1817 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1818 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1819 set now
[clock clicks
-milliseconds]
1820 if {$now >= $lastprogupdate + 100} {
1821 set progupdatepending
0
1823 } elseif
{!$progupdatepending} {
1824 set progupdatepending
1
1825 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1829 proc doprogupdate
{} {
1830 global lastprogupdate progupdatepending
1832 if {$progupdatepending} {
1833 set progupdatepending
0
1834 set lastprogupdate
[clock clicks
-milliseconds]
1839 proc savestuff
{w
} {
1840 global canv canv2 canv3 mainfont textfont uifont tabstop
1841 global stuffsaved findmergefiles maxgraphpct
1842 global maxwidth showneartags showlocalchanges
1843 global viewname viewfiles viewargs viewperm nextviewnum
1844 global cmitmode wrapcomment datetimeformat limitdiffs
1845 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1847 if {$stuffsaved} return
1848 if {![winfo viewable .
]} return
1850 set f
[open
"~/.gitk-new" w
]
1851 puts
$f [list
set mainfont
$mainfont]
1852 puts
$f [list
set textfont
$textfont]
1853 puts
$f [list
set uifont
$uifont]
1854 puts
$f [list
set tabstop
$tabstop]
1855 puts
$f [list
set findmergefiles
$findmergefiles]
1856 puts
$f [list
set maxgraphpct
$maxgraphpct]
1857 puts
$f [list
set maxwidth
$maxwidth]
1858 puts
$f [list
set cmitmode
$cmitmode]
1859 puts
$f [list
set wrapcomment
$wrapcomment]
1860 puts
$f [list
set showneartags
$showneartags]
1861 puts
$f [list
set showlocalchanges
$showlocalchanges]
1862 puts
$f [list
set datetimeformat
$datetimeformat]
1863 puts
$f [list
set limitdiffs
$limitdiffs]
1864 puts
$f [list
set bgcolor
$bgcolor]
1865 puts
$f [list
set fgcolor
$fgcolor]
1866 puts
$f [list
set colors
$colors]
1867 puts
$f [list
set diffcolors
$diffcolors]
1868 puts
$f [list
set diffcontext
$diffcontext]
1869 puts
$f [list
set selectbgcolor
$selectbgcolor]
1871 puts
$f "set geometry(main) [wm geometry .]"
1872 puts
$f "set geometry(topwidth) [winfo width .tf]"
1873 puts
$f "set geometry(topheight) [winfo height .tf]"
1874 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1875 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1876 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1877 puts
$f "set geometry(botheight) [winfo height .bleft]"
1879 puts
-nonewline $f "set permviews {"
1880 for {set v
0} {$v < $nextviewnum} {incr v
} {
1881 if {$viewperm($v)} {
1882 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1887 file rename
-force "~/.gitk-new" "~/.gitk"
1892 proc resizeclistpanes
{win w
} {
1894 if {[info exists oldwidth
($win)]} {
1895 set s0
[$win sash coord
0]
1896 set s1
[$win sash coord
1]
1898 set sash0
[expr {int
($w/2 - 2)}]
1899 set sash1
[expr {int
($w*5/6 - 2)}]
1901 set factor [expr {1.0 * $w / $oldwidth($win)}]
1902 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1903 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1907 if {$sash1 < $sash0 + 20} {
1908 set sash1
[expr {$sash0 + 20}]
1910 if {$sash1 > $w - 10} {
1911 set sash1
[expr {$w - 10}]
1912 if {$sash0 > $sash1 - 20} {
1913 set sash0
[expr {$sash1 - 20}]
1917 $win sash place
0 $sash0 [lindex
$s0 1]
1918 $win sash place
1 $sash1 [lindex
$s1 1]
1920 set oldwidth
($win) $w
1923 proc resizecdetpanes
{win w
} {
1925 if {[info exists oldwidth
($win)]} {
1926 set s0
[$win sash coord
0]
1928 set sash0
[expr {int
($w*3/4 - 2)}]
1930 set factor [expr {1.0 * $w / $oldwidth($win)}]
1931 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1935 if {$sash0 > $w - 15} {
1936 set sash0
[expr {$w - 15}]
1939 $win sash place
0 $sash0 [lindex
$s0 1]
1941 set oldwidth
($win) $w
1944 proc allcanvs args
{
1945 global canv canv2 canv3
1951 proc bindall
{event action
} {
1952 global canv canv2 canv3
1953 bind $canv $event $action
1954 bind $canv2 $event $action
1955 bind $canv3 $event $action
1961 if {[winfo exists
$w]} {
1966 wm title
$w [mc
"About gitk"]
1967 message
$w.m
-text [mc
"
1968 Gitk - a commit viewer for git
1970 Copyright © 2005-2006 Paul Mackerras
1972 Use and redistribute under the terms of the GNU General Public License"] \
1973 -justify center
-aspect 400 -border 2 -bg white
-relief groove
1974 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
1975 $w.m configure
-font uifont
1976 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1977 pack
$w.ok
-side bottom
1978 $w.ok configure
-font uifont
1979 bind $w <Visibility
> "focus $w.ok"
1980 bind $w <Key-Escape
> "destroy $w"
1981 bind $w <Key-Return
> "destroy $w"
1987 if {[winfo exists
$w]} {
1991 if {[tk windowingsystem
] eq
{aqua
}} {
1997 wm title
$w [mc
"Gitk key bindings"]
1998 message
$w.m
-text [mc
"
2002 <Home> Move to first commit
2003 <End> Move to last commit
2004 <Up>, p, i Move up one commit
2005 <Down>, n, k Move down one commit
2006 <Left>, z, j Go back in history list
2007 <Right>, x, l Go forward in history list
2008 <PageUp> Move up one page in commit list
2009 <PageDown> Move down one page in commit list
2010 <$M1T-Home> Scroll to top of commit list
2011 <$M1T-End> Scroll to bottom of commit list
2012 <$M1T-Up> Scroll commit list up one line
2013 <$M1T-Down> Scroll commit list down one line
2014 <$M1T-PageUp> Scroll commit list up one page
2015 <$M1T-PageDown> Scroll commit list down one page
2016 <Shift-Up> Find backwards (upwards, later commits)
2017 <Shift-Down> Find forwards (downwards, earlier commits)
2018 <Delete>, b Scroll diff view up one page
2019 <Backspace> Scroll diff view up one page
2020 <Space> Scroll diff view down one page
2021 u Scroll diff view up 18 lines
2022 d Scroll diff view down 18 lines
2024 <$M1T-G> Move to next find hit
2025 <Return> Move to next find hit
2026 / Move to next find hit, or redo find
2027 ? Move to previous find hit
2028 f Scroll diff view to next file
2029 <$M1T-S> Search for next hit in diff view
2030 <$M1T-R> Search for previous hit in diff view
2031 <$M1T-KP+> Increase font size
2032 <$M1T-plus> Increase font size
2033 <$M1T-KP-> Decrease font size
2034 <$M1T-minus> Decrease font size
2037 -justify left
-bg white
-border 2 -relief groove
2038 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
2039 $w.m configure
-font uifont
2040 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
2041 pack
$w.ok
-side bottom
2042 $w.ok configure
-font uifont
2043 bind $w <Visibility
> "focus $w.ok"
2044 bind $w <Key-Escape
> "destroy $w"
2045 bind $w <Key-Return
> "destroy $w"
2048 # Procedures for manipulating the file list window at the
2049 # bottom right of the overall window.
2051 proc treeview
{w l openlevs
} {
2052 global treecontents treediropen treeheight treeparent treeindex
2062 set treecontents
() {}
2063 $w conf
-state normal
2065 while {[string range
$f 0 $prefixend] ne
$prefix} {
2066 if {$lev <= $openlevs} {
2067 $w mark
set e
:$treeindex($prefix) "end -1c"
2068 $w mark gravity e
:$treeindex($prefix) left
2070 set treeheight
($prefix) $ht
2071 incr ht
[lindex
$htstack end
]
2072 set htstack
[lreplace
$htstack end end
]
2073 set prefixend
[lindex
$prefendstack end
]
2074 set prefendstack
[lreplace
$prefendstack end end
]
2075 set prefix
[string range
$prefix 0 $prefixend]
2078 set tail [string range
$f [expr {$prefixend+1}] end
]
2079 while {[set slash
[string first
"/" $tail]] >= 0} {
2082 lappend prefendstack
$prefixend
2083 incr prefixend
[expr {$slash + 1}]
2084 set d
[string range
$tail 0 $slash]
2085 lappend treecontents
($prefix) $d
2086 set oldprefix
$prefix
2088 set treecontents
($prefix) {}
2089 set treeindex
($prefix) [incr ix
]
2090 set treeparent
($prefix) $oldprefix
2091 set tail [string range
$tail [expr {$slash+1}] end
]
2092 if {$lev <= $openlevs} {
2094 set treediropen
($prefix) [expr {$lev < $openlevs}]
2095 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
2096 $w mark
set d
:$ix "end -1c"
2097 $w mark gravity d
:$ix left
2099 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2101 $w image create end
-align center
-image $bm -padx 1 \
2103 $w insert end
$d [highlight_tag
$prefix]
2104 $w mark
set s
:$ix "end -1c"
2105 $w mark gravity s
:$ix left
2110 if {$lev <= $openlevs} {
2113 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
2115 $w insert end
$tail [highlight_tag
$f]
2117 lappend treecontents
($prefix) $tail
2120 while {$htstack ne
{}} {
2121 set treeheight
($prefix) $ht
2122 incr ht
[lindex
$htstack end
]
2123 set htstack
[lreplace
$htstack end end
]
2124 set prefixend
[lindex
$prefendstack end
]
2125 set prefendstack
[lreplace
$prefendstack end end
]
2126 set prefix
[string range
$prefix 0 $prefixend]
2128 $w conf
-state disabled
2131 proc linetoelt
{l
} {
2132 global treeheight treecontents
2137 foreach e
$treecontents($prefix) {
2142 if {[string index
$e end
] eq
"/"} {
2143 set n
$treeheight($prefix$e)
2155 proc highlight_tree
{y prefix
} {
2156 global treeheight treecontents cflist
2158 foreach e
$treecontents($prefix) {
2160 if {[highlight_tag
$path] ne
{}} {
2161 $cflist tag add bold
$y.0 "$y.0 lineend"
2164 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
2165 set y
[highlight_tree
$y $path]
2171 proc treeclosedir
{w dir
} {
2172 global treediropen treeheight treeparent treeindex
2174 set ix
$treeindex($dir)
2175 $w conf
-state normal
2176 $w delete s
:$ix e
:$ix
2177 set treediropen
($dir) 0
2178 $w image configure a
:$ix -image tri-rt
2179 $w conf
-state disabled
2180 set n
[expr {1 - $treeheight($dir)}]
2181 while {$dir ne
{}} {
2182 incr treeheight
($dir) $n
2183 set dir
$treeparent($dir)
2187 proc treeopendir
{w dir
} {
2188 global treediropen treeheight treeparent treecontents treeindex
2190 set ix
$treeindex($dir)
2191 $w conf
-state normal
2192 $w image configure a
:$ix -image tri-dn
2193 $w mark
set e
:$ix s
:$ix
2194 $w mark gravity e
:$ix right
2197 set n
[llength
$treecontents($dir)]
2198 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
2201 incr treeheight
($x) $n
2203 foreach e
$treecontents($dir) {
2205 if {[string index
$e end
] eq
"/"} {
2206 set iy
$treeindex($de)
2207 $w mark
set d
:$iy e
:$ix
2208 $w mark gravity d
:$iy left
2209 $w insert e
:$ix $str
2210 set treediropen
($de) 0
2211 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
2213 $w insert e
:$ix $e [highlight_tag
$de]
2214 $w mark
set s
:$iy e
:$ix
2215 $w mark gravity s
:$iy left
2216 set treeheight
($de) 1
2218 $w insert e
:$ix $str
2219 $w insert e
:$ix $e [highlight_tag
$de]
2222 $w mark gravity e
:$ix left
2223 $w conf
-state disabled
2224 set treediropen
($dir) 1
2225 set top
[lindex
[split [$w index @
0,0] .
] 0]
2226 set ht
[$w cget
-height]
2227 set l
[lindex
[split [$w index s
:$ix] .
] 0]
2230 } elseif
{$l + $n + 1 > $top + $ht} {
2231 set top
[expr {$l + $n + 2 - $ht}]
2239 proc treeclick
{w x y
} {
2240 global treediropen cmitmode ctext cflist cflist_top
2242 if {$cmitmode ne
"tree"} return
2243 if {![info exists cflist_top
]} return
2244 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2245 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2246 $cflist tag add highlight
$l.0 "$l.0 lineend"
2252 set e
[linetoelt
$l]
2253 if {[string index
$e end
] ne
"/"} {
2255 } elseif
{$treediropen($e)} {
2262 proc setfilelist
{id
} {
2263 global treefilelist cflist
2265 treeview
$cflist $treefilelist($id) 0
2268 image create bitmap tri-rt
-background black
-foreground blue
-data {
2269 #define tri-rt_width 13
2270 #define tri-rt_height 13
2271 static unsigned char tri-rt_bits
[] = {
2272 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2273 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2276 #define tri-rt-mask_width 13
2277 #define tri-rt-mask_height 13
2278 static unsigned char tri-rt-mask_bits
[] = {
2279 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2280 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2283 image create bitmap tri-dn
-background black
-foreground blue
-data {
2284 #define tri-dn_width 13
2285 #define tri-dn_height 13
2286 static unsigned char tri-dn_bits
[] = {
2287 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2288 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2291 #define tri-dn-mask_width 13
2292 #define tri-dn-mask_height 13
2293 static unsigned char tri-dn-mask_bits
[] = {
2294 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2295 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2299 image create bitmap reficon-T
-background black
-foreground yellow
-data {
2300 #define tagicon_width 13
2301 #define tagicon_height 9
2302 static unsigned char tagicon_bits
[] = {
2303 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2304 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2306 #define tagicon-mask_width 13
2307 #define tagicon-mask_height 9
2308 static unsigned char tagicon-mask_bits
[] = {
2309 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2310 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2313 #define headicon_width 13
2314 #define headicon_height 9
2315 static unsigned char headicon_bits
[] = {
2316 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2317 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2320 #define headicon-mask_width 13
2321 #define headicon-mask_height 9
2322 static unsigned char headicon-mask_bits
[] = {
2323 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2324 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2326 image create bitmap reficon-H
-background black
-foreground green \
2327 -data $rectdata -maskdata $rectmask
2328 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
2329 -data $rectdata -maskdata $rectmask
2331 proc init_flist
{first
} {
2332 global cflist cflist_top difffilestart
2334 $cflist conf
-state normal
2335 $cflist delete
0.0 end
2337 $cflist insert end
$first
2339 $cflist tag add highlight
1.0 "1.0 lineend"
2341 catch
{unset cflist_top
}
2343 $cflist conf
-state disabled
2344 set difffilestart
{}
2347 proc highlight_tag
{f
} {
2348 global highlight_paths
2350 foreach p
$highlight_paths {
2351 if {[string match
$p $f]} {
2358 proc highlight_filelist
{} {
2359 global cmitmode cflist
2361 $cflist conf
-state normal
2362 if {$cmitmode ne
"tree"} {
2363 set end
[lindex
[split [$cflist index end
] .
] 0]
2364 for {set l
2} {$l < $end} {incr l
} {
2365 set line
[$cflist get
$l.0 "$l.0 lineend"]
2366 if {[highlight_tag
$line] ne
{}} {
2367 $cflist tag add bold
$l.0 "$l.0 lineend"
2373 $cflist conf
-state disabled
2376 proc unhighlight_filelist
{} {
2379 $cflist conf
-state normal
2380 $cflist tag remove bold
1.0 end
2381 $cflist conf
-state disabled
2384 proc add_flist
{fl
} {
2387 $cflist conf
-state normal
2389 $cflist insert end
"\n"
2390 $cflist insert end
$f [highlight_tag
$f]
2392 $cflist conf
-state disabled
2395 proc sel_flist
{w x y
} {
2396 global ctext difffilestart cflist cflist_top cmitmode
2398 if {$cmitmode eq
"tree"} return
2399 if {![info exists cflist_top
]} return
2400 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2401 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
2402 $cflist tag add highlight
$l.0 "$l.0 lineend"
2407 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
2411 proc pop_flist_menu
{w X Y x y
} {
2412 global ctext cflist cmitmode flist_menu flist_menu_file
2413 global treediffs diffids
2416 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
2418 if {$cmitmode eq
"tree"} {
2419 set e
[linetoelt
$l]
2420 if {[string index
$e end
] eq
"/"} return
2422 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
2424 set flist_menu_file
$e
2425 tk_popup
$flist_menu $X $Y
2428 proc flist_hl
{only
} {
2429 global flist_menu_file findstring gdttype
2431 set x
[shellquote
$flist_menu_file]
2432 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
2435 append findstring
" " $x
2437 set gdttype
[mc
"touching paths:"]
2440 # Functions for adding and removing shell-type quoting
2442 proc shellquote
{str
} {
2443 if {![string match
"*\['\"\\ \t]*" $str]} {
2446 if {![string match
"*\['\"\\]*" $str]} {
2449 if {![string match
"*'*" $str]} {
2452 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2455 proc shellarglist
{l
} {
2461 append str
[shellquote
$a]
2466 proc shelldequote
{str
} {
2471 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
2472 append ret
[string range
$str $used end
]
2473 set used
[string length
$str]
2476 set first
[lindex
$first 0]
2477 set ch
[string index
$str $first]
2478 if {$first > $used} {
2479 append ret
[string range
$str $used [expr {$first - 1}]]
2482 if {$ch eq
" " ||
$ch eq
"\t"} break
2485 set first
[string first
"'" $str $used]
2487 error
"unmatched single-quote"
2489 append ret
[string range
$str $used [expr {$first - 1}]]
2494 if {$used >= [string length
$str]} {
2495 error
"trailing backslash"
2497 append ret
[string index
$str $used]
2502 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
2503 error
"unmatched double-quote"
2505 set first
[lindex
$first 0]
2506 set ch
[string index
$str $first]
2507 if {$first > $used} {
2508 append ret
[string range
$str $used [expr {$first - 1}]]
2511 if {$ch eq
"\""} break
2513 append ret
[string index
$str $used]
2517 return [list
$used $ret]
2520 proc shellsplit
{str
} {
2523 set str
[string trimleft
$str]
2524 if {$str eq
{}} break
2525 set dq
[shelldequote
$str]
2526 set n
[lindex
$dq 0]
2527 set word
[lindex
$dq 1]
2528 set str
[string range
$str $n end
]
2534 # Code to implement multiple views
2536 proc newview
{ishighlight
} {
2537 global nextviewnum newviewname newviewperm uifont newishighlight
2538 global newviewargs revtreeargs
2540 set newishighlight
$ishighlight
2542 if {[winfo exists
$top]} {
2546 set newviewname
($nextviewnum) "View $nextviewnum"
2547 set newviewperm
($nextviewnum) 0
2548 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
2549 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
2554 global viewname viewperm newviewname newviewperm
2555 global viewargs newviewargs
2557 set top .gitkvedit-
$curview
2558 if {[winfo exists
$top]} {
2562 set newviewname
($curview) $viewname($curview)
2563 set newviewperm
($curview) $viewperm($curview)
2564 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
2565 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
2568 proc vieweditor
{top n title
} {
2569 global newviewname newviewperm viewfiles
2573 wm title
$top $title
2574 label
$top.
nl -text [mc
"Name"] -font uifont
2575 entry
$top.name
-width 20 -textvariable newviewname
($n) -font uifont
2576 grid
$top.
nl $top.name
-sticky w
-pady 5
2577 checkbutton
$top.perm
-text [mc
"Remember this view"] -variable newviewperm
($n) \
2579 grid
$top.perm
- -pady 5 -sticky w
2580 message
$top.al
-aspect 1000 -font uifont \
2581 -text [mc
"Commits to include (arguments to git rev-list):"]
2582 grid
$top.al
- -sticky w
-pady 5
2583 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
2584 -background white
-font uifont
2585 grid
$top.args
- -sticky ew
-padx 5
2586 message
$top.l
-aspect 1000 -font uifont \
2587 -text [mc
"Enter files and directories to include, one per line:"]
2588 grid
$top.l
- -sticky w
2589 text
$top.t
-width 40 -height 10 -background white
-font uifont
2590 if {[info exists viewfiles
($n)]} {
2591 foreach f
$viewfiles($n) {
2592 $top.t insert end
$f
2593 $top.t insert end
"\n"
2595 $top.t delete
{end
- 1c
} end
2596 $top.t mark
set insert
0.0
2598 grid
$top.t
- -sticky ew
-padx 5
2600 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n] \
2602 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top] \
2604 grid
$top.buts.ok
$top.buts.can
2605 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
2606 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
2607 grid
$top.buts
- -pady 10 -sticky ew
2611 proc doviewmenu
{m first cmd op argv
} {
2612 set nmenu
[$m index end
]
2613 for {set i
$first} {$i <= $nmenu} {incr i
} {
2614 if {[$m entrycget
$i -command] eq
$cmd} {
2615 eval $m $op $i $argv
2621 proc allviewmenus
{n op args
} {
2624 doviewmenu .bar.view
5 [list showview
$n] $op $args
2625 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2628 proc newviewok
{top n
} {
2629 global nextviewnum newviewperm newviewname newishighlight
2630 global viewname viewfiles viewperm selectedview curview
2631 global viewargs newviewargs viewhlmenu
2634 set newargs
[shellsplit
$newviewargs($n)]
2636 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
2642 foreach f
[split [$top.t get
0.0 end
] "\n"] {
2643 set ft
[string trim
$f]
2648 if {![info exists viewfiles
($n)]} {
2649 # creating a new view
2651 set viewname
($n) $newviewname($n)
2652 set viewperm
($n) $newviewperm($n)
2653 set viewfiles
($n) $files
2654 set viewargs
($n) $newargs
2656 if {!$newishighlight} {
2659 run addvhighlight
$n
2662 # editing an existing view
2663 set viewperm
($n) $newviewperm($n)
2664 if {$newviewname($n) ne
$viewname($n)} {
2665 set viewname
($n) $newviewname($n)
2666 doviewmenu .bar.view
5 [list showview
$n] \
2667 entryconf
[list
-label $viewname($n)]
2668 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2669 # entryconf [list -label $viewname($n) -value $viewname($n)]
2671 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n)} {
2672 set viewfiles
($n) $files
2673 set viewargs
($n) $newargs
2674 if {$curview == $n} {
2679 catch
{destroy
$top}
2683 global curview viewperm hlview selectedhlview
2685 if {$curview == 0} return
2686 if {[info exists hlview
] && $hlview == $curview} {
2687 set selectedhlview
[mc
"None"]
2690 allviewmenus
$curview delete
2691 set viewperm
($curview) 0
2695 proc addviewmenu
{n
} {
2696 global viewname viewhlmenu
2698 .bar.view add radiobutton
-label $viewname($n) \
2699 -command [list showview
$n] -variable selectedview
-value $n
2700 #$viewhlmenu add radiobutton -label $viewname($n) \
2701 # -command [list addvhighlight $n] -variable selectedhlview
2705 global curview viewfiles cached_commitrow ordertok
2706 global displayorder parentlist rowidlist rowisopt rowfinal
2707 global colormap rowtextx nextcolor canvxmax
2708 global numcommits viewcomplete
2709 global selectedline currentid canv canvy0
2711 global pending_select
2713 global selectedview selectfirst
2714 global hlview selectedhlview commitinterest
2716 if {$n == $curview} return
2718 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2719 set span
[$canv yview
]
2720 set ytop
[expr {[lindex
$span 0] * $ymax}]
2721 set ybot
[expr {[lindex
$span 1] * $ymax}]
2722 set yscreen
[expr {($ybot - $ytop) / 2}]
2723 if {[info exists selectedline
]} {
2724 set selid
$currentid
2725 set y
[yc
$selectedline]
2726 if {$ytop < $y && $y < $ybot} {
2727 set yscreen
[expr {$y - $ytop}]
2729 } elseif
{[info exists pending_select
]} {
2730 set selid
$pending_select
2731 unset pending_select
2735 catch
{unset treediffs
}
2737 if {[info exists hlview
] && $hlview == $n} {
2739 set selectedhlview
[mc
"None"]
2741 catch
{unset commitinterest
}
2742 catch
{unset cached_commitrow
}
2743 catch
{unset ordertok
}
2747 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2748 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2751 if {![info exists viewcomplete
($n)]} {
2753 set pending_select
$selid
2764 set numcommits
$commitidx($n)
2766 catch
{unset colormap
}
2767 catch
{unset rowtextx
}
2769 set canvxmax
[$canv cget
-width]
2776 if {$selid ne
{} && [commitinview
$selid $n]} {
2777 set row
[rowofcommit
$selid]
2778 # try to get the selected row in the same position on the screen
2779 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2780 set ytop
[expr {[yc
$row] - $yscreen}]
2784 set yf
[expr {$ytop * 1.0 / $ymax}]
2786 allcanvs yview moveto
$yf
2790 } elseif
{$selid ne
{}} {
2791 set pending_select
$selid
2793 set row
[first_real_row
]
2794 if {$row < $numcommits} {
2800 if {!$viewcomplete($n)} {
2801 if {$numcommits == 0} {
2802 show_status
[mc
"Reading commits..."]
2804 } elseif
{$numcommits == 0} {
2805 show_status
[mc
"No commits selected"]
2809 # Stuff relating to the highlighting facility
2811 proc ishighlighted
{row
} {
2812 global vhighlights fhighlights nhighlights rhighlights
2814 if {[info exists nhighlights
($row)] && $nhighlights($row) > 0} {
2815 return $nhighlights($row)
2817 if {[info exists vhighlights
($row)] && $vhighlights($row) > 0} {
2818 return $vhighlights($row)
2820 if {[info exists fhighlights
($row)] && $fhighlights($row) > 0} {
2821 return $fhighlights($row)
2823 if {[info exists rhighlights
($row)] && $rhighlights($row) > 0} {
2824 return $rhighlights($row)
2829 proc bolden
{row font
} {
2830 global canv linehtag selectedline boldrows
2832 lappend boldrows
$row
2833 $canv itemconf
$linehtag($row) -font $font
2834 if {[info exists selectedline
] && $row == $selectedline} {
2836 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2837 -outline {{}} -tags secsel \
2838 -fill [$canv cget
-selectbackground]]
2843 proc bolden_name
{row font
} {
2844 global canv2 linentag selectedline boldnamerows
2846 lappend boldnamerows
$row
2847 $canv2 itemconf
$linentag($row) -font $font
2848 if {[info exists selectedline
] && $row == $selectedline} {
2849 $canv2 delete secsel
2850 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2851 -outline {{}} -tags secsel \
2852 -fill [$canv2 cget
-selectbackground]]
2861 foreach row
$boldrows {
2862 if {![ishighlighted
$row]} {
2863 bolden
$row mainfont
2865 lappend stillbold
$row
2868 set boldrows
$stillbold
2871 proc addvhighlight
{n
} {
2872 global hlview viewcomplete curview vhl_done vhighlights commitidx
2874 if {[info exists hlview
]} {
2878 if {$n != $curview && ![info exists viewcomplete
($n)]} {
2881 set vhl_done
$commitidx($hlview)
2882 if {$vhl_done > 0} {
2887 proc delvhighlight
{} {
2888 global hlview vhighlights
2890 if {![info exists hlview
]} return
2892 catch
{unset vhighlights
}
2896 proc vhighlightmore
{} {
2897 global hlview vhl_done commitidx vhighlights curview
2899 set max
$commitidx($hlview)
2900 set vr
[visiblerows
]
2901 set r0
[lindex
$vr 0]
2902 set r1
[lindex
$vr 1]
2903 for {set i
$vhl_done} {$i < $max} {incr i
} {
2904 set id
[commitonrow
$i $hlview]
2905 if {[commitinview
$id $curview]} {
2906 set row
[rowofcommit
$id]
2907 if {$r0 <= $row && $row <= $r1} {
2908 if {![highlighted
$row]} {
2909 bolden
$row mainfontbold
2911 set vhighlights
($row) 1
2918 proc askvhighlight
{row id
} {
2919 global hlview vhighlights iddrawn
2921 if {[commitinview
$id $hlview]} {
2922 if {[info exists iddrawn
($id)] && ![ishighlighted
$row]} {
2923 bolden
$row mainfontbold
2925 set vhighlights
($row) 1
2927 set vhighlights
($row) 0
2931 proc hfiles_change
{} {
2932 global highlight_files filehighlight fhighlights fh_serial
2933 global highlight_paths gdttype
2935 if {[info exists filehighlight
]} {
2936 # delete previous highlights
2937 catch
{close
$filehighlight}
2939 catch
{unset fhighlights
}
2941 unhighlight_filelist
2943 set highlight_paths
{}
2944 after cancel do_file_hl
$fh_serial
2946 if {$highlight_files ne
{}} {
2947 after
300 do_file_hl
$fh_serial
2951 proc gdttype_change
{name ix op
} {
2952 global gdttype highlight_files findstring findpattern
2955 if {$findstring ne
{}} {
2956 if {$gdttype eq
[mc
"containing:"]} {
2957 if {$highlight_files ne
{}} {
2958 set highlight_files
{}
2963 if {$findpattern ne
{}} {
2967 set highlight_files
$findstring
2972 # enable/disable findtype/findloc menus too
2975 proc find_change
{name ix op
} {
2976 global gdttype findstring highlight_files
2979 if {$gdttype eq
[mc
"containing:"]} {
2982 if {$highlight_files ne
$findstring} {
2983 set highlight_files
$findstring
2990 proc findcom_change args
{
2991 global nhighlights boldnamerows
2992 global findpattern findtype findstring gdttype
2995 # delete previous highlights, if any
2996 foreach row
$boldnamerows {
2997 bolden_name
$row mainfont
3000 catch
{unset nhighlights
}
3003 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
3005 } elseif
{$findtype eq
[mc
"Regexp"]} {
3006 set findpattern
$findstring
3008 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3010 set findpattern
"*$e*"
3014 proc makepatterns
{l
} {
3017 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3018 if {[string index
$ee end
] eq
"/"} {
3028 proc do_file_hl
{serial
} {
3029 global highlight_files filehighlight highlight_paths gdttype fhl_list
3031 if {$gdttype eq
[mc
"touching paths:"]} {
3032 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
3033 set highlight_paths
[makepatterns
$paths]
3035 set gdtargs
[concat
-- $paths]
3036 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
3037 set gdtargs
[list
"-S$highlight_files"]
3039 # must be "containing:", i.e. we're searching commit info
3042 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
3043 set filehighlight
[open
$cmd r
+]
3044 fconfigure
$filehighlight -blocking 0
3045 filerun
$filehighlight readfhighlight
3051 proc flushhighlights
{} {
3052 global filehighlight fhl_list
3054 if {[info exists filehighlight
]} {
3056 puts
$filehighlight ""
3057 flush
$filehighlight
3061 proc askfilehighlight
{row id
} {
3062 global filehighlight fhighlights fhl_list
3064 lappend fhl_list
$id
3065 set fhighlights
($row) -1
3066 puts
$filehighlight $id
3069 proc readfhighlight
{} {
3070 global filehighlight fhighlights curview iddrawn
3071 global fhl_list find_dirn
3073 if {![info exists filehighlight
]} {
3077 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
3078 set line
[string trim
$line]
3079 set i
[lsearch
-exact $fhl_list $line]
3080 if {$i < 0} continue
3081 for {set j
0} {$j < $i} {incr j
} {
3082 set id
[lindex
$fhl_list $j]
3083 if {[commitinview
$id $curview]} {
3084 set fhighlights
([rowofcommit
$id]) 0
3087 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
3088 if {$line eq
{}} continue
3089 if {![commitinview
$line $curview]} continue
3090 set row
[rowofcommit
$line]
3091 if {[info exists iddrawn
($line)] && ![ishighlighted
$row]} {
3092 bolden
$row mainfontbold
3094 set fhighlights
($row) 1
3096 if {[eof
$filehighlight]} {
3098 puts
"oops, git diff-tree died"
3099 catch
{close
$filehighlight}
3103 if {[info exists find_dirn
]} {
3109 proc doesmatch
{f
} {
3110 global findtype findpattern
3112 if {$findtype eq
[mc
"Regexp"]} {
3113 return [regexp
$findpattern $f]
3114 } elseif
{$findtype eq
[mc
"IgnCase"]} {
3115 return [string match
-nocase $findpattern $f]
3117 return [string match
$findpattern $f]
3121 proc askfindhighlight
{row id
} {
3122 global nhighlights commitinfo iddrawn
3124 global markingmatches
3126 if {![info exists commitinfo
($id)]} {
3129 set info
$commitinfo($id)
3131 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
3132 foreach f
$info ty
$fldtypes {
3133 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
3135 if {$ty eq
[mc
"Author"]} {
3142 if {$isbold && [info exists iddrawn
($id)]} {
3143 if {![ishighlighted
$row]} {
3144 bolden
$row mainfontbold
3146 bolden_name
$row mainfontbold
3149 if {$markingmatches} {
3150 markrowmatches
$row $id
3153 set nhighlights
($row) $isbold
3156 proc markrowmatches
{row id
} {
3157 global canv canv2 linehtag linentag commitinfo findloc
3159 set headline
[lindex
$commitinfo($id) 0]
3160 set author
[lindex
$commitinfo($id) 1]
3161 $canv delete match
$row
3162 $canv2 delete match
$row
3163 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
3164 set m
[findmatches
$headline]
3166 markmatches
$canv $row $headline $linehtag($row) $m \
3167 [$canv itemcget
$linehtag($row) -font] $row
3170 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
3171 set m
[findmatches
$author]
3173 markmatches
$canv2 $row $author $linentag($row) $m \
3174 [$canv2 itemcget
$linentag($row) -font] $row
3179 proc vrel_change
{name ix op
} {
3180 global highlight_related
3183 if {$highlight_related ne
[mc
"None"]} {
3188 # prepare for testing whether commits are descendents or ancestors of a
3189 proc rhighlight_sel
{a
} {
3190 global descendent desc_todo ancestor anc_todo
3191 global highlight_related rhighlights
3193 catch
{unset descendent
}
3194 set desc_todo
[list
$a]
3195 catch
{unset ancestor
}
3196 set anc_todo
[list
$a]
3197 if {$highlight_related ne
[mc
"None"]} {
3203 proc rhighlight_none
{} {
3206 catch
{unset rhighlights
}
3210 proc is_descendent
{a
} {
3211 global curview children descendent desc_todo
3214 set la
[rowofcommit
$a]
3218 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3219 set do [lindex
$todo $i]
3220 if {[rowofcommit
$do] < $la} {
3221 lappend leftover
$do
3224 foreach nk
$children($v,$do) {
3225 if {![info exists descendent
($nk)]} {
3226 set descendent
($nk) 1
3234 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3238 set descendent
($a) 0
3239 set desc_todo
$leftover
3242 proc is_ancestor
{a
} {
3243 global curview parents ancestor anc_todo
3246 set la
[rowofcommit
$a]
3250 for {set i
0} {$i < [llength
$todo]} {incr i
} {
3251 set do [lindex
$todo $i]
3252 if {![commitinview
$do $v] ||
[rowofcommit
$do] > $la} {
3253 lappend leftover
$do
3256 foreach np
$parents($v,$do) {
3257 if {![info exists ancestor
($np)]} {
3266 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
3271 set anc_todo
$leftover
3274 proc askrelhighlight
{row id
} {
3275 global descendent highlight_related iddrawn rhighlights
3276 global selectedline ancestor
3278 if {![info exists selectedline
]} return
3280 if {$highlight_related eq
[mc
"Descendent"] ||
3281 $highlight_related eq
[mc
"Not descendent"]} {
3282 if {![info exists descendent
($id)]} {
3285 if {$descendent($id) == ($highlight_related eq
[mc
"Descendent"])} {
3288 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
3289 $highlight_related eq
[mc
"Not ancestor"]} {
3290 if {![info exists ancestor
($id)]} {
3293 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
3297 if {[info exists iddrawn
($id)]} {
3298 if {$isbold && ![ishighlighted
$row]} {
3299 bolden
$row mainfontbold
3302 set rhighlights
($row) $isbold
3305 # Graph layout functions
3307 proc shortids
{ids
} {
3310 if {[llength
$id] > 1} {
3311 lappend res
[shortids
$id]
3312 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
3313 lappend res
[string range
$id 0 7]
3324 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
3325 if {($n & $mask) != 0} {
3326 set ret
[concat
$ret $o]
3328 set o
[concat
$o $o]
3333 proc ordertoken
{id
} {
3334 global ordertok curview varcid varcstart varctok curview parents children
3335 global nullid nullid2
3337 if {[info exists ordertok
($id)]} {
3338 return $ordertok($id)
3343 if {[info exists varcid
($curview,$id)]} {
3344 set a
$varcid($curview,$id)
3345 set p
[lindex
$varcstart($curview) $a]
3347 set p
[lindex
$children($curview,$id) 0]
3349 if {[info exists ordertok
($p)]} {
3350 set tok
$ordertok($p)
3353 if {[llength
$children($curview,$p)] == 0} {
3355 set tok
[lindex
$varctok($curview) $a]
3358 set id
[lindex
$children($curview,$p) 0]
3359 if {$id eq
$nullid ||
$id eq
$nullid2} {
3360 # XXX treat it as a root
3361 set tok
[lindex
$varctok($curview) $a]
3364 if {[llength
$parents($curview,$id)] == 1} {
3365 lappend todo
[list
$p {}]
3367 set j
[lsearch
-exact $parents($curview,$id) $p]
3369 puts
"oops didn't find [shortids $p] in parents of [shortids $id]"
3371 lappend todo
[list
$p [strrep
$j]]
3374 for {set i
[llength
$todo]} {[incr i
-1] >= 0} {} {
3375 set p
[lindex
$todo $i 0]
3376 append tok
[lindex
$todo $i 1]
3377 set ordertok
($p) $tok
3379 set ordertok
($origid) $tok
3383 # Work out where id should go in idlist so that order-token
3384 # values increase from left to right
3385 proc idcol
{idlist id
{i
0}} {
3386 set t
[ordertoken
$id]
3390 if {$i >= [llength
$idlist] ||
$t < [ordertoken
[lindex
$idlist $i]]} {
3391 if {$i > [llength
$idlist]} {
3392 set i
[llength
$idlist]
3394 while {[incr i
-1] >= 0 && $t < [ordertoken
[lindex
$idlist $i]]} {}
3397 if {$t > [ordertoken
[lindex
$idlist $i]]} {
3398 while {[incr i
] < [llength
$idlist] &&
3399 $t >= [ordertoken
[lindex
$idlist $i]]} {}
3405 proc initlayout
{} {
3406 global rowidlist rowisopt rowfinal displayorder parentlist
3407 global numcommits canvxmax canv
3409 global colormap rowtextx
3419 set canvxmax
[$canv cget
-width]
3420 catch
{unset colormap
}
3421 catch
{unset rowtextx
}
3425 proc setcanvscroll
{} {
3426 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3428 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3429 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
3430 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
3431 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
3434 proc visiblerows
{} {
3435 global canv numcommits linespc
3437 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3438 if {$ymax eq
{} ||
$ymax == 0} return
3440 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
3441 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
3445 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
3446 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
3447 if {$r1 >= $numcommits} {
3448 set r1
[expr {$numcommits - 1}]
3450 return [list
$r0 $r1]
3453 proc layoutmore
{} {
3454 global commitidx viewcomplete curview
3455 global numcommits pending_select selectedline curview
3456 global selectfirst lastscrollset commitinterest
3458 set canshow
$commitidx($curview)
3459 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3460 if {$numcommits == 0} {
3464 set prev
$numcommits
3465 set numcommits
$canshow
3466 set t
[clock clicks
-milliseconds]
3467 if {$prev < 100 ||
$viewcomplete($curview) ||
$t - $lastscrollset > 500} {
3468 set lastscrollset
$t
3471 set rows
[visiblerows
]
3472 set r1
[lindex
$rows 1]
3473 if {$r1 >= $canshow} {
3474 set r1
[expr {$canshow - 1}]
3479 if {[info exists pending_select
] &&
3480 [commitinview
$pending_select $curview]} {
3481 selectline
[rowofcommit
$pending_select] 1
3484 if {[info exists selectedline
] ||
[info exists pending_select
]} {
3487 set l
[first_real_row
]
3494 proc doshowlocalchanges
{} {
3495 global curview mainheadid
3497 if {[commitinview
$mainheadid $curview]} {
3500 lappend commitinterest
($mainheadid) {dodiffindex
}
3504 proc dohidelocalchanges
{} {
3505 global nullid nullid2 lserial curview
3507 if {[commitinview
$nullid $curview]} {
3508 removerow
$nullid $curview
3510 if {[commitinview
$nullid2 $curview]} {
3511 removerow
$nullid2 $curview
3516 # spawn off a process to do git diff-index --cached HEAD
3517 proc dodiffindex
{} {
3518 global lserial showlocalchanges
3520 if {!$showlocalchanges} return
3522 set fd
[open
"|git diff-index --cached HEAD" r
]
3523 fconfigure
$fd -blocking 0
3524 filerun
$fd [list readdiffindex
$fd $lserial]
3527 proc readdiffindex
{fd serial
} {
3528 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3531 if {[gets
$fd line
] < 0} {
3537 # we only need to see one line and we don't really care what it says...
3540 if {$serial != $lserial} {
3544 # now see if there are any local changes not checked in to the index
3545 set fd
[open
"|git diff-files" r
]
3546 fconfigure
$fd -blocking 0
3547 filerun
$fd [list readdifffiles
$fd $serial]
3549 if {$isdiff && ![commitinview
$nullid2 $curview]} {
3550 # add the line for the changes in the index to the graph
3551 set hl
[mc
"Local changes checked in to index but not committed"]
3552 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
3553 set commitdata
($nullid2) "\n $hl\n"
3554 if {[commitinview
$nullid $curview]} {
3555 removerow
$nullid $curview
3557 insertrow
$nullid2 $mainheadid $curview
3558 } elseif
{!$isdiff && [commitinview
$nullid2 $curview]} {
3559 removerow
$nullid2 $curview
3564 proc readdifffiles
{fd serial
} {
3565 global mainheadid nullid nullid2 curview
3566 global commitinfo commitdata lserial
3569 if {[gets
$fd line
] < 0} {
3575 # we only need to see one line and we don't really care what it says...
3578 if {$serial != $lserial} {
3582 if {$isdiff && ![commitinview
$nullid $curview]} {
3583 # add the line for the local diff to the graph
3584 set hl
[mc
"Local uncommitted changes, not checked in to index"]
3585 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
3586 set commitdata
($nullid) "\n $hl\n"
3587 if {[commitinview
$nullid2 $curview]} {
3592 insertrow
$nullid $p $curview
3593 } elseif
{!$isdiff && [commitinview
$nullid $curview]} {
3594 removerow
$nullid $curview
3599 proc nextuse
{id row
} {
3600 global curview children
3602 if {[info exists children
($curview,$id)]} {
3603 foreach kid
$children($curview,$id) {
3604 if {![commitinview
$kid $curview]} {
3607 if {[rowofcommit
$kid] > $row} {
3608 return [rowofcommit
$kid]
3612 if {[commitinview
$id $curview]} {
3613 return [rowofcommit
$id]
3618 proc prevuse
{id row
} {
3619 global curview children
3622 if {[info exists children
($curview,$id)]} {
3623 foreach kid
$children($curview,$id) {
3624 if {![commitinview
$kid $curview]} break
3625 if {[rowofcommit
$kid] < $row} {
3626 set ret
[rowofcommit
$kid]
3633 proc make_idlist
{row
} {
3634 global displayorder parentlist uparrowlen downarrowlen mingaplen
3635 global commitidx curview children
3637 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
3641 set ra
[expr {$row - $downarrowlen}]
3645 set rb
[expr {$row + $uparrowlen}]
3646 if {$rb > $commitidx($curview)} {
3647 set rb
$commitidx($curview)
3649 make_disporder
$r [expr {$rb + 1}]
3651 for {} {$r < $ra} {incr r
} {
3652 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3653 foreach p
[lindex
$parentlist $r] {
3654 if {$p eq
$nextid} continue
3655 set rn
[nextuse
$p $r]
3657 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3658 lappend ids
[list
[ordertoken
$p] $p]
3662 for {} {$r < $row} {incr r
} {
3663 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3664 foreach p
[lindex
$parentlist $r] {
3665 if {$p eq
$nextid} continue
3666 set rn
[nextuse
$p $r]
3667 if {$rn < 0 ||
$rn >= $row} {
3668 lappend ids
[list
[ordertoken
$p] $p]
3672 set id
[lindex
$displayorder $row]
3673 lappend ids
[list
[ordertoken
$id] $id]
3675 foreach p
[lindex
$parentlist $r] {
3676 set firstkid
[lindex
$children($curview,$p) 0]
3677 if {[rowofcommit
$firstkid] < $row} {
3678 lappend ids
[list
[ordertoken
$p] $p]
3682 set id
[lindex
$displayorder $r]
3684 set firstkid
[lindex
$children($curview,$id) 0]
3685 if {$firstkid ne
{} && [rowofcommit
$firstkid] < $row} {
3686 lappend ids
[list
[ordertoken
$id] $id]
3691 foreach idx
[lsort
-unique $ids] {
3692 lappend idlist
[lindex
$idx 1]
3697 proc rowsequal
{a b
} {
3698 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3699 set a
[lreplace
$a $i $i]
3701 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3702 set b
[lreplace
$b $i $i]
3704 return [expr {$a eq
$b}]
3707 proc makeupline
{id row rend
col} {
3708 global rowidlist uparrowlen downarrowlen mingaplen
3710 for {set r
$rend} {1} {set r
$rstart} {
3711 set rstart
[prevuse
$id $r]
3712 if {$rstart < 0} return
3713 if {$rstart < $row} break
3715 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3716 set rstart
[expr {$rend - $uparrowlen - 1}]
3718 for {set r
$rstart} {[incr r
] <= $row} {} {
3719 set idlist
[lindex
$rowidlist $r]
3720 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3721 set col [idcol
$idlist $id $col]
3722 lset rowidlist
$r [linsert
$idlist $col $id]
3728 proc layoutrows
{row endrow
} {
3729 global rowidlist rowisopt rowfinal displayorder
3730 global uparrowlen downarrowlen maxwidth mingaplen
3731 global children parentlist
3732 global commitidx viewcomplete curview
3734 make_disporder
[expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3737 set rm1
[expr {$row - 1}]
3738 foreach id
[lindex
$rowidlist $rm1] {
3743 set final
[lindex
$rowfinal $rm1]
3745 for {} {$row < $endrow} {incr row
} {
3746 set rm1
[expr {$row - 1}]
3747 if {$rm1 < 0 ||
$idlist eq
{}} {
3748 set idlist
[make_idlist
$row]
3751 set id
[lindex
$displayorder $rm1]
3752 set col [lsearch
-exact $idlist $id]
3753 set idlist
[lreplace
$idlist $col $col]
3754 foreach p
[lindex
$parentlist $rm1] {
3755 if {[lsearch
-exact $idlist $p] < 0} {
3756 set col [idcol
$idlist $p $col]
3757 set idlist
[linsert
$idlist $col $p]
3758 # if not the first child, we have to insert a line going up
3759 if {$id ne
[lindex
$children($curview,$p) 0]} {
3760 makeupline
$p $rm1 $row $col
3764 set id
[lindex
$displayorder $row]
3765 if {$row > $downarrowlen} {
3766 set termrow
[expr {$row - $downarrowlen - 1}]
3767 foreach p
[lindex
$parentlist $termrow] {
3768 set i
[lsearch
-exact $idlist $p]
3769 if {$i < 0} continue
3770 set nr
[nextuse
$p $termrow]
3771 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3772 set idlist
[lreplace
$idlist $i $i]
3776 set col [lsearch
-exact $idlist $id]
3778 set col [idcol
$idlist $id]
3779 set idlist
[linsert
$idlist $col $id]
3780 if {$children($curview,$id) ne
{}} {
3781 makeupline
$id $rm1 $row $col
3784 set r
[expr {$row + $uparrowlen - 1}]
3785 if {$r < $commitidx($curview)} {
3787 foreach p
[lindex
$parentlist $r] {
3788 if {[lsearch
-exact $idlist $p] >= 0} continue
3789 set fk
[lindex
$children($curview,$p) 0]
3790 if {[rowofcommit
$fk] < $row} {
3791 set x
[idcol
$idlist $p $x]
3792 set idlist
[linsert
$idlist $x $p]
3795 if {[incr r
] < $commitidx($curview)} {
3796 set p
[lindex
$displayorder $r]
3797 if {[lsearch
-exact $idlist $p] < 0} {
3798 set fk
[lindex
$children($curview,$p) 0]
3799 if {$fk ne
{} && [rowofcommit
$fk] < $row} {
3800 set x
[idcol
$idlist $p $x]
3801 set idlist
[linsert
$idlist $x $p]
3807 if {$final && !$viewcomplete($curview) &&
3808 $row + $uparrowlen + $mingaplen + $downarrowlen
3809 >= $commitidx($curview)} {
3812 set l
[llength
$rowidlist]
3814 lappend rowidlist
$idlist
3816 lappend rowfinal
$final
3817 } elseif
{$row < $l} {
3818 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3819 lset rowidlist
$row $idlist
3822 lset rowfinal
$row $final
3824 set pad
[ntimes
[expr {$row - $l}] {}]
3825 set rowidlist
[concat
$rowidlist $pad]
3826 lappend rowidlist
$idlist
3827 set rowfinal
[concat
$rowfinal $pad]
3828 lappend rowfinal
$final
3829 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3835 proc changedrow
{row
} {
3836 global displayorder iddrawn rowisopt need_redisplay
3838 set l
[llength
$rowisopt]
3840 lset rowisopt
$row 0
3841 if {$row + 1 < $l} {
3842 lset rowisopt
[expr {$row + 1}] 0
3843 if {$row + 2 < $l} {
3844 lset rowisopt
[expr {$row + 2}] 0
3848 set id
[lindex
$displayorder $row]
3849 if {[info exists iddrawn
($id)]} {
3850 set need_redisplay
1
3854 proc insert_pad
{row
col npad
} {
3857 set pad
[ntimes
$npad {}]
3858 set idlist
[lindex
$rowidlist $row]
3859 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3860 set aft
[lrange
$idlist $col end
]
3861 set i
[lsearch
-exact $aft {}]
3863 set aft
[lreplace
$aft $i $i]
3865 lset rowidlist
$row [concat
$bef $pad $aft]
3869 proc optimize_rows
{row
col endrow
} {
3870 global rowidlist rowisopt displayorder curview children
3875 for {} {$row < $endrow} {incr row
; set col 0} {
3876 if {[lindex
$rowisopt $row]} continue
3878 set y0
[expr {$row - 1}]
3879 set ym
[expr {$row - 2}]
3880 set idlist
[lindex
$rowidlist $row]
3881 set previdlist
[lindex
$rowidlist $y0]
3882 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3884 set pprevidlist
[lindex
$rowidlist $ym]
3885 if {$pprevidlist eq
{}} continue
3891 for {} {$col < [llength
$idlist]} {incr
col} {
3892 set id
[lindex
$idlist $col]
3893 if {[lindex
$previdlist $col] eq
$id} continue
3898 set x0
[lsearch
-exact $previdlist $id]
3899 if {$x0 < 0} continue
3900 set z
[expr {$x0 - $col}]
3904 set xm
[lsearch
-exact $pprevidlist $id]
3906 set z0
[expr {$xm - $x0}]
3910 # if row y0 is the first child of $id then it's not an arrow
3911 if {[lindex
$children($curview,$id) 0] ne
3912 [lindex
$displayorder $y0]} {
3916 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3917 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3920 # Looking at lines from this row to the previous row,
3921 # make them go straight up if they end in an arrow on
3922 # the previous row; otherwise make them go straight up
3924 if {$z < -1 ||
($z < 0 && $isarrow)} {
3925 # Line currently goes left too much;
3926 # insert pads in the previous row, then optimize it
3927 set npad
[expr {-1 - $z + $isarrow}]
3928 insert_pad
$y0 $x0 $npad
3930 optimize_rows
$y0 $x0 $row
3932 set previdlist
[lindex
$rowidlist $y0]
3933 set x0
[lsearch
-exact $previdlist $id]
3934 set z
[expr {$x0 - $col}]
3936 set pprevidlist
[lindex
$rowidlist $ym]
3937 set xm
[lsearch
-exact $pprevidlist $id]
3938 set z0
[expr {$xm - $x0}]
3940 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3941 # Line currently goes right too much;
3942 # insert pads in this line
3943 set npad
[expr {$z - 1 + $isarrow}]
3944 insert_pad
$row $col $npad
3945 set idlist
[lindex
$rowidlist $row]
3947 set z
[expr {$x0 - $col}]
3950 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3951 # this line links to its first child on row $row-2
3952 set id
[lindex
$displayorder $ym]
3953 set xc
[lsearch
-exact $pprevidlist $id]
3955 set z0
[expr {$xc - $x0}]
3958 # avoid lines jigging left then immediately right
3959 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3960 insert_pad
$y0 $x0 1
3962 optimize_rows
$y0 $x0 $row
3963 set previdlist
[lindex
$rowidlist $y0]
3967 # Find the first column that doesn't have a line going right
3968 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
3969 set id
[lindex
$idlist $col]
3970 if {$id eq
{}} break
3971 set x0
[lsearch
-exact $previdlist $id]
3973 # check if this is the link to the first child
3974 set kid
[lindex
$displayorder $y0]
3975 if {[lindex
$children($curview,$id) 0] eq
$kid} {
3976 # it is, work out offset to child
3977 set x0
[lsearch
-exact $previdlist $kid]
3980 if {$x0 <= $col} break
3982 # Insert a pad at that column as long as it has a line and
3983 # isn't the last column
3984 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
3985 set idlist
[linsert
$idlist $col {}]
3986 lset rowidlist
$row $idlist
3994 global canvx0 linespc
3995 return [expr {$canvx0 + $col * $linespc}]
3999 global canvy0 linespc
4000 return [expr {$canvy0 + $row * $linespc}]
4003 proc linewidth
{id
} {
4004 global thickerline lthickness
4007 if {[info exists thickerline
] && $id eq
$thickerline} {
4008 set wid
[expr {2 * $lthickness}]
4013 proc rowranges
{id
} {
4014 global curview children uparrowlen downarrowlen
4017 set kids
$children($curview,$id)
4023 foreach child
$kids {
4024 if {![commitinview
$child $curview]} break
4025 set row
[rowofcommit
$child]
4026 if {![info exists prev
]} {
4027 lappend ret
[expr {$row + 1}]
4029 if {$row <= $prevrow} {
4030 puts
"oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4032 # see if the line extends the whole way from prevrow to row
4033 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4034 [lsearch
-exact [lindex
$rowidlist \
4035 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
4036 # it doesn't, see where it ends
4037 set r
[expr {$prevrow + $downarrowlen}]
4038 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4039 while {[incr r
-1] > $prevrow &&
4040 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4042 while {[incr r
] <= $row &&
4043 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4047 # see where it starts up again
4048 set r
[expr {$row - $uparrowlen}]
4049 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
4050 while {[incr r
] < $row &&
4051 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
4053 while {[incr r
-1] >= $prevrow &&
4054 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
4060 if {$child eq
$id} {
4069 proc drawlineseg
{id row endrow arrowlow
} {
4070 global rowidlist displayorder iddrawn linesegs
4071 global canv colormap linespc curview maxlinelen parentlist
4073 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
4074 set le
[expr {$row + 1}]
4077 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
4083 set x
[lindex
$displayorder $le]
4088 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
4089 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
4105 if {[info exists linesegs
($id)]} {
4106 set lines
$linesegs($id)
4108 set r0
[lindex
$li 0]
4110 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
4120 set li
[lindex
$lines [expr {$i-1}]]
4121 set r1
[lindex
$li 1]
4122 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
4127 set x
[lindex
$cols [expr {$le - $row}]]
4128 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
4129 set dir
[expr {$xp - $x}]
4131 set ith
[lindex
$lines $i 2]
4132 set coords
[$canv coords
$ith]
4133 set ah
[$canv itemcget
$ith -arrow]
4134 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
4135 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
4136 if {$x2 ne
{} && $x - $x2 == $dir} {
4137 set coords
[lrange
$coords 0 end-2
]
4140 set coords
[list
[xc
$le $x] [yc
$le]]
4143 set itl
[lindex
$lines [expr {$i-1}] 2]
4144 set al
[$canv itemcget
$itl -arrow]
4145 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
4146 } elseif
{$arrowlow} {
4147 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
4148 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
4152 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
4153 for {set y
$le} {[incr y
-1] > $row} {} {
4155 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
4156 set ndir
[expr {$xp - $x}]
4157 if {$dir != $ndir ||
$xp < 0} {
4158 lappend coords
[xc
$y $x] [yc
$y]
4164 # join parent line to first child
4165 set ch
[lindex
$displayorder $row]
4166 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
4168 puts
"oops: drawlineseg: child $ch not on row $row"
4169 } elseif
{$xc != $x} {
4170 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
4171 set d
[expr {int
(0.5 * $linespc)}]
4174 set x2
[expr {$x1 - $d}]
4176 set x2
[expr {$x1 + $d}]
4179 set y1
[expr {$y2 + $d}]
4180 lappend coords
$x1 $y1 $x2 $y2
4181 } elseif
{$xc < $x - 1} {
4182 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
4183 } elseif
{$xc > $x + 1} {
4184 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
4188 lappend coords
[xc
$row $x] [yc
$row]
4190 set xn
[xc
$row $xp]
4192 lappend coords
$xn $yn
4196 set t
[$canv create line
$coords -width [linewidth
$id] \
4197 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
4200 set lines
[linsert
$lines $i [list
$row $le $t]]
4202 $canv coords
$ith $coords
4203 if {$arrow ne
$ah} {
4204 $canv itemconf
$ith -arrow $arrow
4206 lset lines
$i 0 $row
4209 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
4210 set ndir
[expr {$xo - $xp}]
4211 set clow
[$canv coords
$itl]
4212 if {$dir == $ndir} {
4213 set clow
[lrange
$clow 2 end
]
4215 set coords
[concat
$coords $clow]
4217 lset lines
[expr {$i-1}] 1 $le
4219 # coalesce two pieces
4221 set b
[lindex
$lines [expr {$i-1}] 0]
4222 set e
[lindex
$lines $i 1]
4223 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
4225 $canv coords
$itl $coords
4226 if {$arrow ne
$al} {
4227 $canv itemconf
$itl -arrow $arrow
4231 set linesegs
($id) $lines
4235 proc drawparentlinks
{id row
} {
4236 global rowidlist canv colormap curview parentlist
4237 global idpos linespc
4239 set rowids
[lindex
$rowidlist $row]
4240 set col [lsearch
-exact $rowids $id]
4241 if {$col < 0} return
4242 set olds
[lindex
$parentlist $row]
4243 set row2
[expr {$row + 1}]
4244 set x
[xc
$row $col]
4247 set d
[expr {int
(0.5 * $linespc)}]
4248 set ymid
[expr {$y + $d}]
4249 set ids
[lindex
$rowidlist $row2]
4250 # rmx = right-most X coord used
4253 set i
[lsearch
-exact $ids $p]
4255 puts
"oops, parent $p of $id not in list"
4258 set x2
[xc
$row2 $i]
4262 set j
[lsearch
-exact $rowids $p]
4264 # drawlineseg will do this one for us
4268 # should handle duplicated parents here...
4269 set coords
[list
$x $y]
4271 # if attaching to a vertical segment, draw a smaller
4272 # slant for visual distinctness
4275 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
4277 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
4279 } elseif
{$i < $col && $i < $j} {
4280 # segment slants towards us already
4281 lappend coords
[xc
$row $j] $y
4283 if {$i < $col - 1} {
4284 lappend coords
[expr {$x2 + $linespc}] $y
4285 } elseif
{$i > $col + 1} {
4286 lappend coords
[expr {$x2 - $linespc}] $y
4288 lappend coords
$x2 $y2
4291 lappend coords
$x2 $y2
4293 set t
[$canv create line
$coords -width [linewidth
$p] \
4294 -fill $colormap($p) -tags lines.
$p]
4298 if {$rmx > [lindex
$idpos($id) 1]} {
4299 lset idpos
($id) 1 $rmx
4304 proc drawlines
{id
} {
4307 $canv itemconf lines.
$id -width [linewidth
$id]
4310 proc drawcmittext
{id row
col} {
4311 global linespc canv canv2 canv3 fgcolor curview
4312 global cmitlisted commitinfo rowidlist parentlist
4313 global rowtextx idpos idtags idheads idotherrefs
4314 global linehtag linentag linedtag selectedline
4315 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4317 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4318 set listed
$cmitlisted($curview,$id)
4319 if {$id eq
$nullid} {
4321 } elseif
{$id eq
$nullid2} {
4324 set ofill
[expr {$listed != 0?
"blue": "white"}]
4326 set x
[xc
$row $col]
4328 set orad
[expr {$linespc / 3}]
4330 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
4331 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4332 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4333 } elseif
{$listed == 2} {
4334 # triangle pointing left for left-side commits
4335 set t
[$canv create polygon \
4336 [expr {$x - $orad}] $y \
4337 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4338 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4339 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4341 # triangle pointing right for right-side commits
4342 set t
[$canv create polygon \
4343 [expr {$x + $orad - 1}] $y \
4344 [expr {$x - $orad}] [expr {$y - $orad}] \
4345 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4346 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
4349 $canv bind $t <1> {selcanvline
{} %x
%y
}
4350 set rmx
[llength
[lindex
$rowidlist $row]]
4351 set olds
[lindex
$parentlist $row]
4353 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
4355 set i
[lsearch
-exact $nextids $p]
4361 set xt
[xc
$row $rmx]
4362 set rowtextx
($row) $xt
4363 set idpos
($id) [list
$x $xt $y]
4364 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
4365 ||
[info exists idotherrefs
($id)]} {
4366 set xt
[drawtags
$id $x $xt $y]
4368 set headline
[lindex
$commitinfo($id) 0]
4369 set name
[lindex
$commitinfo($id) 1]
4370 set date [lindex
$commitinfo($id) 2]
4371 set date [formatdate
$date]
4374 set isbold
[ishighlighted
$row]
4376 lappend boldrows
$row
4377 set font mainfontbold
4379 lappend boldnamerows
$row
4380 set nfont mainfontbold
4383 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
4384 -text $headline -font $font -tags text
]
4385 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
4386 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
4387 -text $name -font $nfont -tags text
]
4388 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
4389 -text $date -font mainfont
-tags text
]
4390 if {[info exists selectedline
] && $selectedline == $row} {
4393 set xr
[expr {$xt + [font measure
$font $headline]}]
4394 if {$xr > $canvxmax} {
4400 proc drawcmitrow
{row
} {
4401 global displayorder rowidlist nrows_drawn
4402 global iddrawn markingmatches
4403 global commitinfo numcommits
4404 global filehighlight fhighlights findpattern nhighlights
4405 global hlview vhighlights
4406 global highlight_related rhighlights
4408 if {$row >= $numcommits} return
4410 set id
[lindex
$displayorder $row]
4411 if {[info exists hlview
] && ![info exists vhighlights
($row)]} {
4412 askvhighlight
$row $id
4414 if {[info exists filehighlight
] && ![info exists fhighlights
($row)]} {
4415 askfilehighlight
$row $id
4417 if {$findpattern ne
{} && ![info exists nhighlights
($row)]} {
4418 askfindhighlight
$row $id
4420 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($row)]} {
4421 askrelhighlight
$row $id
4423 if {![info exists iddrawn
($id)]} {
4424 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
4426 puts
"oops, row $row id $id not in list"
4429 if {![info exists commitinfo
($id)]} {
4433 drawcmittext
$id $row $col
4437 if {$markingmatches} {
4438 markrowmatches
$row $id
4442 proc drawcommits
{row
{endrow
{}}} {
4443 global numcommits iddrawn displayorder curview need_redisplay
4444 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4449 if {$endrow eq
{}} {
4452 if {$endrow >= $numcommits} {
4453 set endrow
[expr {$numcommits - 1}]
4456 set rl1
[expr {$row - $downarrowlen - 3}]
4460 set ro1
[expr {$row - 3}]
4464 set r2
[expr {$endrow + $uparrowlen + 3}]
4465 if {$r2 > $numcommits} {
4468 for {set r
$rl1} {$r < $r2} {incr r
} {
4469 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
4473 set rl1
[expr {$r + 1}]
4479 optimize_rows
$ro1 0 $r2
4480 if {$need_redisplay ||
$nrows_drawn > 2000} {
4485 # make the lines join to already-drawn rows either side
4486 set r
[expr {$row - 1}]
4487 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
4490 set er
[expr {$endrow + 1}]
4491 if {$er >= $numcommits ||
4492 ![info exists iddrawn
([lindex
$displayorder $er])]} {
4495 for {} {$r <= $er} {incr r
} {
4496 set id
[lindex
$displayorder $r]
4497 set wasdrawn
[info exists iddrawn
($id)]
4499 if {$r == $er} break
4500 set nextid
[lindex
$displayorder [expr {$r + 1}]]
4501 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
4502 drawparentlinks
$id $r
4504 set rowids
[lindex
$rowidlist $r]
4505 foreach lid
$rowids {
4506 if {$lid eq
{}} continue
4507 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
4509 # see if this is the first child of any of its parents
4510 foreach p
[lindex
$parentlist $r] {
4511 if {[lsearch
-exact $rowids $p] < 0} {
4512 # make this line extend up to the child
4513 set lineend
($p) [drawlineseg
$p $r $er 0]
4517 set lineend
($lid) [drawlineseg
$lid $r $er 1]
4523 proc undolayout
{row
} {
4524 global uparrowlen mingaplen downarrowlen
4525 global rowidlist rowisopt rowfinal need_redisplay
4527 set r
[expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4531 if {[llength
$rowidlist] > $r} {
4533 set rowidlist
[lrange
$rowidlist 0 $r]
4534 set rowfinal
[lrange
$rowfinal 0 $r]
4535 set rowisopt
[lrange
$rowisopt 0 $r]
4536 set need_redisplay
1
4541 proc drawvisible
{} {
4542 global canv linespc curview vrowmod selectedline targetrow targetid
4543 global need_redisplay cscroll
4545 set fs
[$canv yview
]
4546 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4547 if {$ymax eq
{} ||
$ymax == 0} return
4548 set f0
[lindex
$fs 0]
4549 set f1
[lindex
$fs 1]
4550 set y0
[expr {int
($f0 * $ymax)}]
4551 set y1
[expr {int
($f1 * $ymax)}]
4553 if {[info exists targetid
]} {
4554 set r
[rowofcommit
$targetid]
4555 if {$r != $targetrow} {
4556 # Fix up the scrollregion and change the scrolling position
4557 # now that our target row has moved.
4558 set diff [expr {($r - $targetrow) * $linespc}]
4561 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4564 set f0
[expr {$y0 / $ymax}]
4565 set f1
[expr {$y1 / $ymax}]
4566 allcanvs yview moveto
$f0
4567 $cscroll set $f0 $f1
4568 set need_redisplay
1
4572 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
4573 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
4574 if {$endrow >= $vrowmod($curview)} {
4575 update_arcrows
$curview
4577 if {[info exists selectedline
] &&
4578 $row <= $selectedline && $selectedline <= $endrow} {
4579 set targetrow
$selectedline
4581 set targetrow
[expr {int
(($row + $endrow) / 2)}]
4583 set targetid
[commitonrow
$targetrow]
4584 drawcommits
$row $endrow
4587 proc clear_display
{} {
4588 global iddrawn linesegs need_redisplay nrows_drawn
4589 global vhighlights fhighlights nhighlights rhighlights
4592 catch
{unset iddrawn
}
4593 catch
{unset linesegs
}
4594 catch
{unset vhighlights
}
4595 catch
{unset fhighlights
}
4596 catch
{unset nhighlights
}
4597 catch
{unset rhighlights
}
4598 set need_redisplay
0
4602 proc findcrossings
{id
} {
4603 global rowidlist parentlist numcommits displayorder
4607 foreach
{s e
} [rowranges
$id] {
4608 if {$e >= $numcommits} {
4609 set e
[expr {$numcommits - 1}]
4611 if {$e <= $s} continue
4612 for {set row
$e} {[incr row
-1] >= $s} {} {
4613 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
4615 set olds
[lindex
$parentlist $row]
4616 set kid
[lindex
$displayorder $row]
4617 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
4618 if {$kidx < 0} continue
4619 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
4621 set px
[lsearch
-exact $nextrow $p]
4622 if {$px < 0} continue
4623 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
4624 if {[lsearch
-exact $ccross $p] >= 0} continue
4625 if {$x == $px + ($kidx < $px?
-1: 1)} {
4627 } elseif
{[lsearch
-exact $cross $p] < 0} {
4634 return [concat
$ccross {{}} $cross]
4637 proc assigncolor
{id
} {
4638 global colormap colors nextcolor
4639 global parents children children curview
4641 if {[info exists colormap
($id)]} return
4642 set ncolors
[llength
$colors]
4643 if {[info exists children
($curview,$id)]} {
4644 set kids
$children($curview,$id)
4648 if {[llength
$kids] == 1} {
4649 set child
[lindex
$kids 0]
4650 if {[info exists colormap
($child)]
4651 && [llength
$parents($curview,$child)] == 1} {
4652 set colormap
($id) $colormap($child)
4658 foreach x
[findcrossings
$id] {
4660 # delimiter between corner crossings and other crossings
4661 if {[llength
$badcolors] >= $ncolors - 1} break
4662 set origbad
$badcolors
4664 if {[info exists colormap
($x)]
4665 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
4666 lappend badcolors
$colormap($x)
4669 if {[llength
$badcolors] >= $ncolors} {
4670 set badcolors
$origbad
4672 set origbad
$badcolors
4673 if {[llength
$badcolors] < $ncolors - 1} {
4674 foreach child
$kids {
4675 if {[info exists colormap
($child)]
4676 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
4677 lappend badcolors
$colormap($child)
4679 foreach p
$parents($curview,$child) {
4680 if {[info exists colormap
($p)]
4681 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
4682 lappend badcolors
$colormap($p)
4686 if {[llength
$badcolors] >= $ncolors} {
4687 set badcolors
$origbad
4690 for {set i
0} {$i <= $ncolors} {incr i
} {
4691 set c
[lindex
$colors $nextcolor]
4692 if {[incr nextcolor
] >= $ncolors} {
4695 if {[lsearch
-exact $badcolors $c]} break
4697 set colormap
($id) $c
4700 proc bindline
{t id
} {
4703 $canv bind $t <Enter
> "lineenter %x %y $id"
4704 $canv bind $t <Motion
> "linemotion %x %y $id"
4705 $canv bind $t <Leave
> "lineleave $id"
4706 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4709 proc drawtags
{id x xt y1
} {
4710 global idtags idheads idotherrefs mainhead
4711 global linespc lthickness
4712 global canv rowtextx curview fgcolor bgcolor
4717 if {[info exists idtags
($id)]} {
4718 set marks
$idtags($id)
4719 set ntags
[llength
$marks]
4721 if {[info exists idheads
($id)]} {
4722 set marks
[concat
$marks $idheads($id)]
4723 set nheads
[llength
$idheads($id)]
4725 if {[info exists idotherrefs
($id)]} {
4726 set marks
[concat
$marks $idotherrefs($id)]
4732 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4733 set yt
[expr {$y1 - 0.5 * $linespc}]
4734 set yb
[expr {$yt + $linespc - 1}]
4738 foreach tag
$marks {
4740 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4741 set wid
[font measure mainfontbold
$tag]
4743 set wid
[font measure mainfont
$tag]
4747 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4749 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4750 -width $lthickness -fill black
-tags tag.
$id]
4752 foreach tag
$marks x
$xvals wid
$wvals {
4753 set xl
[expr {$x + $delta}]
4754 set xr
[expr {$x + $delta + $wid + $lthickness}]
4756 if {[incr ntags
-1] >= 0} {
4758 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4759 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4760 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4761 $canv bind $t <1> [list showtag
$tag 1]
4762 set rowtextx
([rowofcommit
$id]) [expr {$xr + $linespc}]
4764 # draw a head or other ref
4765 if {[incr nheads
-1] >= 0} {
4767 if {$tag eq
$mainhead} {
4768 set font mainfontbold
4773 set xl
[expr {$xl - $delta/2}]
4774 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4775 -width 1 -outline black
-fill $col -tags tag.
$id
4776 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4777 set rwid
[font measure mainfont
$remoteprefix]
4778 set xi
[expr {$x + 1}]
4779 set yti
[expr {$yt + 1}]
4780 set xri
[expr {$x + $rwid}]
4781 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4782 -width 0 -fill "#ffddaa" -tags tag.
$id
4785 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4786 -font $font -tags [list tag.
$id text
]]
4788 $canv bind $t <1> [list showtag
$tag 1]
4789 } elseif
{$nheads >= 0} {
4790 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4796 proc xcoord
{i level
ln} {
4797 global canvx0 xspc1 xspc2
4799 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4800 if {$i > 0 && $i == $level} {
4801 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4802 } elseif
{$i > $level} {
4803 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4808 proc show_status
{msg
} {
4812 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4813 -tags text
-fill $fgcolor
4816 # Don't change the text pane cursor if it is currently the hand cursor,
4817 # showing that we are over a sha1 ID link.
4818 proc settextcursor
{c
} {
4819 global ctext curtextcursor
4821 if {[$ctext cget
-cursor] == $curtextcursor} {
4822 $ctext config
-cursor $c
4824 set curtextcursor
$c
4827 proc nowbusy
{what
{name
{}}} {
4828 global isbusy busyname statusw
4830 if {[array names isbusy
] eq
{}} {
4831 . config
-cursor watch
4835 set busyname
($what) $name
4837 $statusw conf
-text $name
4841 proc notbusy
{what
} {
4842 global isbusy maincursor textcursor busyname statusw
4846 if {$busyname($what) ne
{} &&
4847 [$statusw cget
-text] eq
$busyname($what)} {
4848 $statusw conf
-text {}
4851 if {[array names isbusy
] eq
{}} {
4852 . config
-cursor $maincursor
4853 settextcursor
$textcursor
4857 proc findmatches
{f
} {
4858 global findtype findstring
4859 if {$findtype == [mc
"Regexp"]} {
4860 set matches
[regexp
-indices -all -inline $findstring $f]
4863 if {$findtype == [mc
"IgnCase"]} {
4864 set f
[string tolower
$f]
4865 set fs
[string tolower
$fs]
4869 set l
[string length
$fs]
4870 while {[set j
[string first
$fs $f $i]] >= 0} {
4871 lappend matches
[list
$j [expr {$j+$l-1}]]
4872 set i
[expr {$j + $l}]
4878 proc dofind
{{dirn
1} {wrap
1}} {
4879 global findstring findstartline findcurline selectedline numcommits
4880 global gdttype filehighlight fh_serial find_dirn findallowwrap
4882 if {[info exists find_dirn
]} {
4883 if {$find_dirn == $dirn} return
4887 if {$findstring eq
{} ||
$numcommits == 0} return
4888 if {![info exists selectedline
]} {
4889 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4891 set findstartline
$selectedline
4893 set findcurline
$findstartline
4894 nowbusy finding
[mc
"Searching"]
4895 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4896 after cancel do_file_hl
$fh_serial
4897 do_file_hl
$fh_serial
4900 set findallowwrap
$wrap
4904 proc stopfinding
{} {
4905 global find_dirn findcurline fprogcoord
4907 if {[info exists find_dirn
]} {
4917 global commitdata commitinfo numcommits findpattern findloc
4918 global findstartline findcurline findallowwrap
4919 global find_dirn gdttype fhighlights fprogcoord
4920 global curview varcorder vrownum varccommits
4922 if {![info exists find_dirn
]} {
4925 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4928 if {$find_dirn > 0} {
4930 if {$l >= $numcommits} {
4933 if {$l <= $findstartline} {
4934 set lim
[expr {$findstartline + 1}]
4937 set moretodo
$findallowwrap
4944 if {$l >= $findstartline} {
4945 set lim
[expr {$findstartline - 1}]
4948 set moretodo
$findallowwrap
4951 set n
[expr {($lim - $l) * $find_dirn}]
4958 set ai
[bsearch
$vrownum($curview) $l]
4959 set a
[lindex
$varcorder($curview) $ai]
4960 set arow
[lindex
$vrownum($curview) $ai]
4961 set ids
[lindex
$varccommits($curview,$a)]
4962 set arowend
[expr {$arow + [llength
$ids]}]
4963 if {$gdttype eq
[mc
"containing:"]} {
4964 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4965 if {$l < $arow ||
$l >= $arowend} {
4967 set a
[lindex
$varcorder($curview) $ai]
4968 set arow
[lindex
$vrownum($curview) $ai]
4969 set ids
[lindex
$varccommits($curview,$a)]
4970 set arowend
[expr {$arow + [llength
$ids]}]
4972 set id
[lindex
$ids [expr {$l - $arow}]]
4973 # shouldn't happen unless git log doesn't give all the commits...
4974 if {![info exists commitdata
($id)] ||
4975 ![doesmatch
$commitdata($id)]} {
4978 if {![info exists commitinfo
($id)]} {
4981 set info
$commitinfo($id)
4982 foreach f
$info ty
$fldtypes {
4983 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
4992 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4993 if {$l < $arow ||
$l >= $arowend} {
4995 set a
[lindex
$varcorder($curview) $ai]
4996 set arow
[lindex
$vrownum($curview) $ai]
4997 set ids
[lindex
$varccommits($curview,$a)]
4998 set arowend
[expr {$arow + [llength
$ids]}]
5000 set id
[lindex
$ids [expr {$l - $arow}]]
5001 if {![info exists fhighlights
($l)]} {
5002 askfilehighlight
$l $id
5005 set findcurline
[expr {$l - $find_dirn}]
5007 } elseif
{$fhighlights($l)} {
5013 if {$found ||
($domore && !$moretodo)} {
5029 set findcurline
[expr {$l - $find_dirn}]
5031 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
5035 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
5040 proc findselectline
{l
} {
5041 global findloc commentend ctext findcurline markingmatches gdttype
5043 set markingmatches
1
5046 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
5047 # highlight the matches in the comments
5048 set f
[$ctext get
1.0 $commentend]
5049 set matches
[findmatches
$f]
5050 foreach match
$matches {
5051 set start
[lindex
$match 0]
5052 set end
[expr {[lindex
$match 1] + 1}]
5053 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
5059 # mark the bits of a headline or author that match a find string
5060 proc markmatches
{canv l str tag matches font row
} {
5063 set bbox
[$canv bbox
$tag]
5064 set x0
[lindex
$bbox 0]
5065 set y0
[lindex
$bbox 1]
5066 set y1
[lindex
$bbox 3]
5067 foreach match
$matches {
5068 set start
[lindex
$match 0]
5069 set end
[lindex
$match 1]
5070 if {$start > $end} continue
5071 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
5072 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
5073 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
5074 [expr {$x0+$xlen+2}] $y1 \
5075 -outline {} -tags [list match
$l matches
] -fill yellow
]
5077 if {[info exists selectedline
] && $row == $selectedline} {
5078 $canv raise
$t secsel
5083 proc unmarkmatches
{} {
5084 global markingmatches
5086 allcanvs delete matches
5087 set markingmatches
0
5091 proc selcanvline
{w x y
} {
5092 global canv canvy0 ctext linespc
5094 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5095 if {$ymax == {}} return
5096 set yfrac
[lindex
[$canv yview
] 0]
5097 set y
[expr {$y + $yfrac * $ymax}]
5098 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
5103 set xmax
[lindex
[$canv cget
-scrollregion] 2]
5104 set xleft
[expr {[lindex
[$canv xview
] 0] * $xmax}]
5105 if {![info exists rowtextx
($l)] ||
$xleft + $x < $rowtextx($l)} return
5111 proc commit_descriptor
{p
} {
5113 if {![info exists commitinfo
($p)]} {
5117 if {[llength
$commitinfo($p)] > 1} {
5118 set l
[lindex
$commitinfo($p) 0]
5123 # append some text to the ctext widget, and make any SHA1 ID
5124 # that we know about be a clickable link.
5125 proc appendwithlinks
{text tags
} {
5126 global ctext linknum curview pendinglinks
5128 set start
[$ctext index
"end - 1c"]
5129 $ctext insert end
$text $tags
5130 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
5134 set linkid
[string range
$text $s $e]
5136 $ctext tag delete link
$linknum
5137 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
5138 setlink
$linkid link
$linknum
5143 proc setlink
{id lk
} {
5144 global curview ctext pendinglinks commitinterest
5146 if {[commitinview
$id $curview]} {
5147 $ctext tag conf
$lk -foreground blue
-underline 1
5148 $ctext tag
bind $lk <1> [list selectline
[rowofcommit
$id] 1]
5149 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
5150 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
5152 lappend pendinglinks
($id) $lk
5153 lappend commitinterest
($id) {makelink
%I
}
5157 proc makelink
{id
} {
5160 if {![info exists pendinglinks
($id)]} return
5161 foreach lk
$pendinglinks($id) {
5164 unset pendinglinks
($id)
5167 proc linkcursor
{w inc
} {
5168 global linkentercount curtextcursor
5170 if {[incr linkentercount
$inc] > 0} {
5171 $w configure
-cursor hand2
5173 $w configure
-cursor $curtextcursor
5174 if {$linkentercount < 0} {
5175 set linkentercount
0
5180 proc viewnextline
{dir
} {
5184 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5185 set wnow
[$canv yview
]
5186 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5187 set newtop
[expr {$wtop + $dir * $linespc}]
5190 } elseif
{$newtop > $ymax} {
5193 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5196 # add a list of tag or branch names at position pos
5197 # returns the number of names inserted
5198 proc appendrefs
{pos ids var
} {
5199 global ctext linknum curview
$var maxrefs
5201 if {[catch
{$ctext index
$pos}]} {
5204 $ctext conf
-state normal
5205 $ctext delete
$pos "$pos lineend"
5208 foreach tag
[set $var\
($id\
)] {
5209 lappend tags
[list
$tag $id]
5212 if {[llength
$tags] > $maxrefs} {
5213 $ctext insert
$pos "many ([llength $tags])"
5215 set tags
[lsort
-index 0 -decreasing $tags]
5218 set id
[lindex
$ti 1]
5221 $ctext tag delete
$lk
5222 $ctext insert
$pos $sep
5223 $ctext insert
$pos [lindex
$ti 0] $lk
5228 $ctext conf
-state disabled
5229 return [llength
$tags]
5232 # called when we have finished computing the nearby tags
5233 proc dispneartags
{delay
} {
5234 global selectedline currentid showneartags tagphase
5236 if {![info exists selectedline
] ||
!$showneartags} return
5237 after cancel dispnexttag
5239 after
200 dispnexttag
5242 after idle dispnexttag
5247 proc dispnexttag
{} {
5248 global selectedline currentid showneartags tagphase ctext
5250 if {![info exists selectedline
] ||
!$showneartags} return
5251 switch
-- $tagphase {
5253 set dtags
[desctags
$currentid]
5255 appendrefs precedes
$dtags idtags
5259 set atags
[anctags
$currentid]
5261 appendrefs follows
$atags idtags
5265 set dheads
[descheads
$currentid]
5266 if {$dheads ne
{}} {
5267 if {[appendrefs branch
$dheads idheads
] > 1
5268 && [$ctext get
"branch -3c"] eq
"h"} {
5269 # turn "Branch" into "Branches"
5270 $ctext conf
-state normal
5271 $ctext insert
"branch -2c" "es"
5272 $ctext conf
-state disabled
5277 if {[incr tagphase
] <= 2} {
5278 after idle dispnexttag
5282 proc make_secsel
{l
} {
5283 global linehtag linentag linedtag canv canv2 canv3
5285 if {![info exists linehtag
($l)]} return
5287 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
5288 -tags secsel
-fill [$canv cget
-selectbackground]]
5290 $canv2 delete secsel
5291 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
5292 -tags secsel
-fill [$canv2 cget
-selectbackground]]
5294 $canv3 delete secsel
5295 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
5296 -tags secsel
-fill [$canv3 cget
-selectbackground]]
5300 proc selectline
{l isnew
} {
5301 global canv ctext commitinfo selectedline
5302 global canvy0 linespc parents children curview
5303 global currentid sha1entry
5304 global commentend idtags linknum
5305 global mergemax numcommits pending_select
5306 global cmitmode showneartags allcommits
5308 catch
{unset pending_select
}
5313 if {$l < 0 ||
$l >= $numcommits} return
5314 set y
[expr {$canvy0 + $l * $linespc}]
5315 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5316 set ytop
[expr {$y - $linespc - 1}]
5317 set ybot
[expr {$y + $linespc + 1}]
5318 set wnow
[$canv yview
]
5319 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5320 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
5321 set wh
[expr {$wbot - $wtop}]
5323 if {$ytop < $wtop} {
5324 if {$ybot < $wtop} {
5325 set newtop
[expr {$y - $wh / 2.0}]
5328 if {$newtop > $wtop - $linespc} {
5329 set newtop
[expr {$wtop - $linespc}]
5332 } elseif
{$ybot > $wbot} {
5333 if {$ytop > $wbot} {
5334 set newtop
[expr {$y - $wh / 2.0}]
5336 set newtop
[expr {$ybot - $wh}]
5337 if {$newtop < $wtop + $linespc} {
5338 set newtop
[expr {$wtop + $linespc}]
5342 if {$newtop != $wtop} {
5346 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5352 set id
[commitonrow
$l]
5354 addtohistory
[list selbyid
$id]
5359 $sha1entry delete
0 end
5360 $sha1entry insert
0 $id
5361 $sha1entry selection from
0
5362 $sha1entry selection to end
5365 $ctext conf
-state normal
5368 set info
$commitinfo($id)
5369 set date [formatdate
[lindex
$info 2]]
5370 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
5371 set date [formatdate
[lindex
$info 4]]
5372 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
5373 if {[info exists idtags
($id)]} {
5374 $ctext insert end
[mc
"Tags:"]
5375 foreach tag
$idtags($id) {
5376 $ctext insert end
" $tag"
5378 $ctext insert end
"\n"
5382 set olds
$parents($curview,$id)
5383 if {[llength
$olds] > 1} {
5386 if {$np >= $mergemax} {
5391 $ctext insert end
"[mc "Parent
"]: " $tag
5392 appendwithlinks
[commit_descriptor
$p] {}
5397 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
5401 foreach c
$children($curview,$id) {
5402 append headers
"[mc "Child
"]: [commit_descriptor $c]"
5405 # make anything that looks like a SHA1 ID be a clickable link
5406 appendwithlinks
$headers {}
5407 if {$showneartags} {
5408 if {![info exists allcommits
]} {
5411 $ctext insert end
"[mc "Branch
"]: "
5412 $ctext mark
set branch
"end -1c"
5413 $ctext mark gravity branch left
5414 $ctext insert end
"\n[mc "Follows
"]: "
5415 $ctext mark
set follows
"end -1c"
5416 $ctext mark gravity follows left
5417 $ctext insert end
"\n[mc "Precedes
"]: "
5418 $ctext mark
set precedes
"end -1c"
5419 $ctext mark gravity precedes left
5420 $ctext insert end
"\n"
5423 $ctext insert end
"\n"
5424 set comment
[lindex
$info 5]
5425 if {[string first
"\r" $comment] >= 0} {
5426 set comment
[string map
{"\r" "\n "} $comment]
5428 appendwithlinks
$comment {comment
}
5430 $ctext tag remove found
1.0 end
5431 $ctext conf
-state disabled
5432 set commentend
[$ctext index
"end - 1c"]
5434 init_flist
[mc
"Comments"]
5435 if {$cmitmode eq
"tree"} {
5437 } elseif
{[llength
$olds] <= 1} {
5444 proc selfirstline
{} {
5449 proc sellastline
{} {
5452 set l
[expr {$numcommits - 1}]
5456 proc selnextline
{dir
} {
5459 if {![info exists selectedline
]} return
5460 set l
[expr {$selectedline + $dir}]
5465 proc selnextpage
{dir
} {
5466 global canv linespc selectedline numcommits
5468 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
5472 allcanvs yview scroll
[expr {$dir * $lpp}] units
5474 if {![info exists selectedline
]} return
5475 set l
[expr {$selectedline + $dir * $lpp}]
5478 } elseif
{$l >= $numcommits} {
5479 set l
[expr $numcommits - 1]
5485 proc unselectline
{} {
5486 global selectedline currentid
5488 catch
{unset selectedline
}
5489 catch
{unset currentid
}
5490 allcanvs delete secsel
5494 proc reselectline
{} {
5497 if {[info exists selectedline
]} {
5498 selectline
$selectedline 0
5502 proc addtohistory
{cmd
} {
5503 global
history historyindex curview
5505 set elt
[list
$curview $cmd]
5506 if {$historyindex > 0
5507 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
5511 if {$historyindex < [llength
$history]} {
5512 set history [lreplace
$history $historyindex end
$elt]
5514 lappend
history $elt
5517 if {$historyindex > 1} {
5518 .tf.bar.leftbut conf
-state normal
5520 .tf.bar.leftbut conf
-state disabled
5522 .tf.bar.rightbut conf
-state disabled
5528 set view
[lindex
$elt 0]
5529 set cmd
[lindex
$elt 1]
5530 if {$curview != $view} {
5537 global
history historyindex
5540 if {$historyindex > 1} {
5541 incr historyindex
-1
5542 godo
[lindex
$history [expr {$historyindex - 1}]]
5543 .tf.bar.rightbut conf
-state normal
5545 if {$historyindex <= 1} {
5546 .tf.bar.leftbut conf
-state disabled
5551 global
history historyindex
5554 if {$historyindex < [llength
$history]} {
5555 set cmd
[lindex
$history $historyindex]
5558 .tf.bar.leftbut conf
-state normal
5560 if {$historyindex >= [llength
$history]} {
5561 .tf.bar.rightbut conf
-state disabled
5566 global treefilelist treeidlist diffids diffmergeid treepending
5567 global nullid nullid2
5570 catch
{unset diffmergeid
}
5571 if {![info exists treefilelist
($id)]} {
5572 if {![info exists treepending
]} {
5573 if {$id eq
$nullid} {
5574 set cmd
[list | git ls-files
]
5575 } elseif
{$id eq
$nullid2} {
5576 set cmd
[list | git ls-files
--stage -t]
5578 set cmd
[list | git ls-tree
-r $id]
5580 if {[catch
{set gtf
[open
$cmd r
]}]} {
5584 set treefilelist
($id) {}
5585 set treeidlist
($id) {}
5586 fconfigure
$gtf -blocking 0
5587 filerun
$gtf [list gettreeline
$gtf $id]
5594 proc gettreeline
{gtf id
} {
5595 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5598 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
5599 if {$diffids eq
$nullid} {
5602 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
5603 set i
[string first
"\t" $line]
5604 if {$i < 0} continue
5605 set sha1
[lindex
$line 2]
5606 set fname
[string range
$line [expr {$i+1}] end
]
5607 if {[string index
$fname 0] eq
"\""} {
5608 set fname
[lindex
$fname 0]
5610 lappend treeidlist
($id) $sha1
5612 lappend treefilelist
($id) $fname
5615 return [expr {$nl >= 1000?
2: 1}]
5619 if {$cmitmode ne
"tree"} {
5620 if {![info exists diffmergeid
]} {
5621 gettreediffs
$diffids
5623 } elseif
{$id ne
$diffids} {
5632 global treefilelist treeidlist diffids nullid nullid2
5633 global ctext commentend
5635 set i
[lsearch
-exact $treefilelist($diffids) $f]
5637 puts
"oops, $f not in list for id $diffids"
5640 if {$diffids eq
$nullid} {
5641 if {[catch
{set bf
[open
$f r
]} err
]} {
5642 puts
"oops, can't read $f: $err"
5646 set blob
[lindex
$treeidlist($diffids) $i]
5647 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5648 puts
"oops, error reading blob $blob: $err"
5652 fconfigure
$bf -blocking 0
5653 filerun
$bf [list getblobline
$bf $diffids]
5654 $ctext config
-state normal
5655 clear_ctext
$commentend
5656 $ctext insert end
"\n"
5657 $ctext insert end
"$f\n" filesep
5658 $ctext config
-state disabled
5659 $ctext yview
$commentend
5663 proc getblobline
{bf id
} {
5664 global diffids cmitmode ctext
5666 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5670 $ctext config
-state normal
5672 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5673 $ctext insert end
"$line\n"
5676 # delete last newline
5677 $ctext delete
"end - 2c" "end - 1c"
5681 $ctext config
-state disabled
5682 return [expr {$nl >= 1000?
2: 1}]
5685 proc mergediff
{id
} {
5686 global diffmergeid mdifffd
5689 global limitdiffs viewfiles curview
5693 # this doesn't seem to actually affect anything...
5694 set cmd
[concat | git diff-tree
--no-commit-id --cc $id]
5695 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5696 set cmd
[concat
$cmd -- $viewfiles($curview)]
5698 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5699 error_popup
"[mc "Error getting merge diffs
:"] $err"
5702 fconfigure
$mdf -blocking 0
5703 set mdifffd
($id) $mdf
5704 set np
[llength
$parents($curview,$id)]
5706 filerun
$mdf [list getmergediffline
$mdf $id $np]
5709 proc getmergediffline
{mdf id np
} {
5710 global diffmergeid ctext cflist mergemax
5711 global difffilestart mdifffd
5713 $ctext conf
-state normal
5715 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5716 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5717 ||
$mdf != $mdifffd($id)} {
5721 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5722 # start of a new file
5723 $ctext insert end
"\n"
5724 set here
[$ctext index
"end - 1c"]
5725 lappend difffilestart
$here
5726 add_flist
[list
$fname]
5727 set l
[expr {(78 - [string length
$fname]) / 2}]
5728 set pad
[string range
"----------------------------------------" 1 $l]
5729 $ctext insert end
"$pad $fname $pad\n" filesep
5730 } elseif
{[regexp
{^@@
} $line]} {
5731 $ctext insert end
"$line\n" hunksep
5732 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5735 # parse the prefix - one ' ', '-' or '+' for each parent
5740 for {set j
0} {$j < $np} {incr j
} {
5741 set c
[string range
$line $j $j]
5744 } elseif
{$c == "-"} {
5746 } elseif
{$c == "+"} {
5755 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5756 # line doesn't appear in result, parents in $minuses have the line
5757 set num
[lindex
$minuses 0]
5758 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5759 # line appears in result, parents in $pluses don't have the line
5760 lappend tags mresult
5761 set num
[lindex
$spaces 0]
5764 if {$num >= $mergemax} {
5769 $ctext insert end
"$line\n" $tags
5772 $ctext conf
-state disabled
5777 return [expr {$nr >= 1000?
2: 1}]
5780 proc startdiff
{ids
} {
5781 global treediffs diffids treepending diffmergeid nullid nullid2
5785 catch
{unset diffmergeid
}
5786 if {![info exists treediffs
($ids)] ||
5787 [lsearch
-exact $ids $nullid] >= 0 ||
5788 [lsearch
-exact $ids $nullid2] >= 0} {
5789 if {![info exists treepending
]} {
5797 proc path_filter
{filter name
} {
5799 set l
[string length
$p]
5800 if {[string index
$p end
] eq
"/"} {
5801 if {[string compare
-length $l $p $name] == 0} {
5805 if {[string compare
-length $l $p $name] == 0 &&
5806 ([string length
$name] == $l ||
5807 [string index
$name $l] eq
"/")} {
5815 proc addtocflist
{ids
} {
5818 add_flist
$treediffs($ids)
5822 proc diffcmd
{ids flags
} {
5823 global nullid nullid2
5825 set i
[lsearch
-exact $ids $nullid]
5826 set j
[lsearch
-exact $ids $nullid2]
5828 if {[llength
$ids] > 1 && $j < 0} {
5829 # comparing working directory with some specific revision
5830 set cmd
[concat | git diff-index
$flags]
5832 lappend cmd
-R [lindex
$ids 1]
5834 lappend cmd
[lindex
$ids 0]
5837 # comparing working directory with index
5838 set cmd
[concat | git diff-files
$flags]
5843 } elseif
{$j >= 0} {
5844 set cmd
[concat | git diff-index
--cached $flags]
5845 if {[llength
$ids] > 1} {
5846 # comparing index with specific revision
5848 lappend cmd
-R [lindex
$ids 1]
5850 lappend cmd
[lindex
$ids 0]
5853 # comparing index with HEAD
5857 set cmd
[concat | git diff-tree
-r $flags $ids]
5862 proc gettreediffs
{ids
} {
5863 global treediff treepending
5865 set treepending
$ids
5867 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5868 fconfigure
$gdtf -blocking 0
5869 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5872 proc gettreediffline
{gdtf ids
} {
5873 global treediff treediffs treepending diffids diffmergeid
5874 global cmitmode viewfiles curview limitdiffs
5877 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5878 set i
[string first
"\t" $line]
5880 set file [string range
$line [expr {$i+1}] end
]
5881 if {[string index
$file 0] eq
"\""} {
5882 set file [lindex
$file 0]
5884 lappend treediff
$file
5888 return [expr {$nr >= 1000?
2: 1}]
5891 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5893 foreach f
$treediff {
5894 if {[path_filter
$viewfiles($curview) $f]} {
5898 set treediffs
($ids) $flist
5900 set treediffs
($ids) $treediff
5903 if {$cmitmode eq
"tree"} {
5905 } elseif
{$ids != $diffids} {
5906 if {![info exists diffmergeid
]} {
5907 gettreediffs
$diffids
5915 # empty string or positive integer
5916 proc diffcontextvalidate
{v
} {
5917 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5920 proc diffcontextchange
{n1 n2 op
} {
5921 global diffcontextstring diffcontext
5923 if {[string is integer
-strict $diffcontextstring]} {
5924 if {$diffcontextstring > 0} {
5925 set diffcontext
$diffcontextstring
5931 proc getblobdiffs
{ids
} {
5932 global blobdifffd diffids env
5933 global diffinhdr treediffs
5935 global limitdiffs viewfiles curview
5937 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5938 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5939 set cmd
[concat
$cmd -- $viewfiles($curview)]
5941 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5942 puts
"error getting diffs: $err"
5946 fconfigure
$bdf -blocking 0
5947 set blobdifffd
($ids) $bdf
5948 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5951 proc setinlist
{var i val
} {
5954 while {[llength
[set $var]] < $i} {
5957 if {[llength
[set $var]] == $i} {
5964 proc makediffhdr
{fname ids
} {
5965 global ctext curdiffstart treediffs
5967 set i
[lsearch
-exact $treediffs($ids) $fname]
5969 setinlist difffilestart
$i $curdiffstart
5971 set l
[expr {(78 - [string length
$fname]) / 2}]
5972 set pad
[string range
"----------------------------------------" 1 $l]
5973 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
5976 proc getblobdiffline
{bdf ids
} {
5977 global diffids blobdifffd ctext curdiffstart
5978 global diffnexthead diffnextnote difffilestart
5979 global diffinhdr treediffs
5982 $ctext conf
-state normal
5983 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
5984 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
5988 if {![string compare
-length 11 "diff --git " $line]} {
5989 # trim off "diff --git "
5990 set line
[string range
$line 11 end
]
5992 # start of a new file
5993 $ctext insert end
"\n"
5994 set curdiffstart
[$ctext index
"end - 1c"]
5995 $ctext insert end
"\n" filesep
5996 # If the name hasn't changed the length will be odd,
5997 # the middle char will be a space, and the two bits either
5998 # side will be a/name and b/name, or "a/name" and "b/name".
5999 # If the name has changed we'll get "rename from" and
6000 # "rename to" or "copy from" and "copy to" lines following this,
6001 # and we'll use them to get the filenames.
6002 # This complexity is necessary because spaces in the filename(s)
6003 # don't get escaped.
6004 set l
[string length
$line]
6005 set i
[expr {$l / 2}]
6006 if {!(($l & 1) && [string index
$line $i] eq
" " &&
6007 [string range
$line 2 [expr {$i - 1}]] eq \
6008 [string range
$line [expr {$i + 3}] end
])} {
6011 # unescape if quoted and chop off the a/ from the front
6012 if {[string index
$line 0] eq
"\""} {
6013 set fname
[string range
[lindex
$line 0] 2 end
]
6015 set fname
[string range
$line 2 [expr {$i - 1}]]
6017 makediffhdr
$fname $ids
6019 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
6020 $line match f1l f1c f2l f2c rest
]} {
6021 $ctext insert end
"$line\n" hunksep
6024 } elseif
{$diffinhdr} {
6025 if {![string compare
-length 12 "rename from " $line]} {
6026 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
6027 if {[string index
$fname 0] eq
"\""} {
6028 set fname
[lindex
$fname 0]
6030 set i
[lsearch
-exact $treediffs($ids) $fname]
6032 setinlist difffilestart
$i $curdiffstart
6034 } elseif
{![string compare
-length 10 $line "rename to "] ||
6035 ![string compare
-length 8 $line "copy to "]} {
6036 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
6037 if {[string index
$fname 0] eq
"\""} {
6038 set fname
[lindex
$fname 0]
6040 makediffhdr
$fname $ids
6041 } elseif
{[string compare
-length 3 $line "---"] == 0} {
6044 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
6048 $ctext insert end
"$line\n" filesep
6051 set x
[string range
$line 0 0]
6052 if {$x == "-" ||
$x == "+"} {
6053 set tag
[expr {$x == "+"}]
6054 $ctext insert end
"$line\n" d
$tag
6055 } elseif
{$x == " "} {
6056 $ctext insert end
"$line\n"
6058 # "\ No newline at end of file",
6059 # or something else we don't recognize
6060 $ctext insert end
"$line\n" hunksep
6064 $ctext conf
-state disabled
6069 return [expr {$nr >= 1000?
2: 1}]
6072 proc changediffdisp
{} {
6073 global ctext diffelide
6075 $ctext tag conf d0
-elide [lindex
$diffelide 0]
6076 $ctext tag conf d1
-elide [lindex
$diffelide 1]
6080 global difffilestart ctext
6081 set prev
[lindex
$difffilestart 0]
6082 set here
[$ctext index @
0,0]
6083 foreach loc
$difffilestart {
6084 if {[$ctext compare
$loc >= $here]} {
6094 global difffilestart ctext
6095 set here
[$ctext index @
0,0]
6096 foreach loc
$difffilestart {
6097 if {[$ctext compare
$loc > $here]} {
6104 proc clear_ctext
{{first
1.0}} {
6105 global ctext smarktop smarkbot
6108 set l
[lindex
[split $first .
] 0]
6109 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
6112 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
6115 $ctext delete
$first end
6116 if {$first eq
"1.0"} {
6117 catch
{unset pendinglinks
}
6121 proc settabs
{{firstab
{}}} {
6122 global firsttabstop tabstop ctext have_tk85
6124 if {$firstab ne
{} && $have_tk85} {
6125 set firsttabstop
$firstab
6127 set w
[font measure textfont
"0"]
6128 if {$firsttabstop != 0} {
6129 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
6130 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6131 } elseif
{$have_tk85 ||
$tabstop != 8} {
6132 $ctext conf
-tabs [expr {$tabstop * $w}]
6134 $ctext conf
-tabs {}
6138 proc incrsearch
{name ix op
} {
6139 global ctext searchstring searchdirn
6141 $ctext tag remove found
1.0 end
6142 if {[catch
{$ctext index anchor
}]} {
6143 # no anchor set, use start of selection, or of visible area
6144 set sel
[$ctext tag ranges sel
]
6146 $ctext mark
set anchor
[lindex
$sel 0]
6147 } elseif
{$searchdirn eq
"-forwards"} {
6148 $ctext mark
set anchor @
0,0
6150 $ctext mark
set anchor @
0,[winfo height
$ctext]
6153 if {$searchstring ne
{}} {
6154 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
6163 global sstring ctext searchstring searchdirn
6166 $sstring icursor end
6167 set searchdirn
-forwards
6168 if {$searchstring ne
{}} {
6169 set sel
[$ctext tag ranges sel
]
6171 set start
"[lindex $sel 0] + 1c"
6172 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6175 set match
[$ctext search
-count mlen
-- $searchstring $start]
6176 $ctext tag remove sel
1.0 end
6182 set mend
"$match + $mlen c"
6183 $ctext tag add sel
$match $mend
6184 $ctext mark
unset anchor
6188 proc dosearchback
{} {
6189 global sstring ctext searchstring searchdirn
6192 $sstring icursor end
6193 set searchdirn
-backwards
6194 if {$searchstring ne
{}} {
6195 set sel
[$ctext tag ranges sel
]
6197 set start
[lindex
$sel 0]
6198 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6199 set start @
0,[winfo height
$ctext]
6201 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
6202 $ctext tag remove sel
1.0 end
6208 set mend
"$match + $ml c"
6209 $ctext tag add sel
$match $mend
6210 $ctext mark
unset anchor
6214 proc searchmark
{first last
} {
6215 global ctext searchstring
6219 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
6220 if {$match eq
{}} break
6221 set mend
"$match + $mlen c"
6222 $ctext tag add found
$match $mend
6226 proc searchmarkvisible
{doall
} {
6227 global ctext smarktop smarkbot
6229 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
6230 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
6231 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
6232 # no overlap with previous
6233 searchmark
$topline $botline
6234 set smarktop
$topline
6235 set smarkbot
$botline
6237 if {$topline < $smarktop} {
6238 searchmark
$topline [expr {$smarktop-1}]
6239 set smarktop
$topline
6241 if {$botline > $smarkbot} {
6242 searchmark
[expr {$smarkbot+1}] $botline
6243 set smarkbot
$botline
6248 proc scrolltext
{f0 f1
} {
6251 .bleft.sb
set $f0 $f1
6252 if {$searchstring ne
{}} {
6258 global linespc charspc canvx0 canvy0
6259 global xspc1 xspc2 lthickness
6261 set linespc
[font metrics mainfont
-linespace]
6262 set charspc
[font measure mainfont
"m"]
6263 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
6264 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
6265 set lthickness
[expr {int
($linespc / 9) + 1}]
6266 set xspc1
(0) $linespc
6274 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6275 if {$ymax eq
{} ||
$ymax == 0} return
6276 set span
[$canv yview
]
6279 allcanvs yview moveto
[lindex
$span 0]
6281 if {[info exists selectedline
]} {
6282 selectline
$selectedline 0
6283 allcanvs yview moveto
[lindex
$span 0]
6287 proc parsefont
{f n
} {
6290 set fontattr
($f,family
) [lindex
$n 0]
6292 if {$s eq
{} ||
$s == 0} {
6295 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
6297 set fontattr
($f,size
) $s
6298 set fontattr
($f,weight
) normal
6299 set fontattr
($f,slant
) roman
6300 foreach style
[lrange
$n 2 end
] {
6303 "bold" {set fontattr
($f,weight
) $style}
6305 "italic" {set fontattr
($f,slant
) $style}
6310 proc fontflags
{f
{isbold
0}} {
6313 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
6314 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
6315 -slant $fontattr($f,slant
)]
6321 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
6322 if {$fontattr($f,weight
) eq
"bold"} {
6325 if {$fontattr($f,slant
) eq
"italic"} {
6331 proc incrfont
{inc
} {
6332 global mainfont textfont ctext canv cflist showrefstop
6333 global stopped entries fontattr
6336 set s
$fontattr(mainfont
,size
)
6341 set fontattr
(mainfont
,size
) $s
6342 font config mainfont
-size $s
6343 font config mainfontbold
-size $s
6344 set mainfont
[fontname mainfont
]
6345 set s
$fontattr(textfont
,size
)
6350 set fontattr
(textfont
,size
) $s
6351 font config textfont
-size $s
6352 font config textfontbold
-size $s
6353 set textfont
[fontname textfont
]
6360 global sha1entry sha1string
6361 if {[string length
$sha1string] == 40} {
6362 $sha1entry delete
0 end
6366 proc sha1change
{n1 n2 op
} {
6367 global sha1string currentid sha1but
6368 if {$sha1string == {}
6369 ||
([info exists currentid
] && $sha1string == $currentid)} {
6374 if {[$sha1but cget
-state] == $state} return
6375 if {$state == "normal"} {
6376 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
6378 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
6382 proc gotocommit
{} {
6383 global sha1string tagids headids curview varcid
6385 if {$sha1string == {}
6386 ||
([info exists currentid
] && $sha1string == $currentid)} return
6387 if {[info exists tagids
($sha1string)]} {
6388 set id
$tagids($sha1string)
6389 } elseif
{[info exists headids
($sha1string)]} {
6390 set id
$headids($sha1string)
6392 set id
[string tolower
$sha1string]
6393 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
6394 set matches
[array names varcid
"$curview,$id*"]
6395 if {$matches ne
{}} {
6396 if {[llength
$matches] > 1} {
6397 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
6400 set id
[lindex
[split [lindex
$matches 0] ","] 1]
6404 if {[commitinview
$id $curview]} {
6405 selectline
[rowofcommit
$id] 1
6408 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
6409 set msg
[mc
"SHA1 id %s is not known" $sha1string]
6411 set msg
[mc
"Tag/Head %s is not known" $sha1string]
6416 proc lineenter
{x y id
} {
6417 global hoverx hovery hoverid hovertimer
6418 global commitinfo canv
6420 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6424 if {[info exists hovertimer
]} {
6425 after cancel
$hovertimer
6427 set hovertimer
[after
500 linehover
]
6431 proc linemotion
{x y id
} {
6432 global hoverx hovery hoverid hovertimer
6434 if {[info exists hoverid
] && $id == $hoverid} {
6437 if {[info exists hovertimer
]} {
6438 after cancel
$hovertimer
6440 set hovertimer
[after
500 linehover
]
6444 proc lineleave
{id
} {
6445 global hoverid hovertimer canv
6447 if {[info exists hoverid
] && $id == $hoverid} {
6449 if {[info exists hovertimer
]} {
6450 after cancel
$hovertimer
6458 global hoverx hovery hoverid hovertimer
6459 global canv linespc lthickness
6462 set text
[lindex
$commitinfo($hoverid) 0]
6463 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6464 if {$ymax == {}} return
6465 set yfrac
[lindex
[$canv yview
] 0]
6466 set x
[expr {$hoverx + 2 * $linespc}]
6467 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6468 set x0
[expr {$x - 2 * $lthickness}]
6469 set y0
[expr {$y - 2 * $lthickness}]
6470 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
6471 set y1
[expr {$y + $linespc + 2 * $lthickness}]
6472 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
6473 -fill \
#ffff80 -outline black -width 1 -tags hover]
6475 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
6480 proc clickisonarrow
{id y
} {
6483 set ranges
[rowranges
$id]
6484 set thresh
[expr {2 * $lthickness + 6}]
6485 set n
[expr {[llength
$ranges] - 1}]
6486 for {set i
1} {$i < $n} {incr i
} {
6487 set row
[lindex
$ranges $i]
6488 if {abs
([yc
$row] - $y) < $thresh} {
6495 proc arrowjump
{id n y
} {
6498 # 1 <-> 2, 3 <-> 4, etc...
6499 set n
[expr {(($n - 1) ^
1) + 1}]
6500 set row
[lindex
[rowranges
$id] $n]
6502 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6503 if {$ymax eq
{} ||
$ymax <= 0} return
6504 set view
[$canv yview
]
6505 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
6506 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
6510 allcanvs yview moveto
$yfrac
6513 proc lineclick
{x y id isnew
} {
6514 global ctext commitinfo children canv thickerline curview
6516 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6521 # draw this line thicker than normal
6525 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6526 if {$ymax eq
{}} return
6527 set yfrac
[lindex
[$canv yview
] 0]
6528 set y
[expr {$y + $yfrac * $ymax}]
6530 set dirn
[clickisonarrow
$id $y]
6532 arrowjump
$id $dirn $y
6537 addtohistory
[list lineclick
$x $y $id 0]
6539 # fill the details pane with info about this line
6540 $ctext conf
-state normal
6543 $ctext insert end
"[mc "Parent
"]:\t"
6544 $ctext insert end
$id link0
6546 set info
$commitinfo($id)
6547 $ctext insert end
"\n\t[lindex $info 0]\n"
6548 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
6549 set date [formatdate
[lindex
$info 2]]
6550 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
6551 set kids
$children($curview,$id)
6553 $ctext insert end
"\n[mc "Children
"]:"
6555 foreach child
$kids {
6557 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
6558 set info
$commitinfo($child)
6559 $ctext insert end
"\n\t"
6560 $ctext insert end
$child link
$i
6561 setlink
$child link
$i
6562 $ctext insert end
"\n\t[lindex $info 0]"
6563 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
6564 set date [formatdate
[lindex
$info 2]]
6565 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
6568 $ctext conf
-state disabled
6572 proc normalline
{} {
6574 if {[info exists thickerline
]} {
6583 if {[commitinview
$id $curview]} {
6584 selectline
[rowofcommit
$id] 1
6590 if {![info exists startmstime
]} {
6591 set startmstime
[clock clicks
-milliseconds]
6593 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
6596 proc rowmenu
{x y id
} {
6597 global rowctxmenu selectedline rowmenuid curview
6598 global nullid nullid2 fakerowmenu mainhead
6602 if {![info exists selectedline
]
6603 ||
[rowofcommit
$id] eq
$selectedline} {
6608 if {$id ne
$nullid && $id ne
$nullid2} {
6609 set menu
$rowctxmenu
6610 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6612 set menu
$fakerowmenu
6614 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6615 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6616 $menu entryconfigure
[mc
"Make patch"] -state $state
6617 tk_popup
$menu $x $y
6620 proc diffvssel
{dirn
} {
6621 global rowmenuid selectedline
6623 if {![info exists selectedline
]} return
6625 set oldid
[commitonrow
$selectedline]
6626 set newid
$rowmenuid
6628 set oldid
$rowmenuid
6629 set newid
[commitonrow
$selectedline]
6631 addtohistory
[list doseldiff
$oldid $newid]
6632 doseldiff
$oldid $newid
6635 proc doseldiff
{oldid newid
} {
6639 $ctext conf
-state normal
6641 init_flist
[mc
"Top"]
6642 $ctext insert end
"[mc "From
"] "
6643 $ctext insert end
$oldid link0
6644 setlink
$oldid link0
6645 $ctext insert end
"\n "
6646 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6647 $ctext insert end
"\n\n[mc "To
"] "
6648 $ctext insert end
$newid link1
6649 setlink
$newid link1
6650 $ctext insert end
"\n "
6651 $ctext insert end
[lindex
$commitinfo($newid) 0]
6652 $ctext insert end
"\n"
6653 $ctext conf
-state disabled
6654 $ctext tag remove found
1.0 end
6655 startdiff
[list
$oldid $newid]
6659 global rowmenuid currentid commitinfo patchtop patchnum
6661 if {![info exists currentid
]} return
6662 set oldid
$currentid
6663 set oldhead
[lindex
$commitinfo($oldid) 0]
6664 set newid
$rowmenuid
6665 set newhead
[lindex
$commitinfo($newid) 0]
6668 catch
{destroy
$top}
6670 label
$top.title
-text [mc
"Generate patch"]
6671 grid
$top.title
- -pady 10
6672 label
$top.from
-text [mc
"From:"]
6673 entry
$top.fromsha1
-width 40 -relief flat
6674 $top.fromsha1 insert
0 $oldid
6675 $top.fromsha1 conf
-state readonly
6676 grid
$top.from
$top.fromsha1
-sticky w
6677 entry
$top.fromhead
-width 60 -relief flat
6678 $top.fromhead insert
0 $oldhead
6679 $top.fromhead conf
-state readonly
6680 grid x
$top.fromhead
-sticky w
6681 label
$top.to
-text [mc
"To:"]
6682 entry
$top.tosha1
-width 40 -relief flat
6683 $top.tosha1 insert
0 $newid
6684 $top.tosha1 conf
-state readonly
6685 grid
$top.to
$top.tosha1
-sticky w
6686 entry
$top.tohead
-width 60 -relief flat
6687 $top.tohead insert
0 $newhead
6688 $top.tohead conf
-state readonly
6689 grid x
$top.tohead
-sticky w
6690 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6691 grid
$top.
rev x
-pady 10
6692 label
$top.flab
-text [mc
"Output file:"]
6693 entry
$top.fname
-width 60
6694 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6696 grid
$top.flab
$top.fname
-sticky w
6698 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6699 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6700 grid
$top.buts.gen
$top.buts.can
6701 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6702 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6703 grid
$top.buts
- -pady 10 -sticky ew
6707 proc mkpatchrev
{} {
6710 set oldid
[$patchtop.fromsha1 get
]
6711 set oldhead
[$patchtop.fromhead get
]
6712 set newid
[$patchtop.tosha1 get
]
6713 set newhead
[$patchtop.tohead get
]
6714 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6715 v
[list
$newid $newhead $oldid $oldhead] {
6716 $patchtop.
$e conf
-state normal
6717 $patchtop.
$e delete
0 end
6718 $patchtop.
$e insert
0 $v
6719 $patchtop.
$e conf
-state readonly
6724 global patchtop nullid nullid2
6726 set oldid
[$patchtop.fromsha1 get
]
6727 set newid
[$patchtop.tosha1 get
]
6728 set fname
[$patchtop.fname get
]
6729 set cmd
[diffcmd
[list
$oldid $newid] -p]
6730 # trim off the initial "|"
6731 set cmd
[lrange
$cmd 1 end
]
6732 lappend cmd
>$fname &
6733 if {[catch
{eval exec $cmd} err
]} {
6734 error_popup
"[mc "Error creating
patch:"] $err"
6736 catch
{destroy
$patchtop}
6740 proc mkpatchcan
{} {
6743 catch
{destroy
$patchtop}
6748 global rowmenuid mktagtop commitinfo
6752 catch
{destroy
$top}
6754 label
$top.title
-text [mc
"Create tag"]
6755 grid
$top.title
- -pady 10
6756 label
$top.id
-text [mc
"ID:"]
6757 entry
$top.sha1
-width 40 -relief flat
6758 $top.sha1 insert
0 $rowmenuid
6759 $top.sha1 conf
-state readonly
6760 grid
$top.id
$top.sha1
-sticky w
6761 entry
$top.
head -width 60 -relief flat
6762 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6763 $top.
head conf
-state readonly
6764 grid x
$top.
head -sticky w
6765 label
$top.tlab
-text [mc
"Tag name:"]
6766 entry
$top.tag
-width 60
6767 grid
$top.tlab
$top.tag
-sticky w
6769 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6770 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6771 grid
$top.buts.gen
$top.buts.can
6772 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6773 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6774 grid
$top.buts
- -pady 10 -sticky ew
6779 global mktagtop env tagids idtags
6781 set id
[$mktagtop.sha1 get
]
6782 set tag
[$mktagtop.tag get
]
6784 error_popup
[mc
"No tag name specified"]
6787 if {[info exists tagids
($tag)]} {
6788 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6793 set fname
[file join $dir "refs/tags" $tag]
6794 set f
[open
$fname w
]
6798 error_popup
"[mc "Error creating tag
:"] $err"
6802 set tagids
($tag) $id
6803 lappend idtags
($id) $tag
6810 proc redrawtags
{id
} {
6811 global canv linehtag idpos currentid curview
6812 global canvxmax iddrawn
6814 if {![commitinview
$id $curview]} return
6815 if {![info exists iddrawn
($id)]} return
6816 set row
[rowofcommit
$id]
6817 $canv delete tag.
$id
6818 set xt
[eval drawtags
$id $idpos($id)]
6819 $canv coords
$linehtag($row) $xt [lindex
$idpos($id) 2]
6820 set text
[$canv itemcget
$linehtag($row) -text]
6821 set font
[$canv itemcget
$linehtag($row) -font]
6822 set xr
[expr {$xt + [font measure
$font $text]}]
6823 if {$xr > $canvxmax} {
6827 if {[info exists currentid
] && $currentid == $id} {
6835 catch
{destroy
$mktagtop}
6844 proc writecommit
{} {
6845 global rowmenuid wrcomtop commitinfo wrcomcmd
6847 set top .writecommit
6849 catch
{destroy
$top}
6851 label
$top.title
-text [mc
"Write commit to file"]
6852 grid
$top.title
- -pady 10
6853 label
$top.id
-text [mc
"ID:"]
6854 entry
$top.sha1
-width 40 -relief flat
6855 $top.sha1 insert
0 $rowmenuid
6856 $top.sha1 conf
-state readonly
6857 grid
$top.id
$top.sha1
-sticky w
6858 entry
$top.
head -width 60 -relief flat
6859 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6860 $top.
head conf
-state readonly
6861 grid x
$top.
head -sticky w
6862 label
$top.clab
-text [mc
"Command:"]
6863 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6864 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6865 label
$top.flab
-text [mc
"Output file:"]
6866 entry
$top.fname
-width 60
6867 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6868 grid
$top.flab
$top.fname
-sticky w
6870 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6871 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6872 grid
$top.buts.gen
$top.buts.can
6873 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6874 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6875 grid
$top.buts
- -pady 10 -sticky ew
6882 set id
[$wrcomtop.sha1 get
]
6883 set cmd
"echo $id | [$wrcomtop.cmd get]"
6884 set fname
[$wrcomtop.fname get
]
6885 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6886 error_popup
"[mc "Error writing commit
:"] $err"
6888 catch
{destroy
$wrcomtop}
6895 catch
{destroy
$wrcomtop}
6900 global rowmenuid mkbrtop
6903 catch
{destroy
$top}
6905 label
$top.title
-text [mc
"Create new branch"]
6906 grid
$top.title
- -pady 10
6907 label
$top.id
-text [mc
"ID:"]
6908 entry
$top.sha1
-width 40 -relief flat
6909 $top.sha1 insert
0 $rowmenuid
6910 $top.sha1 conf
-state readonly
6911 grid
$top.id
$top.sha1
-sticky w
6912 label
$top.nlab
-text [mc
"Name:"]
6913 entry
$top.name
-width 40
6914 grid
$top.nlab
$top.name
-sticky w
6916 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6917 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6918 grid
$top.buts.go
$top.buts.can
6919 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6920 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6921 grid
$top.buts
- -pady 10 -sticky ew
6926 global headids idheads
6928 set name
[$top.name get
]
6929 set id
[$top.sha1 get
]
6931 error_popup
[mc
"Please specify a name for the new branch"]
6934 catch
{destroy
$top}
6938 exec git branch
$name $id
6943 set headids
($name) $id
6944 lappend idheads
($id) $name
6953 proc cherrypick
{} {
6954 global rowmenuid curview
6957 set oldhead
[exec git rev-parse HEAD
]
6958 set dheads
[descheads
$rowmenuid]
6959 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
6960 set ok
[confirm_popup
[mc
"Commit %s is already\
6961 included in branch %s -- really re-apply it?" \
6962 [string range
$rowmenuid 0 7] $mainhead]]
6965 nowbusy cherrypick
[mc
"Cherry-picking"]
6967 # Unfortunately git-cherry-pick writes stuff to stderr even when
6968 # no error occurs, and exec takes that as an indication of error...
6969 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
6974 set newhead
[exec git rev-parse HEAD
]
6975 if {$newhead eq
$oldhead} {
6977 error_popup
[mc
"No changes committed"]
6980 addnewchild
$newhead $oldhead
6981 if {[commitinview
$oldhead $curview]} {
6982 insertrow
$newhead $oldhead $curview
6983 if {$mainhead ne
{}} {
6984 movehead
$newhead $mainhead
6985 movedhead
$newhead $mainhead
6994 global mainheadid mainhead rowmenuid confirm_ok resettype
6997 set w
".confirmreset"
7000 wm title
$w [mc
"Confirm reset"]
7001 message
$w.m
-text \
7002 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
7003 -justify center
-aspect 1000
7004 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
7005 frame
$w.f
-relief sunken
-border 2
7006 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
7007 grid
$w.f.rt
-sticky w
7009 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
7010 -text [mc
"Soft: Leave working tree and index untouched"]
7011 grid
$w.f.soft
-sticky w
7012 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
7013 -text [mc
"Mixed: Leave working tree untouched, reset index"]
7014 grid
$w.f.mixed
-sticky w
7015 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
7016 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
7017 grid
$w.f.hard
-sticky w
7018 pack
$w.f
-side top
-fill x
7019 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
7020 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
7021 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
7022 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
7023 bind $w <Visibility
> "grab $w; focus $w"
7025 if {!$confirm_ok} return
7026 if {[catch
{set fd
[open \
7027 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
7031 filerun
$fd [list readresetstat
$fd]
7032 nowbusy
reset [mc
"Resetting"]
7036 proc readresetstat
{fd
} {
7037 global mainhead mainheadid showlocalchanges rprogcoord
7039 if {[gets
$fd line
] >= 0} {
7040 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
7041 set rprogcoord
[expr {1.0 * $m / $n}]
7049 if {[catch
{close
$fd} err
]} {
7052 set oldhead
$mainheadid
7053 set newhead
[exec git rev-parse HEAD
]
7054 if {$newhead ne
$oldhead} {
7055 movehead
$newhead $mainhead
7056 movedhead
$newhead $mainhead
7057 set mainheadid
$newhead
7061 if {$showlocalchanges} {
7067 # context menu for a head
7068 proc headmenu
{x y id
head} {
7069 global headmenuid headmenuhead headctxmenu mainhead
7073 set headmenuhead
$head
7075 if {$head eq
$mainhead} {
7078 $headctxmenu entryconfigure
0 -state $state
7079 $headctxmenu entryconfigure
1 -state $state
7080 tk_popup
$headctxmenu $x $y
7084 global headmenuid headmenuhead mainhead headids
7085 global showlocalchanges mainheadid
7087 # check the tree is clean first??
7088 set oldmainhead
$mainhead
7089 nowbusy checkout
[mc
"Checking out"]
7093 exec git checkout
-q $headmenuhead
7099 set mainhead
$headmenuhead
7100 set mainheadid
$headmenuid
7101 if {[info exists headids
($oldmainhead)]} {
7102 redrawtags
$headids($oldmainhead)
7104 redrawtags
$headmenuid
7106 if {$showlocalchanges} {
7112 global headmenuid headmenuhead mainhead
7115 set head $headmenuhead
7117 # this check shouldn't be needed any more...
7118 if {$head eq
$mainhead} {
7119 error_popup
[mc
"Cannot delete the currently checked-out branch"]
7122 set dheads
[descheads
$id]
7123 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
7124 # the stuff on this branch isn't on any other branch
7125 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
7126 branch.\nReally delete branch %s?" $head $head]]} return
7130 if {[catch
{exec git branch
-D $head} err
]} {
7135 removehead
$id $head
7136 removedhead
$id $head
7143 # Display a list of tags and heads
7145 global showrefstop bgcolor fgcolor selectbgcolor
7146 global bglist fglist reflistfilter reflist maincursor
7149 set showrefstop
$top
7150 if {[winfo exists
$top]} {
7156 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
7157 text
$top.list
-background $bgcolor -foreground $fgcolor \
7158 -selectbackground $selectbgcolor -font mainfont \
7159 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7160 -width 30 -height 20 -cursor $maincursor \
7161 -spacing1 1 -spacing3 1 -state disabled
7162 $top.list tag configure highlight
-background $selectbgcolor
7163 lappend bglist
$top.list
7164 lappend fglist
$top.list
7165 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
7166 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
7167 grid
$top.list
$top.ysb
-sticky nsew
7168 grid
$top.xsb x
-sticky ew
7170 label
$top.f.l
-text "[mc "Filter
"]: " -font uifont
7171 entry
$top.f.e
-width 20 -textvariable reflistfilter
-font uifont
7172 set reflistfilter
"*"
7173 trace add variable reflistfilter
write reflistfilter_change
7174 pack
$top.f.e
-side right
-fill x
-expand 1
7175 pack
$top.f.l
-side left
7176 grid
$top.f
- -sticky ew
-pady 2
7177 button
$top.close
-command [list destroy
$top] -text [mc
"Close"] \
7180 grid columnconfigure
$top 0 -weight 1
7181 grid rowconfigure
$top 0 -weight 1
7182 bind $top.list
<1> {break}
7183 bind $top.list
<B1-Motion
> {break}
7184 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
7189 proc sel_reflist
{w x y
} {
7190 global showrefstop reflist headids tagids otherrefids
7192 if {![winfo exists
$showrefstop]} return
7193 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
7194 set ref
[lindex
$reflist [expr {$l-1}]]
7195 set n
[lindex
$ref 0]
7196 switch
-- [lindex
$ref 1] {
7197 "H" {selbyid
$headids($n)}
7198 "T" {selbyid
$tagids($n)}
7199 "o" {selbyid
$otherrefids($n)}
7201 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
7204 proc unsel_reflist
{} {
7207 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7208 $showrefstop.list tag remove highlight
0.0 end
7211 proc reflistfilter_change
{n1 n2 op
} {
7212 global reflistfilter
7214 after cancel refill_reflist
7215 after
200 refill_reflist
7218 proc refill_reflist
{} {
7219 global reflist reflistfilter showrefstop headids tagids otherrefids
7220 global curview commitinterest
7222 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7224 foreach n
[array names headids
] {
7225 if {[string match
$reflistfilter $n]} {
7226 if {[commitinview
$headids($n) $curview]} {
7227 lappend refs
[list
$n H
]
7229 set commitinterest
($headids($n)) {run refill_reflist
}
7233 foreach n
[array names tagids
] {
7234 if {[string match
$reflistfilter $n]} {
7235 if {[commitinview
$tagids($n) $curview]} {
7236 lappend refs
[list
$n T
]
7238 set commitinterest
($tagids($n)) {run refill_reflist
}
7242 foreach n
[array names otherrefids
] {
7243 if {[string match
$reflistfilter $n]} {
7244 if {[commitinview
$otherrefids($n) $curview]} {
7245 lappend refs
[list
$n o
]
7247 set commitinterest
($otherrefids($n)) {run refill_reflist
}
7251 set refs
[lsort
-index 0 $refs]
7252 if {$refs eq
$reflist} return
7254 # Update the contents of $showrefstop.list according to the
7255 # differences between $reflist (old) and $refs (new)
7256 $showrefstop.list conf
-state normal
7257 $showrefstop.list insert end
"\n"
7260 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
7261 if {$i < [llength
$reflist]} {
7262 if {$j < [llength
$refs]} {
7263 set cmp [string compare
[lindex
$reflist $i 0] \
7264 [lindex
$refs $j 0]]
7266 set cmp [string compare
[lindex
$reflist $i 1] \
7267 [lindex
$refs $j 1]]
7277 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
7285 set l
[expr {$j + 1}]
7286 $showrefstop.list image create
$l.0 -align baseline \
7287 -image reficon-
[lindex
$refs $j 1] -padx 2
7288 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
7294 # delete last newline
7295 $showrefstop.list delete end-2c end-1c
7296 $showrefstop.list conf
-state disabled
7299 # Stuff for finding nearby tags
7300 proc getallcommits
{} {
7301 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7302 global idheads idtags idotherrefs allparents tagobjid
7304 if {![info exists allcommits
]} {
7310 set allccache
[file join [gitdir
] "gitk.cache"]
7312 set f
[open
$allccache r
]
7321 set cmd
[list | git rev-list
--parents]
7322 set allcupdate
[expr {$seeds ne
{}}]
7326 set refs
[concat
[array names idheads
] [array names idtags
] \
7327 [array names idotherrefs
]]
7330 foreach name
[array names tagobjid
] {
7331 lappend tagobjs
$tagobjid($name)
7333 foreach id
[lsort
-unique $refs] {
7334 if {![info exists allparents
($id)] &&
7335 [lsearch
-exact $tagobjs $id] < 0} {
7346 set fd
[open
[concat
$cmd $ids] r
]
7347 fconfigure
$fd -blocking 0
7350 filerun
$fd [list getallclines
$fd]
7356 # Since most commits have 1 parent and 1 child, we group strings of
7357 # such commits into "arcs" joining branch/merge points (BMPs), which
7358 # are commits that either don't have 1 parent or don't have 1 child.
7360 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7361 # arcout(id) - outgoing arcs for BMP
7362 # arcids(a) - list of IDs on arc including end but not start
7363 # arcstart(a) - BMP ID at start of arc
7364 # arcend(a) - BMP ID at end of arc
7365 # growing(a) - arc a is still growing
7366 # arctags(a) - IDs out of arcids (excluding end) that have tags
7367 # archeads(a) - IDs out of arcids (excluding end) that have heads
7368 # The start of an arc is at the descendent end, so "incoming" means
7369 # coming from descendents, and "outgoing" means going towards ancestors.
7371 proc getallclines
{fd
} {
7372 global allparents allchildren idtags idheads nextarc
7373 global arcnos arcids arctags arcout arcend arcstart archeads growing
7374 global seeds allcommits cachedarcs allcupdate
7377 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
7378 set id
[lindex
$line 0]
7379 if {[info exists allparents
($id)]} {
7384 set olds
[lrange
$line 1 end
]
7385 set allparents
($id) $olds
7386 if {![info exists allchildren
($id)]} {
7387 set allchildren
($id) {}
7392 if {[llength
$olds] == 1 && [llength
$a] == 1} {
7393 lappend arcids
($a) $id
7394 if {[info exists idtags
($id)]} {
7395 lappend arctags
($a) $id
7397 if {[info exists idheads
($id)]} {
7398 lappend archeads
($a) $id
7400 if {[info exists allparents
($olds)]} {
7401 # seen parent already
7402 if {![info exists arcout
($olds)]} {
7405 lappend arcids
($a) $olds
7406 set arcend
($a) $olds
7409 lappend allchildren
($olds) $id
7410 lappend arcnos
($olds) $a
7414 foreach a
$arcnos($id) {
7415 lappend arcids
($a) $id
7422 lappend allchildren
($p) $id
7423 set a
[incr nextarc
]
7424 set arcstart
($a) $id
7431 if {[info exists allparents
($p)]} {
7432 # seen it already, may need to make a new branch
7433 if {![info exists arcout
($p)]} {
7436 lappend arcids
($a) $p
7440 lappend arcnos
($p) $a
7445 global cached_dheads cached_dtags cached_atags
7446 catch
{unset cached_dheads
}
7447 catch
{unset cached_dtags
}
7448 catch
{unset cached_atags
}
7451 return [expr {$nid >= 1000?
2: 1}]
7455 fconfigure
$fd -blocking 1
7458 # got an error reading the list of commits
7459 # if we were updating, try rereading the whole thing again
7465 error_popup
"[mc "Error reading commit topology information
;\
7466 branch and preceding
/following tag information\
7467 will be incomplete.
"]\n($err)"
7470 if {[incr allcommits
-1] == 0} {
7480 proc recalcarc
{a
} {
7481 global arctags archeads arcids idtags idheads
7485 foreach id
[lrange
$arcids($a) 0 end-1
] {
7486 if {[info exists idtags
($id)]} {
7489 if {[info exists idheads
($id)]} {
7494 set archeads
($a) $ah
7498 global arcnos arcids nextarc arctags archeads idtags idheads
7499 global arcstart arcend arcout allparents growing
7502 if {[llength
$a] != 1} {
7503 puts
"oops splitarc called but [llength $a] arcs already"
7507 set i
[lsearch
-exact $arcids($a) $p]
7509 puts
"oops splitarc $p not in arc $a"
7512 set na
[incr nextarc
]
7513 if {[info exists arcend
($a)]} {
7514 set arcend
($na) $arcend($a)
7516 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
7517 set j
[lsearch
-exact $arcnos($l) $a]
7518 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
7520 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
7521 set arcids
($a) [lrange
$arcids($a) 0 $i]
7523 set arcstart
($na) $p
7525 set arcids
($na) $tail
7526 if {[info exists growing
($a)]} {
7532 if {[llength
$arcnos($id)] == 1} {
7535 set j
[lsearch
-exact $arcnos($id) $a]
7536 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
7540 # reconstruct tags and heads lists
7541 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
7546 set archeads
($na) {}
7550 # Update things for a new commit added that is a child of one
7551 # existing commit. Used when cherry-picking.
7552 proc addnewchild
{id p
} {
7553 global allparents allchildren idtags nextarc
7554 global arcnos arcids arctags arcout arcend arcstart archeads growing
7555 global seeds allcommits
7557 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
7558 set allparents
($id) [list
$p]
7559 set allchildren
($id) {}
7562 lappend allchildren
($p) $id
7563 set a
[incr nextarc
]
7564 set arcstart
($a) $id
7567 set arcids
($a) [list
$p]
7569 if {![info exists arcout
($p)]} {
7572 lappend arcnos
($p) $a
7573 set arcout
($id) [list
$a]
7576 # This implements a cache for the topology information.
7577 # The cache saves, for each arc, the start and end of the arc,
7578 # the ids on the arc, and the outgoing arcs from the end.
7579 proc readcache
{f
} {
7580 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7581 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7586 if {$lim - $a > 500} {
7587 set lim
[expr {$a + 500}]
7591 # finish reading the cache and setting up arctags, etc.
7593 if {$line ne
"1"} {error
"bad final version"}
7595 foreach id
[array names idtags
] {
7596 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7597 [llength
$allparents($id)] == 1} {
7598 set a
[lindex
$arcnos($id) 0]
7599 if {$arctags($a) eq
{}} {
7604 foreach id
[array names idheads
] {
7605 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7606 [llength
$allparents($id)] == 1} {
7607 set a
[lindex
$arcnos($id) 0]
7608 if {$archeads($a) eq
{}} {
7613 foreach id
[lsort
-unique $possible_seeds] {
7614 if {$arcnos($id) eq
{}} {
7620 while {[incr a
] <= $lim} {
7622 if {[llength
$line] != 3} {error
"bad line"}
7623 set s
[lindex
$line 0]
7625 lappend arcout
($s) $a
7626 if {![info exists arcnos
($s)]} {
7627 lappend possible_seeds
$s
7630 set e
[lindex
$line 1]
7635 if {![info exists arcout
($e)]} {
7639 set arcids
($a) [lindex
$line 2]
7640 foreach id
$arcids($a) {
7641 lappend allparents
($s) $id
7643 lappend arcnos
($id) $a
7645 if {![info exists allparents
($s)]} {
7646 set allparents
($s) {}
7651 set nextarc
[expr {$a - 1}]
7664 global nextarc cachedarcs possible_seeds
7668 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7669 # make sure it's an integer
7670 set cachedarcs
[expr {int
([lindex
$line 1])}]
7671 if {$cachedarcs < 0} {error
"bad number of arcs"}
7673 set possible_seeds
{}
7681 proc dropcache
{err
} {
7682 global allcwait nextarc cachedarcs seeds
7684 #puts "dropping cache ($err)"
7685 foreach v
{arcnos arcout arcids arcstart arcend growing \
7686 arctags archeads allparents allchildren
} {
7697 proc writecache
{f
} {
7698 global cachearc cachedarcs allccache
7699 global arcstart arcend arcnos arcids arcout
7703 if {$lim - $a > 1000} {
7704 set lim
[expr {$a + 1000}]
7707 while {[incr a
] <= $lim} {
7708 if {[info exists arcend
($a)]} {
7709 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7711 puts
$f [list
$arcstart($a) {} $arcids($a)]
7716 catch
{file delete
$allccache}
7717 #puts "writing cache failed ($err)"
7720 set cachearc
[expr {$a - 1}]
7721 if {$a > $cachedarcs} {
7730 global nextarc cachedarcs cachearc allccache
7732 if {$nextarc == $cachedarcs} return
7734 set cachedarcs
$nextarc
7736 set f
[open
$allccache w
]
7737 puts
$f [list
1 $cachedarcs]
7742 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7743 # or 0 if neither is true.
7744 proc anc_or_desc
{a b
} {
7745 global arcout arcstart arcend arcnos cached_isanc
7747 if {$arcnos($a) eq
$arcnos($b)} {
7748 # Both are on the same arc(s); either both are the same BMP,
7749 # or if one is not a BMP, the other is also not a BMP or is
7750 # the BMP at end of the arc (and it only has 1 incoming arc).
7751 # Or both can be BMPs with no incoming arcs.
7752 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7755 # assert {[llength $arcnos($a)] == 1}
7756 set arc
[lindex
$arcnos($a) 0]
7757 set i
[lsearch
-exact $arcids($arc) $a]
7758 set j
[lsearch
-exact $arcids($arc) $b]
7759 if {$i < 0 ||
$i > $j} {
7766 if {![info exists arcout
($a)]} {
7767 set arc
[lindex
$arcnos($a) 0]
7768 if {[info exists arcend
($arc)]} {
7769 set aend
$arcend($arc)
7773 set a
$arcstart($arc)
7777 if {![info exists arcout
($b)]} {
7778 set arc
[lindex
$arcnos($b) 0]
7779 if {[info exists arcend
($arc)]} {
7780 set bend
$arcend($arc)
7784 set b
$arcstart($arc)
7794 if {[info exists cached_isanc
($a,$bend)]} {
7795 if {$cached_isanc($a,$bend)} {
7799 if {[info exists cached_isanc
($b,$aend)]} {
7800 if {$cached_isanc($b,$aend)} {
7803 if {[info exists cached_isanc
($a,$bend)]} {
7808 set todo
[list
$a $b]
7811 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7812 set x
[lindex
$todo $i]
7813 if {$anc($x) eq
{}} {
7816 foreach arc
$arcnos($x) {
7817 set xd
$arcstart($arc)
7819 set cached_isanc
($a,$bend) 1
7820 set cached_isanc
($b,$aend) 0
7822 } elseif
{$xd eq
$aend} {
7823 set cached_isanc
($b,$aend) 1
7824 set cached_isanc
($a,$bend) 0
7827 if {![info exists anc
($xd)]} {
7828 set anc
($xd) $anc($x)
7830 } elseif
{$anc($xd) ne
$anc($x)} {
7835 set cached_isanc
($a,$bend) 0
7836 set cached_isanc
($b,$aend) 0
7840 # This identifies whether $desc has an ancestor that is
7841 # a growing tip of the graph and which is not an ancestor of $anc
7842 # and returns 0 if so and 1 if not.
7843 # If we subsequently discover a tag on such a growing tip, and that
7844 # turns out to be a descendent of $anc (which it could, since we
7845 # don't necessarily see children before parents), then $desc
7846 # isn't a good choice to display as a descendent tag of
7847 # $anc (since it is the descendent of another tag which is
7848 # a descendent of $anc). Similarly, $anc isn't a good choice to
7849 # display as a ancestor tag of $desc.
7851 proc is_certain
{desc anc
} {
7852 global arcnos arcout arcstart arcend growing problems
7855 if {[llength
$arcnos($anc)] == 1} {
7856 # tags on the same arc are certain
7857 if {$arcnos($desc) eq
$arcnos($anc)} {
7860 if {![info exists arcout
($anc)]} {
7861 # if $anc is partway along an arc, use the start of the arc instead
7862 set a
[lindex
$arcnos($anc) 0]
7863 set anc
$arcstart($a)
7866 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7869 set a
[lindex
$arcnos($desc) 0]
7875 set anclist
[list
$x]
7879 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7880 set x
[lindex
$anclist $i]
7885 foreach a
$arcout($x) {
7886 if {[info exists growing
($a)]} {
7887 if {![info exists growanc
($x)] && $dl($x)} {
7893 if {[info exists dl
($y)]} {
7897 if {![info exists
done($y)]} {
7900 if {[info exists growanc
($x)]} {
7904 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7905 set z
[lindex
$xl $k]
7906 foreach c
$arcout($z) {
7907 if {[info exists arcend
($c)]} {
7909 if {[info exists dl
($v)] && $dl($v)} {
7911 if {![info exists
done($v)]} {
7914 if {[info exists growanc
($v)]} {
7924 } elseif
{$y eq
$anc ||
!$dl($x)} {
7935 foreach x
[array names growanc
] {
7944 proc validate_arctags
{a
} {
7945 global arctags idtags
7949 foreach id
$arctags($a) {
7951 if {![info exists idtags
($id)]} {
7952 set na
[lreplace
$na $i $i]
7959 proc validate_archeads
{a
} {
7960 global archeads idheads
7963 set na
$archeads($a)
7964 foreach id
$archeads($a) {
7966 if {![info exists idheads
($id)]} {
7967 set na
[lreplace
$na $i $i]
7971 set archeads
($a) $na
7974 # Return the list of IDs that have tags that are descendents of id,
7975 # ignoring IDs that are descendents of IDs already reported.
7976 proc desctags
{id
} {
7977 global arcnos arcstart arcids arctags idtags allparents
7978 global growing cached_dtags
7980 if {![info exists allparents
($id)]} {
7983 set t1
[clock clicks
-milliseconds]
7985 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7986 # part-way along an arc; check that arc first
7987 set a
[lindex
$arcnos($id) 0]
7988 if {$arctags($a) ne
{}} {
7990 set i
[lsearch
-exact $arcids($a) $id]
7992 foreach t
$arctags($a) {
7993 set j
[lsearch
-exact $arcids($a) $t]
8001 set id
$arcstart($a)
8002 if {[info exists idtags
($id)]} {
8006 if {[info exists cached_dtags
($id)]} {
8007 return $cached_dtags($id)
8014 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8015 set id
[lindex
$todo $i]
8017 set ta
[info exists hastaggedancestor
($id)]
8021 # ignore tags on starting node
8022 if {!$ta && $i > 0} {
8023 if {[info exists idtags
($id)]} {
8026 } elseif
{[info exists cached_dtags
($id)]} {
8027 set tagloc
($id) $cached_dtags($id)
8031 foreach a
$arcnos($id) {
8033 if {!$ta && $arctags($a) ne
{}} {
8035 if {$arctags($a) ne
{}} {
8036 lappend tagloc
($id) [lindex
$arctags($a) end
]
8039 if {$ta ||
$arctags($a) ne
{}} {
8040 set tomark
[list
$d]
8041 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8042 set dd [lindex
$tomark $j]
8043 if {![info exists hastaggedancestor
($dd)]} {
8044 if {[info exists
done($dd)]} {
8045 foreach b
$arcnos($dd) {
8046 lappend tomark
$arcstart($b)
8048 if {[info exists tagloc
($dd)]} {
8051 } elseif
{[info exists queued
($dd)]} {
8054 set hastaggedancestor
($dd) 1
8058 if {![info exists queued
($d)]} {
8061 if {![info exists hastaggedancestor
($d)]} {
8068 foreach id
[array names tagloc
] {
8069 if {![info exists hastaggedancestor
($id)]} {
8070 foreach t
$tagloc($id) {
8071 if {[lsearch
-exact $tags $t] < 0} {
8077 set t2
[clock clicks
-milliseconds]
8080 # remove tags that are descendents of other tags
8081 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8082 set a
[lindex
$tags $i]
8083 for {set j
0} {$j < $i} {incr j
} {
8084 set b
[lindex
$tags $j]
8085 set r
[anc_or_desc
$a $b]
8087 set tags
[lreplace
$tags $j $j]
8090 } elseif
{$r == -1} {
8091 set tags
[lreplace
$tags $i $i]
8098 if {[array names growing
] ne
{}} {
8099 # graph isn't finished, need to check if any tag could get
8100 # eclipsed by another tag coming later. Simply ignore any
8101 # tags that could later get eclipsed.
8104 if {[is_certain
$t $origid]} {
8108 if {$tags eq
$ctags} {
8109 set cached_dtags
($origid) $tags
8114 set cached_dtags
($origid) $tags
8116 set t3
[clock clicks
-milliseconds]
8117 if {0 && $t3 - $t1 >= 100} {
8118 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
8119 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8125 global arcnos arcids arcout arcend arctags idtags allparents
8126 global growing cached_atags
8128 if {![info exists allparents
($id)]} {
8131 set t1
[clock clicks
-milliseconds]
8133 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8134 # part-way along an arc; check that arc first
8135 set a
[lindex
$arcnos($id) 0]
8136 if {$arctags($a) ne
{}} {
8138 set i
[lsearch
-exact $arcids($a) $id]
8139 foreach t
$arctags($a) {
8140 set j
[lsearch
-exact $arcids($a) $t]
8146 if {![info exists arcend
($a)]} {
8150 if {[info exists idtags
($id)]} {
8154 if {[info exists cached_atags
($id)]} {
8155 return $cached_atags($id)
8163 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8164 set id
[lindex
$todo $i]
8166 set td
[info exists hastaggeddescendent
($id)]
8170 # ignore tags on starting node
8171 if {!$td && $i > 0} {
8172 if {[info exists idtags
($id)]} {
8175 } elseif
{[info exists cached_atags
($id)]} {
8176 set tagloc
($id) $cached_atags($id)
8180 foreach a
$arcout($id) {
8181 if {!$td && $arctags($a) ne
{}} {
8183 if {$arctags($a) ne
{}} {
8184 lappend tagloc
($id) [lindex
$arctags($a) 0]
8187 if {![info exists arcend
($a)]} continue
8189 if {$td ||
$arctags($a) ne
{}} {
8190 set tomark
[list
$d]
8191 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8192 set dd [lindex
$tomark $j]
8193 if {![info exists hastaggeddescendent
($dd)]} {
8194 if {[info exists
done($dd)]} {
8195 foreach b
$arcout($dd) {
8196 if {[info exists arcend
($b)]} {
8197 lappend tomark
$arcend($b)
8200 if {[info exists tagloc
($dd)]} {
8203 } elseif
{[info exists queued
($dd)]} {
8206 set hastaggeddescendent
($dd) 1
8210 if {![info exists queued
($d)]} {
8213 if {![info exists hastaggeddescendent
($d)]} {
8219 set t2
[clock clicks
-milliseconds]
8222 foreach id
[array names tagloc
] {
8223 if {![info exists hastaggeddescendent
($id)]} {
8224 foreach t
$tagloc($id) {
8225 if {[lsearch
-exact $tags $t] < 0} {
8232 # remove tags that are ancestors of other tags
8233 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8234 set a
[lindex
$tags $i]
8235 for {set j
0} {$j < $i} {incr j
} {
8236 set b
[lindex
$tags $j]
8237 set r
[anc_or_desc
$a $b]
8239 set tags
[lreplace
$tags $j $j]
8242 } elseif
{$r == 1} {
8243 set tags
[lreplace
$tags $i $i]
8250 if {[array names growing
] ne
{}} {
8251 # graph isn't finished, need to check if any tag could get
8252 # eclipsed by another tag coming later. Simply ignore any
8253 # tags that could later get eclipsed.
8256 if {[is_certain
$origid $t]} {
8260 if {$tags eq
$ctags} {
8261 set cached_atags
($origid) $tags
8266 set cached_atags
($origid) $tags
8268 set t3
[clock clicks
-milliseconds]
8269 if {0 && $t3 - $t1 >= 100} {
8270 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
8271 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8276 # Return the list of IDs that have heads that are descendents of id,
8277 # including id itself if it has a head.
8278 proc descheads
{id
} {
8279 global arcnos arcstart arcids archeads idheads cached_dheads
8282 if {![info exists allparents
($id)]} {
8286 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8287 # part-way along an arc; check it first
8288 set a
[lindex
$arcnos($id) 0]
8289 if {$archeads($a) ne
{}} {
8290 validate_archeads
$a
8291 set i
[lsearch
-exact $arcids($a) $id]
8292 foreach t
$archeads($a) {
8293 set j
[lsearch
-exact $arcids($a) $t]
8298 set id
$arcstart($a)
8304 for {set i
0} {$i < [llength
$todo]} {incr i
} {
8305 set id
[lindex
$todo $i]
8306 if {[info exists cached_dheads
($id)]} {
8307 set ret
[concat
$ret $cached_dheads($id)]
8309 if {[info exists idheads
($id)]} {
8312 foreach a
$arcnos($id) {
8313 if {$archeads($a) ne
{}} {
8314 validate_archeads
$a
8315 if {$archeads($a) ne
{}} {
8316 set ret
[concat
$ret $archeads($a)]
8320 if {![info exists seen
($d)]} {
8327 set ret
[lsort
-unique $ret]
8328 set cached_dheads
($origid) $ret
8329 return [concat
$ret $aret]
8332 proc addedtag
{id
} {
8333 global arcnos arcout cached_dtags cached_atags
8335 if {![info exists arcnos
($id)]} return
8336 if {![info exists arcout
($id)]} {
8337 recalcarc
[lindex
$arcnos($id) 0]
8339 catch
{unset cached_dtags
}
8340 catch
{unset cached_atags
}
8343 proc addedhead
{hid
head} {
8344 global arcnos arcout cached_dheads
8346 if {![info exists arcnos
($hid)]} return
8347 if {![info exists arcout
($hid)]} {
8348 recalcarc
[lindex
$arcnos($hid) 0]
8350 catch
{unset cached_dheads
}
8353 proc removedhead
{hid
head} {
8354 global cached_dheads
8356 catch
{unset cached_dheads
}
8359 proc movedhead
{hid
head} {
8360 global arcnos arcout cached_dheads
8362 if {![info exists arcnos
($hid)]} return
8363 if {![info exists arcout
($hid)]} {
8364 recalcarc
[lindex
$arcnos($hid) 0]
8366 catch
{unset cached_dheads
}
8369 proc changedrefs
{} {
8370 global cached_dheads cached_dtags cached_atags
8371 global arctags archeads arcnos arcout idheads idtags
8373 foreach id
[concat
[array names idheads
] [array names idtags
]] {
8374 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
8375 set a
[lindex
$arcnos($id) 0]
8376 if {![info exists donearc
($a)]} {
8382 catch
{unset cached_dtags
}
8383 catch
{unset cached_atags
}
8384 catch
{unset cached_dheads
}
8387 proc rereadrefs
{} {
8388 global idtags idheads idotherrefs mainheadid
8390 set refids
[concat
[array names idtags
] \
8391 [array names idheads
] [array names idotherrefs
]]
8392 foreach id
$refids {
8393 if {![info exists ref
($id)]} {
8394 set ref
($id) [listrefs
$id]
8397 set oldmainhead
$mainheadid
8400 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
8401 [array names idheads
] [array names idotherrefs
]]]
8402 foreach id
$refids {
8403 set v
[listrefs
$id]
8404 if {![info exists ref
($id)] ||
$ref($id) != $v ||
8405 ($id eq
$oldmainhead && $id ne
$mainheadid) ||
8406 ($id eq
$mainheadid && $id ne
$oldmainhead)} {
8413 proc listrefs
{id
} {
8414 global idtags idheads idotherrefs
8417 if {[info exists idtags
($id)]} {
8421 if {[info exists idheads
($id)]} {
8425 if {[info exists idotherrefs
($id)]} {
8426 set z
$idotherrefs($id)
8428 return [list
$x $y $z]
8431 proc showtag
{tag isnew
} {
8432 global ctext tagcontents tagids linknum tagobjid
8435 addtohistory
[list showtag
$tag 0]
8437 $ctext conf
-state normal
8441 if {![info exists tagcontents
($tag)]} {
8443 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
8446 if {[info exists tagcontents
($tag)]} {
8447 set text
$tagcontents($tag)
8449 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
8451 appendwithlinks
$text {}
8452 $ctext conf
-state disabled
8463 proc mkfontdisp
{font top
which} {
8464 global fontattr fontpref
$font
8466 set fontpref
($font) [set $font]
8467 button
$top.
${font}but
-text $which -font optionfont \
8468 -command [list choosefont
$font $which]
8469 label
$top.
$font -relief flat
-font $font \
8470 -text $fontattr($font,family
) -justify left
8471 grid x
$top.
${font}but
$top.
$font -sticky w
8474 proc choosefont
{font
which} {
8475 global fontparam fontlist fonttop fontattr
8477 set fontparam
(which) $which
8478 set fontparam
(font
) $font
8479 set fontparam
(family
) [font actual
$font -family]
8480 set fontparam
(size
) $fontattr($font,size
)
8481 set fontparam
(weight
) $fontattr($font,weight
)
8482 set fontparam
(slant
) $fontattr($font,slant
)
8485 if {![winfo exists
$top]} {
8487 eval font config sample
[font actual
$font]
8489 wm title
$top [mc
"Gitk font chooser"]
8490 label
$top.l
-textvariable fontparam
(which) -font uifont
8491 pack
$top.l
-side top
8492 set fontlist
[lsort
[font families
]]
8494 listbox
$top.f.fam
-listvariable fontlist \
8495 -yscrollcommand [list
$top.f.sb
set]
8496 bind $top.f.fam
<<ListboxSelect>> selfontfam
8497 scrollbar $top.f.sb -command [list $top.f.fam yview]
8498 pack $top.f.sb -side right -fill y
8499 pack $top.f.fam -side left -fill both -expand 1
8500 pack $top.f -side top -fill both -expand 1
8502 spinbox $top.g.size -from 4 -to 40 -width 4 \
8503 -textvariable fontparam(size) \
8504 -validatecommand {string is integer -strict %s}
8505 checkbutton $top.g.bold -padx 5 \
8506 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8507 -variable fontparam(weight) -onvalue bold -offvalue normal
8508 checkbutton $top.g.ital -padx 5 \
8509 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8510 -variable fontparam(slant) -onvalue italic -offvalue roman
8511 pack $top.g.size $top.g.bold $top.g.ital -side left
8512 pack $top.g -side top
8513 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8515 $top.c create text 100 25 -anchor center -text $which -font sample \
8516 -fill black -tags text
8517 bind $top.c <Configure> [list centertext $top.c]
8518 pack $top.c -side top -fill x
8520 button $top.buts.ok -text [mc "OK"] -command fontok -default active \
8522 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal \
8524 grid $top.buts.ok $top.buts.can
8525 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8526 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8527 pack $top.buts -side bottom -fill x
8528 trace add variable fontparam write chg_fontparam
8531 $top.c itemconf text -text $which
8533 set i [lsearch -exact $fontlist $fontparam(family)]
8535 $top.f.fam selection set $i
8540 proc centertext {w} {
8541 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8545 global fontparam fontpref prefstop
8547 set f $fontparam(font)
8548 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8549 if {$fontparam(weight) eq "bold"} {
8550 lappend fontpref($f) "bold"
8552 if {$fontparam(slant) eq "italic"} {
8553 lappend fontpref($f) "italic"
8556 $w conf -text $fontparam(family) -font $fontpref($f)
8562 global fonttop fontparam
8564 if {[info exists fonttop]} {
8565 catch {destroy $fonttop}
8566 catch {font delete sample}
8572 proc selfontfam {} {
8573 global fonttop fontparam
8575 set i [$fonttop.f.fam curselection]
8577 set fontparam(family) [$fonttop.f.fam get $i]
8581 proc chg_fontparam {v sub op} {
8584 font config sample -$sub $fontparam($sub)
8588 global maxwidth maxgraphpct
8589 global oldprefs prefstop showneartags showlocalchanges
8590 global bgcolor fgcolor ctext diffcolors selectbgcolor
8591 global uifont tabstop limitdiffs
8595 if {[winfo exists $top]} {
8599 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8600 limitdiffs tabstop} {
8601 set oldprefs($v) [set $v]
8604 wm title $top [mc "Gitk preferences"]
8605 label $top.ldisp -text [mc "Commit list display options"]
8606 $top.ldisp configure -font uifont
8607 grid $top.ldisp - -sticky w -pady 10
8608 label $top.spacer -text " "
8609 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8611 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8612 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8613 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8615 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8616 grid x $top.maxpctl $top.maxpct -sticky w
8617 frame $top.showlocal
8618 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8619 checkbutton $top.showlocal.b -variable showlocalchanges
8620 pack $top.showlocal.b $top.showlocal.l -side left
8621 grid x $top.showlocal -sticky w
8623 label $top.ddisp -text [mc "Diff display options"]
8624 $top.ddisp configure -font uifont
8625 grid $top.ddisp - -sticky w -pady 10
8626 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8627 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8628 grid x $top.tabstopl $top.tabstop -sticky w
8630 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8631 checkbutton $top.ntag.b -variable showneartags
8632 pack $top.ntag.b $top.ntag.l -side left
8633 grid x $top.ntag -sticky w
8635 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8636 checkbutton $top.ldiff.b -variable limitdiffs
8637 pack $top.ldiff.b $top.ldiff.l -side left
8638 grid x $top.ldiff -sticky w
8640 label $top.cdisp -text [mc "Colors: press to choose"]
8641 $top.cdisp configure -font uifont
8642 grid $top.cdisp - -sticky w -pady 10
8643 label $top.bg -padx 40 -relief sunk -background $bgcolor
8644 button $top.bgbut -text [mc "Background"] -font optionfont \
8645 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8646 grid x $top.bgbut $top.bg -sticky w
8647 label $top.fg -padx 40 -relief sunk -background $fgcolor
8648 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8649 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8650 grid x $top.fgbut $top.fg -sticky w
8651 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8652 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8653 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8654 [list $ctext tag conf d0 -foreground]]
8655 grid x $top.diffoldbut $top.diffold -sticky w
8656 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8657 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8658 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8659 [list $ctext tag conf d1 -foreground]]
8660 grid x $top.diffnewbut $top.diffnew -sticky w
8661 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8662 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8663 -command [list choosecolor diffcolors 2 $top.hunksep \
8664 "diff hunk header" \
8665 [list $ctext tag conf hunksep -foreground]]
8666 grid x $top.hunksepbut $top.hunksep -sticky w
8667 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8668 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8669 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8670 grid x $top.selbgbut $top.selbgsep -sticky w
8672 label $top.cfont -text [mc "Fonts: press to choose"]
8673 $top.cfont configure -font uifont
8674 grid $top.cfont - -sticky w -pady 10
8675 mkfontdisp mainfont $top [mc "Main font"]
8676 mkfontdisp textfont $top [mc "Diff display font"]
8677 mkfontdisp uifont $top [mc "User interface font"]
8680 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8681 $top.buts.ok configure -font uifont
8682 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8683 $top.buts.can configure -font uifont
8684 grid $top.buts.ok $top.buts.can
8685 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8686 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8687 grid $top.buts - - -pady 10 -sticky ew
8688 bind $top <Visibility> "focus $top.buts.ok"
8691 proc choosecolor {v vi w x cmd} {
8694 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8695 -title [mc "Gitk: choose color for %s" $x]]
8696 if {$c eq {}} return
8697 $w conf -background $c
8703 global bglist cflist
8705 $w configure -selectbackground $c
8707 $cflist tag configure highlight \
8708 -background [$cflist cget -selectbackground]
8709 allcanvs itemconf secsel -fill $c
8716 $w conf -background $c
8724 $w conf -foreground $c
8726 allcanvs itemconf text -fill $c
8727 $canv itemconf circle -outline $c
8731 global oldprefs prefstop
8733 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8734 limitdiffs tabstop} {
8736 set $v $oldprefs($v)
8738 catch {destroy $prefstop}
8744 global maxwidth maxgraphpct
8745 global oldprefs prefstop showneartags showlocalchanges
8746 global fontpref mainfont textfont uifont
8747 global limitdiffs treediffs
8749 catch {destroy $prefstop}
8753 if {$mainfont ne $fontpref(mainfont)} {
8754 set mainfont $fontpref(mainfont)
8755 parsefont mainfont $mainfont
8756 eval font configure mainfont [fontflags mainfont]
8757 eval font configure mainfontbold [fontflags mainfont 1]
8761 if {$textfont ne $fontpref(textfont)} {
8762 set textfont $fontpref(textfont)
8763 parsefont textfont $textfont
8764 eval font configure textfont [fontflags textfont]
8765 eval font configure textfontbold [fontflags textfont 1]
8767 if {$uifont ne $fontpref(uifont)} {
8768 set uifont $fontpref(uifont)
8769 parsefont uifont $uifont
8770 eval font configure uifont [fontflags uifont]
8773 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8774 if {$showlocalchanges} {
8780 if {$limitdiffs != $oldprefs(limitdiffs)} {
8781 # treediffs elements are limited by path
8782 catch {unset treediffs}
8784 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8785 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8787 } elseif {$showneartags != $oldprefs(showneartags) ||
8788 $limitdiffs != $oldprefs(limitdiffs)} {
8793 proc formatdate {d} {
8794 global datetimeformat
8796 set d [clock format $d -format $datetimeformat]
8801 # This list of encoding names and aliases is distilled from
8802 # http://www.iana.org/assignments/character-sets.
8803 # Not all of them are supported by Tcl.
8804 set encoding_aliases {
8805 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8806 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8807 { ISO-10646-UTF-1 csISO10646UTF1 }
8808 { ISO_646.basic:1983 ref csISO646basic1983 }
8809 { INVARIANT csINVARIANT }
8810 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8811 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8812 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8813 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8814 { NATS-DANO iso-ir-9-1 csNATSDANO }
8815 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8816 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8817 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8818 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8819 { ISO-2022-KR csISO2022KR }
8821 { ISO-2022-JP csISO2022JP }
8822 { ISO-2022-JP-2 csISO2022JP2 }
8823 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8825 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8826 { IT iso-ir-15 ISO646-IT csISO15Italian }
8827 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8828 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8829 { greek7-old iso-ir-18 csISO18Greek7Old }
8830 { latin-greek iso-ir-19 csISO19LatinGreek }
8831 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8832 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8833 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8834 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8835 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8836 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8837 { INIS iso-ir-49 csISO49INIS }
8838 { INIS-8 iso-ir-50 csISO50INIS8 }
8839 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8840 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8841 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8842 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8843 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8844 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8846 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8847 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8848 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8849 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8850 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8851 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8852 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8853 { greek7 iso-ir-88 csISO88Greek7 }
8854 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8855 { iso-ir-90 csISO90 }
8856 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8857 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8858 csISO92JISC62991984b }
8859 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8860 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8861 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8862 csISO95JIS62291984handadd }
8863 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8864 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8865 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8866 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8868 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8869 { T.61-7bit iso-ir-102 csISO102T617bit }
8870 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8871 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8872 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8873 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8874 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8875 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8876 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8877 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8878 arabic csISOLatinArabic }
8879 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8880 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8881 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8882 greek greek8 csISOLatinGreek }
8883 { T.101-G2 iso-ir-128 csISO128T101G2 }
8884 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8886 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8887 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8888 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8889 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8890 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8891 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8892 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8893 csISOLatinCyrillic }
8894 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8895 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8896 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8897 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8898 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8899 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8900 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8901 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8902 { ISO_10367-box iso-ir-155 csISO10367Box }
8903 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8904 { latin-lap lap iso-ir-158 csISO158Lap }
8905 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8906 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8909 { JIS_X0201 X0201 csHalfWidthKatakana }
8910 { KSC5636 ISO646-KR csKSC5636 }
8911 { ISO-10646-UCS-2 csUnicode }
8912 { ISO-10646-UCS-4 csUCS4 }
8913 { DEC-MCS dec csDECMCS }
8914 { hp-roman8 roman8 r8 csHPRoman8 }
8915 { macintosh mac csMacintosh }
8916 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8918 { IBM038 EBCDIC-INT cp038 csIBM038 }
8919 { IBM273 CP273 csIBM273 }
8920 { IBM274 EBCDIC-BE CP274 csIBM274 }
8921 { IBM275 EBCDIC-BR cp275 csIBM275 }
8922 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8923 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8924 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8925 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8926 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8927 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8928 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8929 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8930 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8931 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8932 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8933 { IBM437 cp437 437 csPC8CodePage437 }
8934 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8935 { IBM775 cp775 csPC775Baltic }
8936 { IBM850 cp850 850 csPC850Multilingual }
8937 { IBM851 cp851 851 csIBM851 }
8938 { IBM852 cp852 852 csPCp852 }
8939 { IBM855 cp855 855 csIBM855 }
8940 { IBM857 cp857 857 csIBM857 }
8941 { IBM860 cp860 860 csIBM860 }
8942 { IBM861 cp861 861 cp-is csIBM861 }
8943 { IBM862 cp862 862 csPC862LatinHebrew }
8944 { IBM863 cp863 863 csIBM863 }
8945 { IBM864 cp864 csIBM864 }
8946 { IBM865 cp865 865 csIBM865 }
8947 { IBM866 cp866 866 csIBM866 }
8948 { IBM868 CP868 cp-ar csIBM868 }
8949 { IBM869 cp869 869 cp-gr csIBM869 }
8950 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8951 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8952 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8953 { IBM891 cp891 csIBM891 }
8954 { IBM903 cp903 csIBM903 }
8955 { IBM904 cp904 904 csIBBM904 }
8956 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8957 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8958 { IBM1026 CP1026 csIBM1026 }
8959 { EBCDIC-AT-DE csIBMEBCDICATDE }
8960 { EBCDIC-AT-DE-A csEBCDICATDEA }
8961 { EBCDIC-CA-FR csEBCDICCAFR }
8962 { EBCDIC-DK-NO csEBCDICDKNO }
8963 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8964 { EBCDIC-FI-SE csEBCDICFISE }
8965 { EBCDIC-FI-SE-A csEBCDICFISEA }
8966 { EBCDIC-FR csEBCDICFR }
8967 { EBCDIC-IT csEBCDICIT }
8968 { EBCDIC-PT csEBCDICPT }
8969 { EBCDIC-ES csEBCDICES }
8970 { EBCDIC-ES-A csEBCDICESA }
8971 { EBCDIC-ES-S csEBCDICESS }
8972 { EBCDIC-UK csEBCDICUK }
8973 { EBCDIC-US csEBCDICUS }
8974 { UNKNOWN-8BIT csUnknown8BiT }
8975 { MNEMONIC csMnemonic }
8980 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8981 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8982 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8983 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8984 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8985 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8986 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8987 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8988 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8989 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8990 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8991 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8992 { IBM1047 IBM-1047 }
8993 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8994 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8995 { UNICODE-1-1 csUnicode11 }
8998 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8999 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9001 { ISO-8859-15 ISO_8859-15 Latin-9 }
9002 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9003 { GBK CP936 MS936 windows-936 }
9004 { JIS_Encoding csJISEncoding }
9005 { Shift_JIS MS_Kanji csShiftJIS }
9006 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9008 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9009 { ISO-10646-UCS-Basic csUnicodeASCII }
9010 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9011 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9012 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9013 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9014 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9015 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9016 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9017 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9018 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9019 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9020 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9021 { Ventura-US csVenturaUS }
9022 { Ventura-International csVenturaInternational }
9023 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9024 { PC8-Turkish csPC8Turkish }
9025 { IBM-Symbols csIBMSymbols }
9026 { IBM-Thai csIBMThai }
9027 { HP-Legal csHPLegal }
9028 { HP-Pi-font csHPPiFont }
9029 { HP-Math8 csHPMath8 }
9030 { Adobe-Symbol-Encoding csHPPSMath }
9031 { HP-DeskTop csHPDesktop }
9032 { Ventura-Math csVenturaMath }
9033 { Microsoft-Publishing csMicrosoftPublishing }
9034 { Windows-31J csWindows31J }
9039 proc tcl_encoding {enc} {
9040 global encoding_aliases
9041 set names [encoding names]
9042 set lcnames [string tolower $names]
9043 set enc [string tolower $enc]
9044 set i [lsearch -exact $lcnames $enc]
9046 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9047 if {[regsub {^iso[-_]} $enc iso encx]} {
9048 set i [lsearch -exact $lcnames $encx]
9052 foreach l $encoding_aliases {
9053 set ll [string tolower $l]
9054 if {[lsearch -exact $ll $enc] < 0} continue
9055 # look through the aliases for one that tcl knows about
9057 set i [lsearch -exact $lcnames $e]
9059 if {[regsub {^iso[-_]} $e iso ex]} {
9060 set i [lsearch -exact $lcnames $ex]
9069 return [lindex $names $i]
9074 # First check that Tcl/Tk is recent enough
9075 if {[catch {package require Tk 8.4} err]} {
9076 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9077 Gitk requires at least Tcl/Tk 8.4."]
9083 set wrcomcmd "git diff-tree --stdin -p --pretty"
9087 set gitencoding [exec git config --get i18n.commitencoding]
9089 if {$gitencoding == ""} {
9090 set gitencoding "utf-8"
9092 set tclencoding [tcl_encoding $gitencoding]
9093 if {$tclencoding == {}} {
9094 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9097 set mainfont {Helvetica 9}
9098 set textfont {Courier 9}
9099 set uifont {Helvetica 9 bold}
9101 set findmergefiles 0
9109 set cmitmode "patch"
9110 set wrapcomment "none"
9114 set showlocalchanges 1
9116 set datetimeformat "%Y-%m-%d %H:%M:%S"
9118 set colors {green red blue magenta darkgrey brown orange}
9121 set diffcolors {red "#00a000" blue}
9123 set selectbgcolor gray85
9125 ## For msgcat loading, first locate the installation location.
9126 if { [info exists ::env(GITK_MSGSDIR)] } {
9127 ## Msgsdir was manually set in the environment.
9128 set gitk_msgsdir $::env(GITK_MSGSDIR)
9130 ## Let's guess the prefix from argv0.
9131 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9132 set gitk_libdir [file join $gitk_prefix share gitk lib]
9133 set gitk_msgsdir [file join $gitk_libdir msgs]
9137 ## Internationalization (i18n) through msgcat and gettext. See
9138 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9139 package require msgcat
9140 namespace import ::msgcat::mc
9141 ## And eventually load the actual message catalog
9142 ::msgcat::mcload $gitk_msgsdir
9144 catch {source ~/.gitk}
9146 font create optionfont -family sans-serif -size -12
9148 parsefont mainfont $mainfont
9149 eval font create mainfont [fontflags mainfont]
9150 eval font create mainfontbold [fontflags mainfont 1]
9152 parsefont textfont $textfont
9153 eval font create textfont [fontflags textfont]
9154 eval font create textfontbold [fontflags textfont 1]
9156 parsefont uifont $uifont
9157 eval font create uifont [fontflags uifont]
9159 # check that we can find a .git directory somewhere...
9160 if {[catch {set gitdir [gitdir]}]} {
9161 show_error {} . [mc "Cannot find a git repository here."]
9164 if {![file isdirectory $gitdir]} {
9165 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9171 set cmdline_files {}
9176 "-d" { set datemode 1 }
9179 lappend revtreeargs $arg
9182 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9186 lappend revtreeargs $arg
9192 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9193 # no -- on command line, but some arguments (other than -d)
9195 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9196 set cmdline_files [split $f "\n"]
9197 set n [llength $cmdline_files]
9198 set revtreeargs [lrange $revtreeargs 0 end-$n]
9199 # Unfortunately git rev-parse doesn't produce an error when
9200 # something is both a revision and a filename. To be consistent
9201 # with git log and git rev-list, check revtreeargs for filenames.
9202 foreach arg $revtreeargs {
9203 if {[file exists $arg]} {
9204 show_error {} . [mc "Ambiguous argument '%s': both revision\
9210 # unfortunately we get both stdout and stderr in $err,
9211 # so look for "fatal:".
9212 set i [string first "fatal:" $err]
9214 set err [string range $err [expr {$i + 6}] end]
9216 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9222 # find the list of unmerged files
9226 set fd [open "| git ls-files -u" r]
9228 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9231 while {[gets $fd line] >= 0} {
9232 set i [string first "\t" $line]
9233 if {$i < 0} continue
9234 set fname [string range $line [expr {$i+1}] end]
9235 if {[lsearch -exact $mlist $fname] >= 0} continue
9237 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9238 lappend mlist $fname
9243 if {$nr_unmerged == 0} {
9244 show_error {} . [mc "No files selected: --merge specified but\
9245 no files are unmerged."]
9247 show_error {} . [mc "No files selected: --merge specified but\
9248 no unmerged files are within file limit."]
9252 set cmdline_files $mlist
9255 set nullid "0000000000000000000000000000000000000000"
9256 set nullid2 "0000000000000000000000000000000000000001"
9258 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9265 set highlight_paths {}
9267 set searchdirn -forwards
9271 set markingmatches 0
9272 set linkentercount 0
9273 set need_redisplay 0
9280 set selectedhlview [mc "None"]
9281 set highlight_related [mc "None"]
9282 set highlight_files {}
9295 # wait for the window to become visible
9297 wm title . "[file tail $argv0]: [file tail [pwd]]"
9300 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9301 # create a view for the files/dirs specified on the command line
9305 set viewname(1) [mc "Command line"]
9306 set viewfiles(1) $cmdline_files
9307 set viewargs(1) $revtreeargs
9310 .bar.view entryconf [mc "Edit view..."] -state normal
9311 .bar.view entryconf [mc "Delete view"] -state normal
9314 if {[info exists permviews]} {
9315 foreach v $permviews {
9318 set viewname($n) [lindex $v 0]
9319 set viewfiles($n) [lindex $v 1]
9320 set viewargs($n) [lindex $v 2]