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
737 if {[info exists cached_commitrow
($id)]} {
738 return $cached_commitrow($id)
741 if {![info exists varcid
($v,$id)]} {
742 puts
"oops rowofcommit no arc for [shortids $id]"
745 set a
$varcid($v,$id)
746 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
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
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 drawfrac
{f0 f1
} {
4544 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4545 if {$ymax eq
{} ||
$ymax == 0} return
4546 set y0
[expr {int
($f0 * $ymax)}]
4547 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
4548 set y1
[expr {int
($f1 * $ymax)}]
4549 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
4550 drawcommits
$row $endrow
4553 proc drawvisible
{} {
4555 eval drawfrac
[$canv yview
]
4558 proc clear_display
{} {
4559 global iddrawn linesegs need_redisplay nrows_drawn
4560 global vhighlights fhighlights nhighlights rhighlights
4563 catch
{unset iddrawn
}
4564 catch
{unset linesegs
}
4565 catch
{unset vhighlights
}
4566 catch
{unset fhighlights
}
4567 catch
{unset nhighlights
}
4568 catch
{unset rhighlights
}
4569 set need_redisplay
0
4573 proc findcrossings
{id
} {
4574 global rowidlist parentlist numcommits displayorder
4578 foreach
{s e
} [rowranges
$id] {
4579 if {$e >= $numcommits} {
4580 set e
[expr {$numcommits - 1}]
4582 if {$e <= $s} continue
4583 for {set row
$e} {[incr row
-1] >= $s} {} {
4584 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
4586 set olds
[lindex
$parentlist $row]
4587 set kid
[lindex
$displayorder $row]
4588 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
4589 if {$kidx < 0} continue
4590 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
4592 set px
[lsearch
-exact $nextrow $p]
4593 if {$px < 0} continue
4594 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
4595 if {[lsearch
-exact $ccross $p] >= 0} continue
4596 if {$x == $px + ($kidx < $px?
-1: 1)} {
4598 } elseif
{[lsearch
-exact $cross $p] < 0} {
4605 return [concat
$ccross {{}} $cross]
4608 proc assigncolor
{id
} {
4609 global colormap colors nextcolor
4610 global parents children children curview
4612 if {[info exists colormap
($id)]} return
4613 set ncolors
[llength
$colors]
4614 if {[info exists children
($curview,$id)]} {
4615 set kids
$children($curview,$id)
4619 if {[llength
$kids] == 1} {
4620 set child
[lindex
$kids 0]
4621 if {[info exists colormap
($child)]
4622 && [llength
$parents($curview,$child)] == 1} {
4623 set colormap
($id) $colormap($child)
4629 foreach x
[findcrossings
$id] {
4631 # delimiter between corner crossings and other crossings
4632 if {[llength
$badcolors] >= $ncolors - 1} break
4633 set origbad
$badcolors
4635 if {[info exists colormap
($x)]
4636 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
4637 lappend badcolors
$colormap($x)
4640 if {[llength
$badcolors] >= $ncolors} {
4641 set badcolors
$origbad
4643 set origbad
$badcolors
4644 if {[llength
$badcolors] < $ncolors - 1} {
4645 foreach child
$kids {
4646 if {[info exists colormap
($child)]
4647 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
4648 lappend badcolors
$colormap($child)
4650 foreach p
$parents($curview,$child) {
4651 if {[info exists colormap
($p)]
4652 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
4653 lappend badcolors
$colormap($p)
4657 if {[llength
$badcolors] >= $ncolors} {
4658 set badcolors
$origbad
4661 for {set i
0} {$i <= $ncolors} {incr i
} {
4662 set c
[lindex
$colors $nextcolor]
4663 if {[incr nextcolor
] >= $ncolors} {
4666 if {[lsearch
-exact $badcolors $c]} break
4668 set colormap
($id) $c
4671 proc bindline
{t id
} {
4674 $canv bind $t <Enter
> "lineenter %x %y $id"
4675 $canv bind $t <Motion
> "linemotion %x %y $id"
4676 $canv bind $t <Leave
> "lineleave $id"
4677 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4680 proc drawtags
{id x xt y1
} {
4681 global idtags idheads idotherrefs mainhead
4682 global linespc lthickness
4683 global canv rowtextx curview fgcolor bgcolor
4688 if {[info exists idtags
($id)]} {
4689 set marks
$idtags($id)
4690 set ntags
[llength
$marks]
4692 if {[info exists idheads
($id)]} {
4693 set marks
[concat
$marks $idheads($id)]
4694 set nheads
[llength
$idheads($id)]
4696 if {[info exists idotherrefs
($id)]} {
4697 set marks
[concat
$marks $idotherrefs($id)]
4703 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4704 set yt
[expr {$y1 - 0.5 * $linespc}]
4705 set yb
[expr {$yt + $linespc - 1}]
4709 foreach tag
$marks {
4711 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4712 set wid
[font measure mainfontbold
$tag]
4714 set wid
[font measure mainfont
$tag]
4718 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4720 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4721 -width $lthickness -fill black
-tags tag.
$id]
4723 foreach tag
$marks x
$xvals wid
$wvals {
4724 set xl
[expr {$x + $delta}]
4725 set xr
[expr {$x + $delta + $wid + $lthickness}]
4727 if {[incr ntags
-1] >= 0} {
4729 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4730 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4731 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4732 $canv bind $t <1> [list showtag
$tag 1]
4733 set rowtextx
([rowofcommit
$id]) [expr {$xr + $linespc}]
4735 # draw a head or other ref
4736 if {[incr nheads
-1] >= 0} {
4738 if {$tag eq
$mainhead} {
4739 set font mainfontbold
4744 set xl
[expr {$xl - $delta/2}]
4745 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4746 -width 1 -outline black
-fill $col -tags tag.
$id
4747 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4748 set rwid
[font measure mainfont
$remoteprefix]
4749 set xi
[expr {$x + 1}]
4750 set yti
[expr {$yt + 1}]
4751 set xri
[expr {$x + $rwid}]
4752 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4753 -width 0 -fill "#ffddaa" -tags tag.
$id
4756 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4757 -font $font -tags [list tag.
$id text
]]
4759 $canv bind $t <1> [list showtag
$tag 1]
4760 } elseif
{$nheads >= 0} {
4761 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4767 proc xcoord
{i level
ln} {
4768 global canvx0 xspc1 xspc2
4770 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4771 if {$i > 0 && $i == $level} {
4772 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4773 } elseif
{$i > $level} {
4774 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4779 proc show_status
{msg
} {
4783 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4784 -tags text
-fill $fgcolor
4787 # Don't change the text pane cursor if it is currently the hand cursor,
4788 # showing that we are over a sha1 ID link.
4789 proc settextcursor
{c
} {
4790 global ctext curtextcursor
4792 if {[$ctext cget
-cursor] == $curtextcursor} {
4793 $ctext config
-cursor $c
4795 set curtextcursor
$c
4798 proc nowbusy
{what
{name
{}}} {
4799 global isbusy busyname statusw
4801 if {[array names isbusy
] eq
{}} {
4802 . config
-cursor watch
4806 set busyname
($what) $name
4808 $statusw conf
-text $name
4812 proc notbusy
{what
} {
4813 global isbusy maincursor textcursor busyname statusw
4817 if {$busyname($what) ne
{} &&
4818 [$statusw cget
-text] eq
$busyname($what)} {
4819 $statusw conf
-text {}
4822 if {[array names isbusy
] eq
{}} {
4823 . config
-cursor $maincursor
4824 settextcursor
$textcursor
4828 proc findmatches
{f
} {
4829 global findtype findstring
4830 if {$findtype == [mc
"Regexp"]} {
4831 set matches
[regexp
-indices -all -inline $findstring $f]
4834 if {$findtype == [mc
"IgnCase"]} {
4835 set f
[string tolower
$f]
4836 set fs
[string tolower
$fs]
4840 set l
[string length
$fs]
4841 while {[set j
[string first
$fs $f $i]] >= 0} {
4842 lappend matches
[list
$j [expr {$j+$l-1}]]
4843 set i
[expr {$j + $l}]
4849 proc dofind
{{dirn
1} {wrap
1}} {
4850 global findstring findstartline findcurline selectedline numcommits
4851 global gdttype filehighlight fh_serial find_dirn findallowwrap
4853 if {[info exists find_dirn
]} {
4854 if {$find_dirn == $dirn} return
4858 if {$findstring eq
{} ||
$numcommits == 0} return
4859 if {![info exists selectedline
]} {
4860 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4862 set findstartline
$selectedline
4864 set findcurline
$findstartline
4865 nowbusy finding
[mc
"Searching"]
4866 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4867 after cancel do_file_hl
$fh_serial
4868 do_file_hl
$fh_serial
4871 set findallowwrap
$wrap
4875 proc stopfinding
{} {
4876 global find_dirn findcurline fprogcoord
4878 if {[info exists find_dirn
]} {
4888 global commitdata commitinfo numcommits findpattern findloc
4889 global findstartline findcurline findallowwrap
4890 global find_dirn gdttype fhighlights fprogcoord
4891 global curview varcorder vrownum varccommits
4893 if {![info exists find_dirn
]} {
4896 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4899 if {$find_dirn > 0} {
4901 if {$l >= $numcommits} {
4904 if {$l <= $findstartline} {
4905 set lim
[expr {$findstartline + 1}]
4908 set moretodo
$findallowwrap
4915 if {$l >= $findstartline} {
4916 set lim
[expr {$findstartline - 1}]
4919 set moretodo
$findallowwrap
4922 set n
[expr {($lim - $l) * $find_dirn}]
4929 set ai
[bsearch
$vrownum($curview) $l]
4930 set a
[lindex
$varcorder($curview) $ai]
4931 set arow
[lindex
$vrownum($curview) $ai]
4932 set ids
[lindex
$varccommits($curview,$a)]
4933 set arowend
[expr {$arow + [llength
$ids]}]
4934 if {$gdttype eq
[mc
"containing:"]} {
4935 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4936 if {$l < $arow ||
$l >= $arowend} {
4938 set a
[lindex
$varcorder($curview) $ai]
4939 set arow
[lindex
$vrownum($curview) $ai]
4940 set ids
[lindex
$varccommits($curview,$a)]
4941 set arowend
[expr {$arow + [llength
$ids]}]
4943 set id
[lindex
$ids [expr {$l - $arow}]]
4944 # shouldn't happen unless git log doesn't give all the commits...
4945 if {![info exists commitdata
($id)] ||
4946 ![doesmatch
$commitdata($id)]} {
4949 if {![info exists commitinfo
($id)]} {
4952 set info
$commitinfo($id)
4953 foreach f
$info ty
$fldtypes {
4954 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
4963 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4964 if {$l < $arow ||
$l >= $arowend} {
4966 set a
[lindex
$varcorder($curview) $ai]
4967 set arow
[lindex
$vrownum($curview) $ai]
4968 set ids
[lindex
$varccommits($curview,$a)]
4969 set arowend
[expr {$arow + [llength
$ids]}]
4971 set id
[lindex
$ids [expr {$l - $arow}]]
4972 if {![info exists fhighlights
($l)]} {
4973 askfilehighlight
$l $id
4976 set findcurline
[expr {$l - $find_dirn}]
4978 } elseif
{$fhighlights($l)} {
4984 if {$found ||
($domore && !$moretodo)} {
5000 set findcurline
[expr {$l - $find_dirn}]
5002 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
5006 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
5011 proc findselectline
{l
} {
5012 global findloc commentend ctext findcurline markingmatches gdttype
5014 set markingmatches
1
5017 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
5018 # highlight the matches in the comments
5019 set f
[$ctext get
1.0 $commentend]
5020 set matches
[findmatches
$f]
5021 foreach match
$matches {
5022 set start
[lindex
$match 0]
5023 set end
[expr {[lindex
$match 1] + 1}]
5024 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
5030 # mark the bits of a headline or author that match a find string
5031 proc markmatches
{canv l str tag matches font row
} {
5034 set bbox
[$canv bbox
$tag]
5035 set x0
[lindex
$bbox 0]
5036 set y0
[lindex
$bbox 1]
5037 set y1
[lindex
$bbox 3]
5038 foreach match
$matches {
5039 set start
[lindex
$match 0]
5040 set end
[lindex
$match 1]
5041 if {$start > $end} continue
5042 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
5043 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
5044 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
5045 [expr {$x0+$xlen+2}] $y1 \
5046 -outline {} -tags [list match
$l matches
] -fill yellow
]
5048 if {[info exists selectedline
] && $row == $selectedline} {
5049 $canv raise
$t secsel
5054 proc unmarkmatches
{} {
5055 global markingmatches
5057 allcanvs delete matches
5058 set markingmatches
0
5062 proc selcanvline
{w x y
} {
5063 global canv canvy0 ctext linespc
5065 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5066 if {$ymax == {}} return
5067 set yfrac
[lindex
[$canv yview
] 0]
5068 set y
[expr {$y + $yfrac * $ymax}]
5069 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
5074 set xmax
[lindex
[$canv cget
-scrollregion] 2]
5075 set xleft
[expr {[lindex
[$canv xview
] 0] * $xmax}]
5076 if {![info exists rowtextx
($l)] ||
$xleft + $x < $rowtextx($l)} return
5082 proc commit_descriptor
{p
} {
5084 if {![info exists commitinfo
($p)]} {
5088 if {[llength
$commitinfo($p)] > 1} {
5089 set l
[lindex
$commitinfo($p) 0]
5094 # append some text to the ctext widget, and make any SHA1 ID
5095 # that we know about be a clickable link.
5096 proc appendwithlinks
{text tags
} {
5097 global ctext linknum curview pendinglinks
5099 set start
[$ctext index
"end - 1c"]
5100 $ctext insert end
$text $tags
5101 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
5105 set linkid
[string range
$text $s $e]
5107 $ctext tag delete link
$linknum
5108 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
5109 setlink
$linkid link
$linknum
5114 proc setlink
{id lk
} {
5115 global curview ctext pendinglinks commitinterest
5117 if {[commitinview
$id $curview]} {
5118 $ctext tag conf
$lk -foreground blue
-underline 1
5119 $ctext tag
bind $lk <1> [list selectline
[rowofcommit
$id] 1]
5120 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
5121 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
5123 lappend pendinglinks
($id) $lk
5124 lappend commitinterest
($id) {makelink
%I
}
5128 proc makelink
{id
} {
5131 if {![info exists pendinglinks
($id)]} return
5132 foreach lk
$pendinglinks($id) {
5135 unset pendinglinks
($id)
5138 proc linkcursor
{w inc
} {
5139 global linkentercount curtextcursor
5141 if {[incr linkentercount
$inc] > 0} {
5142 $w configure
-cursor hand2
5144 $w configure
-cursor $curtextcursor
5145 if {$linkentercount < 0} {
5146 set linkentercount
0
5151 proc viewnextline
{dir
} {
5155 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5156 set wnow
[$canv yview
]
5157 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5158 set newtop
[expr {$wtop + $dir * $linespc}]
5161 } elseif
{$newtop > $ymax} {
5164 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5167 # add a list of tag or branch names at position pos
5168 # returns the number of names inserted
5169 proc appendrefs
{pos ids var
} {
5170 global ctext linknum curview
$var maxrefs
5172 if {[catch
{$ctext index
$pos}]} {
5175 $ctext conf
-state normal
5176 $ctext delete
$pos "$pos lineend"
5179 foreach tag
[set $var\
($id\
)] {
5180 lappend tags
[list
$tag $id]
5183 if {[llength
$tags] > $maxrefs} {
5184 $ctext insert
$pos "many ([llength $tags])"
5186 set tags
[lsort
-index 0 -decreasing $tags]
5189 set id
[lindex
$ti 1]
5192 $ctext tag delete
$lk
5193 $ctext insert
$pos $sep
5194 $ctext insert
$pos [lindex
$ti 0] $lk
5199 $ctext conf
-state disabled
5200 return [llength
$tags]
5203 # called when we have finished computing the nearby tags
5204 proc dispneartags
{delay
} {
5205 global selectedline currentid showneartags tagphase
5207 if {![info exists selectedline
] ||
!$showneartags} return
5208 after cancel dispnexttag
5210 after
200 dispnexttag
5213 after idle dispnexttag
5218 proc dispnexttag
{} {
5219 global selectedline currentid showneartags tagphase ctext
5221 if {![info exists selectedline
] ||
!$showneartags} return
5222 switch
-- $tagphase {
5224 set dtags
[desctags
$currentid]
5226 appendrefs precedes
$dtags idtags
5230 set atags
[anctags
$currentid]
5232 appendrefs follows
$atags idtags
5236 set dheads
[descheads
$currentid]
5237 if {$dheads ne
{}} {
5238 if {[appendrefs branch
$dheads idheads
] > 1
5239 && [$ctext get
"branch -3c"] eq
"h"} {
5240 # turn "Branch" into "Branches"
5241 $ctext conf
-state normal
5242 $ctext insert
"branch -2c" "es"
5243 $ctext conf
-state disabled
5248 if {[incr tagphase
] <= 2} {
5249 after idle dispnexttag
5253 proc make_secsel
{l
} {
5254 global linehtag linentag linedtag canv canv2 canv3
5256 if {![info exists linehtag
($l)]} return
5258 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
5259 -tags secsel
-fill [$canv cget
-selectbackground]]
5261 $canv2 delete secsel
5262 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
5263 -tags secsel
-fill [$canv2 cget
-selectbackground]]
5265 $canv3 delete secsel
5266 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
5267 -tags secsel
-fill [$canv3 cget
-selectbackground]]
5271 proc selectline
{l isnew
} {
5272 global canv ctext commitinfo selectedline
5273 global canvy0 linespc parents children curview
5274 global currentid sha1entry
5275 global commentend idtags linknum
5276 global mergemax numcommits pending_select
5277 global cmitmode showneartags allcommits
5279 catch
{unset pending_select
}
5284 if {$l < 0 ||
$l >= $numcommits} return
5285 set y
[expr {$canvy0 + $l * $linespc}]
5286 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5287 set ytop
[expr {$y - $linespc - 1}]
5288 set ybot
[expr {$y + $linespc + 1}]
5289 set wnow
[$canv yview
]
5290 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
5291 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
5292 set wh
[expr {$wbot - $wtop}]
5294 if {$ytop < $wtop} {
5295 if {$ybot < $wtop} {
5296 set newtop
[expr {$y - $wh / 2.0}]
5299 if {$newtop > $wtop - $linespc} {
5300 set newtop
[expr {$wtop - $linespc}]
5303 } elseif
{$ybot > $wbot} {
5304 if {$ytop > $wbot} {
5305 set newtop
[expr {$y - $wh / 2.0}]
5307 set newtop
[expr {$ybot - $wh}]
5308 if {$newtop < $wtop + $linespc} {
5309 set newtop
[expr {$wtop + $linespc}]
5313 if {$newtop != $wtop} {
5317 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
5323 set id
[commitonrow
$l]
5325 addtohistory
[list selbyid
$id]
5330 $sha1entry delete
0 end
5331 $sha1entry insert
0 $id
5332 $sha1entry selection from
0
5333 $sha1entry selection to end
5336 $ctext conf
-state normal
5339 set info
$commitinfo($id)
5340 set date [formatdate
[lindex
$info 2]]
5341 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
5342 set date [formatdate
[lindex
$info 4]]
5343 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
5344 if {[info exists idtags
($id)]} {
5345 $ctext insert end
[mc
"Tags:"]
5346 foreach tag
$idtags($id) {
5347 $ctext insert end
" $tag"
5349 $ctext insert end
"\n"
5353 set olds
$parents($curview,$id)
5354 if {[llength
$olds] > 1} {
5357 if {$np >= $mergemax} {
5362 $ctext insert end
"[mc "Parent
"]: " $tag
5363 appendwithlinks
[commit_descriptor
$p] {}
5368 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
5372 foreach c
$children($curview,$id) {
5373 append headers
"[mc "Child
"]: [commit_descriptor $c]"
5376 # make anything that looks like a SHA1 ID be a clickable link
5377 appendwithlinks
$headers {}
5378 if {$showneartags} {
5379 if {![info exists allcommits
]} {
5382 $ctext insert end
"[mc "Branch
"]: "
5383 $ctext mark
set branch
"end -1c"
5384 $ctext mark gravity branch left
5385 $ctext insert end
"\n[mc "Follows
"]: "
5386 $ctext mark
set follows
"end -1c"
5387 $ctext mark gravity follows left
5388 $ctext insert end
"\n[mc "Precedes
"]: "
5389 $ctext mark
set precedes
"end -1c"
5390 $ctext mark gravity precedes left
5391 $ctext insert end
"\n"
5394 $ctext insert end
"\n"
5395 set comment
[lindex
$info 5]
5396 if {[string first
"\r" $comment] >= 0} {
5397 set comment
[string map
{"\r" "\n "} $comment]
5399 appendwithlinks
$comment {comment
}
5401 $ctext tag remove found
1.0 end
5402 $ctext conf
-state disabled
5403 set commentend
[$ctext index
"end - 1c"]
5405 init_flist
[mc
"Comments"]
5406 if {$cmitmode eq
"tree"} {
5408 } elseif
{[llength
$olds] <= 1} {
5415 proc selfirstline
{} {
5420 proc sellastline
{} {
5423 set l
[expr {$numcommits - 1}]
5427 proc selnextline
{dir
} {
5430 if {![info exists selectedline
]} return
5431 set l
[expr {$selectedline + $dir}]
5436 proc selnextpage
{dir
} {
5437 global canv linespc selectedline numcommits
5439 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
5443 allcanvs yview scroll
[expr {$dir * $lpp}] units
5445 if {![info exists selectedline
]} return
5446 set l
[expr {$selectedline + $dir * $lpp}]
5449 } elseif
{$l >= $numcommits} {
5450 set l
[expr $numcommits - 1]
5456 proc unselectline
{} {
5457 global selectedline currentid
5459 catch
{unset selectedline
}
5460 catch
{unset currentid
}
5461 allcanvs delete secsel
5465 proc reselectline
{} {
5468 if {[info exists selectedline
]} {
5469 selectline
$selectedline 0
5473 proc addtohistory
{cmd
} {
5474 global
history historyindex curview
5476 set elt
[list
$curview $cmd]
5477 if {$historyindex > 0
5478 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
5482 if {$historyindex < [llength
$history]} {
5483 set history [lreplace
$history $historyindex end
$elt]
5485 lappend
history $elt
5488 if {$historyindex > 1} {
5489 .tf.bar.leftbut conf
-state normal
5491 .tf.bar.leftbut conf
-state disabled
5493 .tf.bar.rightbut conf
-state disabled
5499 set view
[lindex
$elt 0]
5500 set cmd
[lindex
$elt 1]
5501 if {$curview != $view} {
5508 global
history historyindex
5511 if {$historyindex > 1} {
5512 incr historyindex
-1
5513 godo
[lindex
$history [expr {$historyindex - 1}]]
5514 .tf.bar.rightbut conf
-state normal
5516 if {$historyindex <= 1} {
5517 .tf.bar.leftbut conf
-state disabled
5522 global
history historyindex
5525 if {$historyindex < [llength
$history]} {
5526 set cmd
[lindex
$history $historyindex]
5529 .tf.bar.leftbut conf
-state normal
5531 if {$historyindex >= [llength
$history]} {
5532 .tf.bar.rightbut conf
-state disabled
5537 global treefilelist treeidlist diffids diffmergeid treepending
5538 global nullid nullid2
5541 catch
{unset diffmergeid
}
5542 if {![info exists treefilelist
($id)]} {
5543 if {![info exists treepending
]} {
5544 if {$id eq
$nullid} {
5545 set cmd
[list | git ls-files
]
5546 } elseif
{$id eq
$nullid2} {
5547 set cmd
[list | git ls-files
--stage -t]
5549 set cmd
[list | git ls-tree
-r $id]
5551 if {[catch
{set gtf
[open
$cmd r
]}]} {
5555 set treefilelist
($id) {}
5556 set treeidlist
($id) {}
5557 fconfigure
$gtf -blocking 0
5558 filerun
$gtf [list gettreeline
$gtf $id]
5565 proc gettreeline
{gtf id
} {
5566 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5569 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
5570 if {$diffids eq
$nullid} {
5573 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
5574 set i
[string first
"\t" $line]
5575 if {$i < 0} continue
5576 set sha1
[lindex
$line 2]
5577 set fname
[string range
$line [expr {$i+1}] end
]
5578 if {[string index
$fname 0] eq
"\""} {
5579 set fname
[lindex
$fname 0]
5581 lappend treeidlist
($id) $sha1
5583 lappend treefilelist
($id) $fname
5586 return [expr {$nl >= 1000?
2: 1}]
5590 if {$cmitmode ne
"tree"} {
5591 if {![info exists diffmergeid
]} {
5592 gettreediffs
$diffids
5594 } elseif
{$id ne
$diffids} {
5603 global treefilelist treeidlist diffids nullid nullid2
5604 global ctext commentend
5606 set i
[lsearch
-exact $treefilelist($diffids) $f]
5608 puts
"oops, $f not in list for id $diffids"
5611 if {$diffids eq
$nullid} {
5612 if {[catch
{set bf
[open
$f r
]} err
]} {
5613 puts
"oops, can't read $f: $err"
5617 set blob
[lindex
$treeidlist($diffids) $i]
5618 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5619 puts
"oops, error reading blob $blob: $err"
5623 fconfigure
$bf -blocking 0
5624 filerun
$bf [list getblobline
$bf $diffids]
5625 $ctext config
-state normal
5626 clear_ctext
$commentend
5627 $ctext insert end
"\n"
5628 $ctext insert end
"$f\n" filesep
5629 $ctext config
-state disabled
5630 $ctext yview
$commentend
5634 proc getblobline
{bf id
} {
5635 global diffids cmitmode ctext
5637 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5641 $ctext config
-state normal
5643 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5644 $ctext insert end
"$line\n"
5647 # delete last newline
5648 $ctext delete
"end - 2c" "end - 1c"
5652 $ctext config
-state disabled
5653 return [expr {$nl >= 1000?
2: 1}]
5656 proc mergediff
{id
} {
5657 global diffmergeid mdifffd
5660 global limitdiffs viewfiles curview
5664 # this doesn't seem to actually affect anything...
5665 set cmd
[concat | git diff-tree
--no-commit-id --cc $id]
5666 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5667 set cmd
[concat
$cmd -- $viewfiles($curview)]
5669 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5670 error_popup
"[mc "Error getting merge diffs
:"] $err"
5673 fconfigure
$mdf -blocking 0
5674 set mdifffd
($id) $mdf
5675 set np
[llength
$parents($curview,$id)]
5677 filerun
$mdf [list getmergediffline
$mdf $id $np]
5680 proc getmergediffline
{mdf id np
} {
5681 global diffmergeid ctext cflist mergemax
5682 global difffilestart mdifffd
5684 $ctext conf
-state normal
5686 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5687 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5688 ||
$mdf != $mdifffd($id)} {
5692 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5693 # start of a new file
5694 $ctext insert end
"\n"
5695 set here
[$ctext index
"end - 1c"]
5696 lappend difffilestart
$here
5697 add_flist
[list
$fname]
5698 set l
[expr {(78 - [string length
$fname]) / 2}]
5699 set pad
[string range
"----------------------------------------" 1 $l]
5700 $ctext insert end
"$pad $fname $pad\n" filesep
5701 } elseif
{[regexp
{^@@
} $line]} {
5702 $ctext insert end
"$line\n" hunksep
5703 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5706 # parse the prefix - one ' ', '-' or '+' for each parent
5711 for {set j
0} {$j < $np} {incr j
} {
5712 set c
[string range
$line $j $j]
5715 } elseif
{$c == "-"} {
5717 } elseif
{$c == "+"} {
5726 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5727 # line doesn't appear in result, parents in $minuses have the line
5728 set num
[lindex
$minuses 0]
5729 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5730 # line appears in result, parents in $pluses don't have the line
5731 lappend tags mresult
5732 set num
[lindex
$spaces 0]
5735 if {$num >= $mergemax} {
5740 $ctext insert end
"$line\n" $tags
5743 $ctext conf
-state disabled
5748 return [expr {$nr >= 1000?
2: 1}]
5751 proc startdiff
{ids
} {
5752 global treediffs diffids treepending diffmergeid nullid nullid2
5756 catch
{unset diffmergeid
}
5757 if {![info exists treediffs
($ids)] ||
5758 [lsearch
-exact $ids $nullid] >= 0 ||
5759 [lsearch
-exact $ids $nullid2] >= 0} {
5760 if {![info exists treepending
]} {
5768 proc path_filter
{filter name
} {
5770 set l
[string length
$p]
5771 if {[string index
$p end
] eq
"/"} {
5772 if {[string compare
-length $l $p $name] == 0} {
5776 if {[string compare
-length $l $p $name] == 0 &&
5777 ([string length
$name] == $l ||
5778 [string index
$name $l] eq
"/")} {
5786 proc addtocflist
{ids
} {
5789 add_flist
$treediffs($ids)
5793 proc diffcmd
{ids flags
} {
5794 global nullid nullid2
5796 set i
[lsearch
-exact $ids $nullid]
5797 set j
[lsearch
-exact $ids $nullid2]
5799 if {[llength
$ids] > 1 && $j < 0} {
5800 # comparing working directory with some specific revision
5801 set cmd
[concat | git diff-index
$flags]
5803 lappend cmd
-R [lindex
$ids 1]
5805 lappend cmd
[lindex
$ids 0]
5808 # comparing working directory with index
5809 set cmd
[concat | git diff-files
$flags]
5814 } elseif
{$j >= 0} {
5815 set cmd
[concat | git diff-index
--cached $flags]
5816 if {[llength
$ids] > 1} {
5817 # comparing index with specific revision
5819 lappend cmd
-R [lindex
$ids 1]
5821 lappend cmd
[lindex
$ids 0]
5824 # comparing index with HEAD
5828 set cmd
[concat | git diff-tree
-r $flags $ids]
5833 proc gettreediffs
{ids
} {
5834 global treediff treepending
5836 set treepending
$ids
5838 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5839 fconfigure
$gdtf -blocking 0
5840 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5843 proc gettreediffline
{gdtf ids
} {
5844 global treediff treediffs treepending diffids diffmergeid
5845 global cmitmode viewfiles curview limitdiffs
5848 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5849 set i
[string first
"\t" $line]
5851 set file [string range
$line [expr {$i+1}] end
]
5852 if {[string index
$file 0] eq
"\""} {
5853 set file [lindex
$file 0]
5855 lappend treediff
$file
5859 return [expr {$nr >= 1000?
2: 1}]
5862 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5864 foreach f
$treediff {
5865 if {[path_filter
$viewfiles($curview) $f]} {
5869 set treediffs
($ids) $flist
5871 set treediffs
($ids) $treediff
5874 if {$cmitmode eq
"tree"} {
5876 } elseif
{$ids != $diffids} {
5877 if {![info exists diffmergeid
]} {
5878 gettreediffs
$diffids
5886 # empty string or positive integer
5887 proc diffcontextvalidate
{v
} {
5888 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5891 proc diffcontextchange
{n1 n2 op
} {
5892 global diffcontextstring diffcontext
5894 if {[string is integer
-strict $diffcontextstring]} {
5895 if {$diffcontextstring > 0} {
5896 set diffcontext
$diffcontextstring
5902 proc getblobdiffs
{ids
} {
5903 global blobdifffd diffids env
5904 global diffinhdr treediffs
5906 global limitdiffs viewfiles curview
5908 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5909 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5910 set cmd
[concat
$cmd -- $viewfiles($curview)]
5912 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5913 puts
"error getting diffs: $err"
5917 fconfigure
$bdf -blocking 0
5918 set blobdifffd
($ids) $bdf
5919 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5922 proc setinlist
{var i val
} {
5925 while {[llength
[set $var]] < $i} {
5928 if {[llength
[set $var]] == $i} {
5935 proc makediffhdr
{fname ids
} {
5936 global ctext curdiffstart treediffs
5938 set i
[lsearch
-exact $treediffs($ids) $fname]
5940 setinlist difffilestart
$i $curdiffstart
5942 set l
[expr {(78 - [string length
$fname]) / 2}]
5943 set pad
[string range
"----------------------------------------" 1 $l]
5944 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
5947 proc getblobdiffline
{bdf ids
} {
5948 global diffids blobdifffd ctext curdiffstart
5949 global diffnexthead diffnextnote difffilestart
5950 global diffinhdr treediffs
5953 $ctext conf
-state normal
5954 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
5955 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
5959 if {![string compare
-length 11 "diff --git " $line]} {
5960 # trim off "diff --git "
5961 set line
[string range
$line 11 end
]
5963 # start of a new file
5964 $ctext insert end
"\n"
5965 set curdiffstart
[$ctext index
"end - 1c"]
5966 $ctext insert end
"\n" filesep
5967 # If the name hasn't changed the length will be odd,
5968 # the middle char will be a space, and the two bits either
5969 # side will be a/name and b/name, or "a/name" and "b/name".
5970 # If the name has changed we'll get "rename from" and
5971 # "rename to" or "copy from" and "copy to" lines following this,
5972 # and we'll use them to get the filenames.
5973 # This complexity is necessary because spaces in the filename(s)
5974 # don't get escaped.
5975 set l
[string length
$line]
5976 set i
[expr {$l / 2}]
5977 if {!(($l & 1) && [string index
$line $i] eq
" " &&
5978 [string range
$line 2 [expr {$i - 1}]] eq \
5979 [string range
$line [expr {$i + 3}] end
])} {
5982 # unescape if quoted and chop off the a/ from the front
5983 if {[string index
$line 0] eq
"\""} {
5984 set fname
[string range
[lindex
$line 0] 2 end
]
5986 set fname
[string range
$line 2 [expr {$i - 1}]]
5988 makediffhdr
$fname $ids
5990 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
5991 $line match f1l f1c f2l f2c rest
]} {
5992 $ctext insert end
"$line\n" hunksep
5995 } elseif
{$diffinhdr} {
5996 if {![string compare
-length 12 "rename from " $line]} {
5997 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
5998 if {[string index
$fname 0] eq
"\""} {
5999 set fname
[lindex
$fname 0]
6001 set i
[lsearch
-exact $treediffs($ids) $fname]
6003 setinlist difffilestart
$i $curdiffstart
6005 } elseif
{![string compare
-length 10 $line "rename to "] ||
6006 ![string compare
-length 8 $line "copy to "]} {
6007 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
6008 if {[string index
$fname 0] eq
"\""} {
6009 set fname
[lindex
$fname 0]
6011 makediffhdr
$fname $ids
6012 } elseif
{[string compare
-length 3 $line "---"] == 0} {
6015 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
6019 $ctext insert end
"$line\n" filesep
6022 set x
[string range
$line 0 0]
6023 if {$x == "-" ||
$x == "+"} {
6024 set tag
[expr {$x == "+"}]
6025 $ctext insert end
"$line\n" d
$tag
6026 } elseif
{$x == " "} {
6027 $ctext insert end
"$line\n"
6029 # "\ No newline at end of file",
6030 # or something else we don't recognize
6031 $ctext insert end
"$line\n" hunksep
6035 $ctext conf
-state disabled
6040 return [expr {$nr >= 1000?
2: 1}]
6043 proc changediffdisp
{} {
6044 global ctext diffelide
6046 $ctext tag conf d0
-elide [lindex
$diffelide 0]
6047 $ctext tag conf d1
-elide [lindex
$diffelide 1]
6051 global difffilestart ctext
6052 set prev
[lindex
$difffilestart 0]
6053 set here
[$ctext index @
0,0]
6054 foreach loc
$difffilestart {
6055 if {[$ctext compare
$loc >= $here]} {
6065 global difffilestart ctext
6066 set here
[$ctext index @
0,0]
6067 foreach loc
$difffilestart {
6068 if {[$ctext compare
$loc > $here]} {
6075 proc clear_ctext
{{first
1.0}} {
6076 global ctext smarktop smarkbot
6079 set l
[lindex
[split $first .
] 0]
6080 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
6083 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
6086 $ctext delete
$first end
6087 if {$first eq
"1.0"} {
6088 catch
{unset pendinglinks
}
6092 proc settabs
{{firstab
{}}} {
6093 global firsttabstop tabstop ctext have_tk85
6095 if {$firstab ne
{} && $have_tk85} {
6096 set firsttabstop
$firstab
6098 set w
[font measure textfont
"0"]
6099 if {$firsttabstop != 0} {
6100 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
6101 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6102 } elseif
{$have_tk85 ||
$tabstop != 8} {
6103 $ctext conf
-tabs [expr {$tabstop * $w}]
6105 $ctext conf
-tabs {}
6109 proc incrsearch
{name ix op
} {
6110 global ctext searchstring searchdirn
6112 $ctext tag remove found
1.0 end
6113 if {[catch
{$ctext index anchor
}]} {
6114 # no anchor set, use start of selection, or of visible area
6115 set sel
[$ctext tag ranges sel
]
6117 $ctext mark
set anchor
[lindex
$sel 0]
6118 } elseif
{$searchdirn eq
"-forwards"} {
6119 $ctext mark
set anchor @
0,0
6121 $ctext mark
set anchor @
0,[winfo height
$ctext]
6124 if {$searchstring ne
{}} {
6125 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
6134 global sstring ctext searchstring searchdirn
6137 $sstring icursor end
6138 set searchdirn
-forwards
6139 if {$searchstring ne
{}} {
6140 set sel
[$ctext tag ranges sel
]
6142 set start
"[lindex $sel 0] + 1c"
6143 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6146 set match
[$ctext search
-count mlen
-- $searchstring $start]
6147 $ctext tag remove sel
1.0 end
6153 set mend
"$match + $mlen c"
6154 $ctext tag add sel
$match $mend
6155 $ctext mark
unset anchor
6159 proc dosearchback
{} {
6160 global sstring ctext searchstring searchdirn
6163 $sstring icursor end
6164 set searchdirn
-backwards
6165 if {$searchstring ne
{}} {
6166 set sel
[$ctext tag ranges sel
]
6168 set start
[lindex
$sel 0]
6169 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
6170 set start @
0,[winfo height
$ctext]
6172 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
6173 $ctext tag remove sel
1.0 end
6179 set mend
"$match + $ml c"
6180 $ctext tag add sel
$match $mend
6181 $ctext mark
unset anchor
6185 proc searchmark
{first last
} {
6186 global ctext searchstring
6190 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
6191 if {$match eq
{}} break
6192 set mend
"$match + $mlen c"
6193 $ctext tag add found
$match $mend
6197 proc searchmarkvisible
{doall
} {
6198 global ctext smarktop smarkbot
6200 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
6201 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
6202 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
6203 # no overlap with previous
6204 searchmark
$topline $botline
6205 set smarktop
$topline
6206 set smarkbot
$botline
6208 if {$topline < $smarktop} {
6209 searchmark
$topline [expr {$smarktop-1}]
6210 set smarktop
$topline
6212 if {$botline > $smarkbot} {
6213 searchmark
[expr {$smarkbot+1}] $botline
6214 set smarkbot
$botline
6219 proc scrolltext
{f0 f1
} {
6222 .bleft.sb
set $f0 $f1
6223 if {$searchstring ne
{}} {
6229 global linespc charspc canvx0 canvy0
6230 global xspc1 xspc2 lthickness
6232 set linespc
[font metrics mainfont
-linespace]
6233 set charspc
[font measure mainfont
"m"]
6234 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
6235 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
6236 set lthickness
[expr {int
($linespc / 9) + 1}]
6237 set xspc1
(0) $linespc
6245 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6246 if {$ymax eq
{} ||
$ymax == 0} return
6247 set span
[$canv yview
]
6250 allcanvs yview moveto
[lindex
$span 0]
6252 if {[info exists selectedline
]} {
6253 selectline
$selectedline 0
6254 allcanvs yview moveto
[lindex
$span 0]
6258 proc parsefont
{f n
} {
6261 set fontattr
($f,family
) [lindex
$n 0]
6263 if {$s eq
{} ||
$s == 0} {
6266 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
6268 set fontattr
($f,size
) $s
6269 set fontattr
($f,weight
) normal
6270 set fontattr
($f,slant
) roman
6271 foreach style
[lrange
$n 2 end
] {
6274 "bold" {set fontattr
($f,weight
) $style}
6276 "italic" {set fontattr
($f,slant
) $style}
6281 proc fontflags
{f
{isbold
0}} {
6284 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
6285 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
6286 -slant $fontattr($f,slant
)]
6292 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
6293 if {$fontattr($f,weight
) eq
"bold"} {
6296 if {$fontattr($f,slant
) eq
"italic"} {
6302 proc incrfont
{inc
} {
6303 global mainfont textfont ctext canv cflist showrefstop
6304 global stopped entries fontattr
6307 set s
$fontattr(mainfont
,size
)
6312 set fontattr
(mainfont
,size
) $s
6313 font config mainfont
-size $s
6314 font config mainfontbold
-size $s
6315 set mainfont
[fontname mainfont
]
6316 set s
$fontattr(textfont
,size
)
6321 set fontattr
(textfont
,size
) $s
6322 font config textfont
-size $s
6323 font config textfontbold
-size $s
6324 set textfont
[fontname textfont
]
6331 global sha1entry sha1string
6332 if {[string length
$sha1string] == 40} {
6333 $sha1entry delete
0 end
6337 proc sha1change
{n1 n2 op
} {
6338 global sha1string currentid sha1but
6339 if {$sha1string == {}
6340 ||
([info exists currentid
] && $sha1string == $currentid)} {
6345 if {[$sha1but cget
-state] == $state} return
6346 if {$state == "normal"} {
6347 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
6349 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
6353 proc gotocommit
{} {
6354 global sha1string tagids headids curview varcid
6356 if {$sha1string == {}
6357 ||
([info exists currentid
] && $sha1string == $currentid)} return
6358 if {[info exists tagids
($sha1string)]} {
6359 set id
$tagids($sha1string)
6360 } elseif
{[info exists headids
($sha1string)]} {
6361 set id
$headids($sha1string)
6363 set id
[string tolower
$sha1string]
6364 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
6365 set matches
[array names varcid
"$curview,$id*"]
6366 if {$matches ne
{}} {
6367 if {[llength
$matches] > 1} {
6368 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
6371 set id
[lindex
[split [lindex
$matches 0] ","] 1]
6375 if {[commitinview
$id $curview]} {
6376 selectline
[rowofcommit
$id] 1
6379 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
6380 set msg
[mc
"SHA1 id %s is not known" $sha1string]
6382 set msg
[mc
"Tag/Head %s is not known" $sha1string]
6387 proc lineenter
{x y id
} {
6388 global hoverx hovery hoverid hovertimer
6389 global commitinfo canv
6391 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6395 if {[info exists hovertimer
]} {
6396 after cancel
$hovertimer
6398 set hovertimer
[after
500 linehover
]
6402 proc linemotion
{x y id
} {
6403 global hoverx hovery hoverid hovertimer
6405 if {[info exists hoverid
] && $id == $hoverid} {
6408 if {[info exists hovertimer
]} {
6409 after cancel
$hovertimer
6411 set hovertimer
[after
500 linehover
]
6415 proc lineleave
{id
} {
6416 global hoverid hovertimer canv
6418 if {[info exists hoverid
] && $id == $hoverid} {
6420 if {[info exists hovertimer
]} {
6421 after cancel
$hovertimer
6429 global hoverx hovery hoverid hovertimer
6430 global canv linespc lthickness
6433 set text
[lindex
$commitinfo($hoverid) 0]
6434 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6435 if {$ymax == {}} return
6436 set yfrac
[lindex
[$canv yview
] 0]
6437 set x
[expr {$hoverx + 2 * $linespc}]
6438 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6439 set x0
[expr {$x - 2 * $lthickness}]
6440 set y0
[expr {$y - 2 * $lthickness}]
6441 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
6442 set y1
[expr {$y + $linespc + 2 * $lthickness}]
6443 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
6444 -fill \
#ffff80 -outline black -width 1 -tags hover]
6446 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
6451 proc clickisonarrow
{id y
} {
6454 set ranges
[rowranges
$id]
6455 set thresh
[expr {2 * $lthickness + 6}]
6456 set n
[expr {[llength
$ranges] - 1}]
6457 for {set i
1} {$i < $n} {incr i
} {
6458 set row
[lindex
$ranges $i]
6459 if {abs
([yc
$row] - $y) < $thresh} {
6466 proc arrowjump
{id n y
} {
6469 # 1 <-> 2, 3 <-> 4, etc...
6470 set n
[expr {(($n - 1) ^
1) + 1}]
6471 set row
[lindex
[rowranges
$id] $n]
6473 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6474 if {$ymax eq
{} ||
$ymax <= 0} return
6475 set view
[$canv yview
]
6476 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
6477 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
6481 allcanvs yview moveto
$yfrac
6484 proc lineclick
{x y id isnew
} {
6485 global ctext commitinfo children canv thickerline curview
6487 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6492 # draw this line thicker than normal
6496 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6497 if {$ymax eq
{}} return
6498 set yfrac
[lindex
[$canv yview
] 0]
6499 set y
[expr {$y + $yfrac * $ymax}]
6501 set dirn
[clickisonarrow
$id $y]
6503 arrowjump
$id $dirn $y
6508 addtohistory
[list lineclick
$x $y $id 0]
6510 # fill the details pane with info about this line
6511 $ctext conf
-state normal
6514 $ctext insert end
"[mc "Parent
"]:\t"
6515 $ctext insert end
$id link0
6517 set info
$commitinfo($id)
6518 $ctext insert end
"\n\t[lindex $info 0]\n"
6519 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
6520 set date [formatdate
[lindex
$info 2]]
6521 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
6522 set kids
$children($curview,$id)
6524 $ctext insert end
"\n[mc "Children
"]:"
6526 foreach child
$kids {
6528 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
6529 set info
$commitinfo($child)
6530 $ctext insert end
"\n\t"
6531 $ctext insert end
$child link
$i
6532 setlink
$child link
$i
6533 $ctext insert end
"\n\t[lindex $info 0]"
6534 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
6535 set date [formatdate
[lindex
$info 2]]
6536 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
6539 $ctext conf
-state disabled
6543 proc normalline
{} {
6545 if {[info exists thickerline
]} {
6554 if {[commitinview
$id $curview]} {
6555 selectline
[rowofcommit
$id] 1
6561 if {![info exists startmstime
]} {
6562 set startmstime
[clock clicks
-milliseconds]
6564 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
6567 proc rowmenu
{x y id
} {
6568 global rowctxmenu selectedline rowmenuid curview
6569 global nullid nullid2 fakerowmenu mainhead
6573 if {![info exists selectedline
]
6574 ||
[rowofcommit
$id] eq
$selectedline} {
6579 if {$id ne
$nullid && $id ne
$nullid2} {
6580 set menu
$rowctxmenu
6581 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6583 set menu
$fakerowmenu
6585 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6586 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6587 $menu entryconfigure
[mc
"Make patch"] -state $state
6588 tk_popup
$menu $x $y
6591 proc diffvssel
{dirn
} {
6592 global rowmenuid selectedline
6594 if {![info exists selectedline
]} return
6596 set oldid
[commitonrow
$selectedline]
6597 set newid
$rowmenuid
6599 set oldid
$rowmenuid
6600 set newid
[commitonrow
$selectedline]
6602 addtohistory
[list doseldiff
$oldid $newid]
6603 doseldiff
$oldid $newid
6606 proc doseldiff
{oldid newid
} {
6610 $ctext conf
-state normal
6612 init_flist
[mc
"Top"]
6613 $ctext insert end
"[mc "From
"] "
6614 $ctext insert end
$oldid link0
6615 setlink
$oldid link0
6616 $ctext insert end
"\n "
6617 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6618 $ctext insert end
"\n\n[mc "To
"] "
6619 $ctext insert end
$newid link1
6620 setlink
$newid link1
6621 $ctext insert end
"\n "
6622 $ctext insert end
[lindex
$commitinfo($newid) 0]
6623 $ctext insert end
"\n"
6624 $ctext conf
-state disabled
6625 $ctext tag remove found
1.0 end
6626 startdiff
[list
$oldid $newid]
6630 global rowmenuid currentid commitinfo patchtop patchnum
6632 if {![info exists currentid
]} return
6633 set oldid
$currentid
6634 set oldhead
[lindex
$commitinfo($oldid) 0]
6635 set newid
$rowmenuid
6636 set newhead
[lindex
$commitinfo($newid) 0]
6639 catch
{destroy
$top}
6641 label
$top.title
-text [mc
"Generate patch"]
6642 grid
$top.title
- -pady 10
6643 label
$top.from
-text [mc
"From:"]
6644 entry
$top.fromsha1
-width 40 -relief flat
6645 $top.fromsha1 insert
0 $oldid
6646 $top.fromsha1 conf
-state readonly
6647 grid
$top.from
$top.fromsha1
-sticky w
6648 entry
$top.fromhead
-width 60 -relief flat
6649 $top.fromhead insert
0 $oldhead
6650 $top.fromhead conf
-state readonly
6651 grid x
$top.fromhead
-sticky w
6652 label
$top.to
-text [mc
"To:"]
6653 entry
$top.tosha1
-width 40 -relief flat
6654 $top.tosha1 insert
0 $newid
6655 $top.tosha1 conf
-state readonly
6656 grid
$top.to
$top.tosha1
-sticky w
6657 entry
$top.tohead
-width 60 -relief flat
6658 $top.tohead insert
0 $newhead
6659 $top.tohead conf
-state readonly
6660 grid x
$top.tohead
-sticky w
6661 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6662 grid
$top.
rev x
-pady 10
6663 label
$top.flab
-text [mc
"Output file:"]
6664 entry
$top.fname
-width 60
6665 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6667 grid
$top.flab
$top.fname
-sticky w
6669 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6670 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6671 grid
$top.buts.gen
$top.buts.can
6672 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6673 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6674 grid
$top.buts
- -pady 10 -sticky ew
6678 proc mkpatchrev
{} {
6681 set oldid
[$patchtop.fromsha1 get
]
6682 set oldhead
[$patchtop.fromhead get
]
6683 set newid
[$patchtop.tosha1 get
]
6684 set newhead
[$patchtop.tohead get
]
6685 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6686 v
[list
$newid $newhead $oldid $oldhead] {
6687 $patchtop.
$e conf
-state normal
6688 $patchtop.
$e delete
0 end
6689 $patchtop.
$e insert
0 $v
6690 $patchtop.
$e conf
-state readonly
6695 global patchtop nullid nullid2
6697 set oldid
[$patchtop.fromsha1 get
]
6698 set newid
[$patchtop.tosha1 get
]
6699 set fname
[$patchtop.fname get
]
6700 set cmd
[diffcmd
[list
$oldid $newid] -p]
6701 # trim off the initial "|"
6702 set cmd
[lrange
$cmd 1 end
]
6703 lappend cmd
>$fname &
6704 if {[catch
{eval exec $cmd} err
]} {
6705 error_popup
"[mc "Error creating
patch:"] $err"
6707 catch
{destroy
$patchtop}
6711 proc mkpatchcan
{} {
6714 catch
{destroy
$patchtop}
6719 global rowmenuid mktagtop commitinfo
6723 catch
{destroy
$top}
6725 label
$top.title
-text [mc
"Create tag"]
6726 grid
$top.title
- -pady 10
6727 label
$top.id
-text [mc
"ID:"]
6728 entry
$top.sha1
-width 40 -relief flat
6729 $top.sha1 insert
0 $rowmenuid
6730 $top.sha1 conf
-state readonly
6731 grid
$top.id
$top.sha1
-sticky w
6732 entry
$top.
head -width 60 -relief flat
6733 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6734 $top.
head conf
-state readonly
6735 grid x
$top.
head -sticky w
6736 label
$top.tlab
-text [mc
"Tag name:"]
6737 entry
$top.tag
-width 60
6738 grid
$top.tlab
$top.tag
-sticky w
6740 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6741 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6742 grid
$top.buts.gen
$top.buts.can
6743 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6744 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6745 grid
$top.buts
- -pady 10 -sticky ew
6750 global mktagtop env tagids idtags
6752 set id
[$mktagtop.sha1 get
]
6753 set tag
[$mktagtop.tag get
]
6755 error_popup
[mc
"No tag name specified"]
6758 if {[info exists tagids
($tag)]} {
6759 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6764 set fname
[file join $dir "refs/tags" $tag]
6765 set f
[open
$fname w
]
6769 error_popup
"[mc "Error creating tag
:"] $err"
6773 set tagids
($tag) $id
6774 lappend idtags
($id) $tag
6781 proc redrawtags
{id
} {
6782 global canv linehtag idpos currentid curview
6783 global canvxmax iddrawn
6785 if {![commitinview
$id $curview]} return
6786 if {![info exists iddrawn
($id)]} return
6787 set row
[rowofcommit
$id]
6788 $canv delete tag.
$id
6789 set xt
[eval drawtags
$id $idpos($id)]
6790 $canv coords
$linehtag($row) $xt [lindex
$idpos($id) 2]
6791 set text
[$canv itemcget
$linehtag($row) -text]
6792 set font
[$canv itemcget
$linehtag($row) -font]
6793 set xr
[expr {$xt + [font measure
$font $text]}]
6794 if {$xr > $canvxmax} {
6798 if {[info exists currentid
] && $currentid == $id} {
6806 catch
{destroy
$mktagtop}
6815 proc writecommit
{} {
6816 global rowmenuid wrcomtop commitinfo wrcomcmd
6818 set top .writecommit
6820 catch
{destroy
$top}
6822 label
$top.title
-text [mc
"Write commit to file"]
6823 grid
$top.title
- -pady 10
6824 label
$top.id
-text [mc
"ID:"]
6825 entry
$top.sha1
-width 40 -relief flat
6826 $top.sha1 insert
0 $rowmenuid
6827 $top.sha1 conf
-state readonly
6828 grid
$top.id
$top.sha1
-sticky w
6829 entry
$top.
head -width 60 -relief flat
6830 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6831 $top.
head conf
-state readonly
6832 grid x
$top.
head -sticky w
6833 label
$top.clab
-text [mc
"Command:"]
6834 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6835 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6836 label
$top.flab
-text [mc
"Output file:"]
6837 entry
$top.fname
-width 60
6838 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6839 grid
$top.flab
$top.fname
-sticky w
6841 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6842 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6843 grid
$top.buts.gen
$top.buts.can
6844 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6845 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6846 grid
$top.buts
- -pady 10 -sticky ew
6853 set id
[$wrcomtop.sha1 get
]
6854 set cmd
"echo $id | [$wrcomtop.cmd get]"
6855 set fname
[$wrcomtop.fname get
]
6856 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6857 error_popup
"[mc "Error writing commit
:"] $err"
6859 catch
{destroy
$wrcomtop}
6866 catch
{destroy
$wrcomtop}
6871 global rowmenuid mkbrtop
6874 catch
{destroy
$top}
6876 label
$top.title
-text [mc
"Create new branch"]
6877 grid
$top.title
- -pady 10
6878 label
$top.id
-text [mc
"ID:"]
6879 entry
$top.sha1
-width 40 -relief flat
6880 $top.sha1 insert
0 $rowmenuid
6881 $top.sha1 conf
-state readonly
6882 grid
$top.id
$top.sha1
-sticky w
6883 label
$top.nlab
-text [mc
"Name:"]
6884 entry
$top.name
-width 40
6885 grid
$top.nlab
$top.name
-sticky w
6887 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6888 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6889 grid
$top.buts.go
$top.buts.can
6890 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6891 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6892 grid
$top.buts
- -pady 10 -sticky ew
6897 global headids idheads
6899 set name
[$top.name get
]
6900 set id
[$top.sha1 get
]
6902 error_popup
[mc
"Please specify a name for the new branch"]
6905 catch
{destroy
$top}
6909 exec git branch
$name $id
6914 set headids
($name) $id
6915 lappend idheads
($id) $name
6924 proc cherrypick
{} {
6925 global rowmenuid curview
6928 set oldhead
[exec git rev-parse HEAD
]
6929 set dheads
[descheads
$rowmenuid]
6930 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
6931 set ok
[confirm_popup
[mc
"Commit %s is already\
6932 included in branch %s -- really re-apply it?" \
6933 [string range
$rowmenuid 0 7] $mainhead]]
6936 nowbusy cherrypick
[mc
"Cherry-picking"]
6938 # Unfortunately git-cherry-pick writes stuff to stderr even when
6939 # no error occurs, and exec takes that as an indication of error...
6940 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
6945 set newhead
[exec git rev-parse HEAD
]
6946 if {$newhead eq
$oldhead} {
6948 error_popup
[mc
"No changes committed"]
6951 addnewchild
$newhead $oldhead
6952 if {[commitinview
$oldhead $curview]} {
6953 insertrow
$newhead $oldhead $curview
6954 if {$mainhead ne
{}} {
6955 movehead
$newhead $mainhead
6956 movedhead
$newhead $mainhead
6965 global mainheadid mainhead rowmenuid confirm_ok resettype
6968 set w
".confirmreset"
6971 wm title
$w [mc
"Confirm reset"]
6972 message
$w.m
-text \
6973 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
6974 -justify center
-aspect 1000
6975 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
6976 frame
$w.f
-relief sunken
-border 2
6977 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
6978 grid
$w.f.rt
-sticky w
6980 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
6981 -text [mc
"Soft: Leave working tree and index untouched"]
6982 grid
$w.f.soft
-sticky w
6983 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
6984 -text [mc
"Mixed: Leave working tree untouched, reset index"]
6985 grid
$w.f.mixed
-sticky w
6986 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
6987 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
6988 grid
$w.f.hard
-sticky w
6989 pack
$w.f
-side top
-fill x
6990 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
6991 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
6992 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
6993 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
6994 bind $w <Visibility
> "grab $w; focus $w"
6996 if {!$confirm_ok} return
6997 if {[catch
{set fd
[open \
6998 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
7002 filerun
$fd [list readresetstat
$fd]
7003 nowbusy
reset [mc
"Resetting"]
7007 proc readresetstat
{fd
} {
7008 global mainhead mainheadid showlocalchanges rprogcoord
7010 if {[gets
$fd line
] >= 0} {
7011 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
7012 set rprogcoord
[expr {1.0 * $m / $n}]
7020 if {[catch
{close
$fd} err
]} {
7023 set oldhead
$mainheadid
7024 set newhead
[exec git rev-parse HEAD
]
7025 if {$newhead ne
$oldhead} {
7026 movehead
$newhead $mainhead
7027 movedhead
$newhead $mainhead
7028 set mainheadid
$newhead
7032 if {$showlocalchanges} {
7038 # context menu for a head
7039 proc headmenu
{x y id
head} {
7040 global headmenuid headmenuhead headctxmenu mainhead
7044 set headmenuhead
$head
7046 if {$head eq
$mainhead} {
7049 $headctxmenu entryconfigure
0 -state $state
7050 $headctxmenu entryconfigure
1 -state $state
7051 tk_popup
$headctxmenu $x $y
7055 global headmenuid headmenuhead mainhead headids
7056 global showlocalchanges mainheadid
7058 # check the tree is clean first??
7059 set oldmainhead
$mainhead
7060 nowbusy checkout
[mc
"Checking out"]
7064 exec git checkout
-q $headmenuhead
7070 set mainhead
$headmenuhead
7071 set mainheadid
$headmenuid
7072 if {[info exists headids
($oldmainhead)]} {
7073 redrawtags
$headids($oldmainhead)
7075 redrawtags
$headmenuid
7077 if {$showlocalchanges} {
7083 global headmenuid headmenuhead mainhead
7086 set head $headmenuhead
7088 # this check shouldn't be needed any more...
7089 if {$head eq
$mainhead} {
7090 error_popup
[mc
"Cannot delete the currently checked-out branch"]
7093 set dheads
[descheads
$id]
7094 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
7095 # the stuff on this branch isn't on any other branch
7096 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
7097 branch.\nReally delete branch %s?" $head $head]]} return
7101 if {[catch
{exec git branch
-D $head} err
]} {
7106 removehead
$id $head
7107 removedhead
$id $head
7114 # Display a list of tags and heads
7116 global showrefstop bgcolor fgcolor selectbgcolor
7117 global bglist fglist reflistfilter reflist maincursor
7120 set showrefstop
$top
7121 if {[winfo exists
$top]} {
7127 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
7128 text
$top.list
-background $bgcolor -foreground $fgcolor \
7129 -selectbackground $selectbgcolor -font mainfont \
7130 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7131 -width 30 -height 20 -cursor $maincursor \
7132 -spacing1 1 -spacing3 1 -state disabled
7133 $top.list tag configure highlight
-background $selectbgcolor
7134 lappend bglist
$top.list
7135 lappend fglist
$top.list
7136 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
7137 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
7138 grid
$top.list
$top.ysb
-sticky nsew
7139 grid
$top.xsb x
-sticky ew
7141 label
$top.f.l
-text "[mc "Filter
"]: " -font uifont
7142 entry
$top.f.e
-width 20 -textvariable reflistfilter
-font uifont
7143 set reflistfilter
"*"
7144 trace add variable reflistfilter
write reflistfilter_change
7145 pack
$top.f.e
-side right
-fill x
-expand 1
7146 pack
$top.f.l
-side left
7147 grid
$top.f
- -sticky ew
-pady 2
7148 button
$top.close
-command [list destroy
$top] -text [mc
"Close"] \
7151 grid columnconfigure
$top 0 -weight 1
7152 grid rowconfigure
$top 0 -weight 1
7153 bind $top.list
<1> {break}
7154 bind $top.list
<B1-Motion
> {break}
7155 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
7160 proc sel_reflist
{w x y
} {
7161 global showrefstop reflist headids tagids otherrefids
7163 if {![winfo exists
$showrefstop]} return
7164 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
7165 set ref
[lindex
$reflist [expr {$l-1}]]
7166 set n
[lindex
$ref 0]
7167 switch
-- [lindex
$ref 1] {
7168 "H" {selbyid
$headids($n)}
7169 "T" {selbyid
$tagids($n)}
7170 "o" {selbyid
$otherrefids($n)}
7172 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
7175 proc unsel_reflist
{} {
7178 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7179 $showrefstop.list tag remove highlight
0.0 end
7182 proc reflistfilter_change
{n1 n2 op
} {
7183 global reflistfilter
7185 after cancel refill_reflist
7186 after
200 refill_reflist
7189 proc refill_reflist
{} {
7190 global reflist reflistfilter showrefstop headids tagids otherrefids
7191 global curview commitinterest
7193 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
7195 foreach n
[array names headids
] {
7196 if {[string match
$reflistfilter $n]} {
7197 if {[commitinview
$headids($n) $curview]} {
7198 lappend refs
[list
$n H
]
7200 set commitinterest
($headids($n)) {run refill_reflist
}
7204 foreach n
[array names tagids
] {
7205 if {[string match
$reflistfilter $n]} {
7206 if {[commitinview
$tagids($n) $curview]} {
7207 lappend refs
[list
$n T
]
7209 set commitinterest
($tagids($n)) {run refill_reflist
}
7213 foreach n
[array names otherrefids
] {
7214 if {[string match
$reflistfilter $n]} {
7215 if {[commitinview
$otherrefids($n) $curview]} {
7216 lappend refs
[list
$n o
]
7218 set commitinterest
($otherrefids($n)) {run refill_reflist
}
7222 set refs
[lsort
-index 0 $refs]
7223 if {$refs eq
$reflist} return
7225 # Update the contents of $showrefstop.list according to the
7226 # differences between $reflist (old) and $refs (new)
7227 $showrefstop.list conf
-state normal
7228 $showrefstop.list insert end
"\n"
7231 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
7232 if {$i < [llength
$reflist]} {
7233 if {$j < [llength
$refs]} {
7234 set cmp [string compare
[lindex
$reflist $i 0] \
7235 [lindex
$refs $j 0]]
7237 set cmp [string compare
[lindex
$reflist $i 1] \
7238 [lindex
$refs $j 1]]
7248 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
7256 set l
[expr {$j + 1}]
7257 $showrefstop.list image create
$l.0 -align baseline \
7258 -image reficon-
[lindex
$refs $j 1] -padx 2
7259 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
7265 # delete last newline
7266 $showrefstop.list delete end-2c end-1c
7267 $showrefstop.list conf
-state disabled
7270 # Stuff for finding nearby tags
7271 proc getallcommits
{} {
7272 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7273 global idheads idtags idotherrefs allparents tagobjid
7275 if {![info exists allcommits
]} {
7281 set allccache
[file join [gitdir
] "gitk.cache"]
7283 set f
[open
$allccache r
]
7292 set cmd
[list | git rev-list
--parents]
7293 set allcupdate
[expr {$seeds ne
{}}]
7297 set refs
[concat
[array names idheads
] [array names idtags
] \
7298 [array names idotherrefs
]]
7301 foreach name
[array names tagobjid
] {
7302 lappend tagobjs
$tagobjid($name)
7304 foreach id
[lsort
-unique $refs] {
7305 if {![info exists allparents
($id)] &&
7306 [lsearch
-exact $tagobjs $id] < 0} {
7317 set fd
[open
[concat
$cmd $ids] r
]
7318 fconfigure
$fd -blocking 0
7321 filerun
$fd [list getallclines
$fd]
7327 # Since most commits have 1 parent and 1 child, we group strings of
7328 # such commits into "arcs" joining branch/merge points (BMPs), which
7329 # are commits that either don't have 1 parent or don't have 1 child.
7331 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7332 # arcout(id) - outgoing arcs for BMP
7333 # arcids(a) - list of IDs on arc including end but not start
7334 # arcstart(a) - BMP ID at start of arc
7335 # arcend(a) - BMP ID at end of arc
7336 # growing(a) - arc a is still growing
7337 # arctags(a) - IDs out of arcids (excluding end) that have tags
7338 # archeads(a) - IDs out of arcids (excluding end) that have heads
7339 # The start of an arc is at the descendent end, so "incoming" means
7340 # coming from descendents, and "outgoing" means going towards ancestors.
7342 proc getallclines
{fd
} {
7343 global allparents allchildren idtags idheads nextarc
7344 global arcnos arcids arctags arcout arcend arcstart archeads growing
7345 global seeds allcommits cachedarcs allcupdate
7348 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
7349 set id
[lindex
$line 0]
7350 if {[info exists allparents
($id)]} {
7355 set olds
[lrange
$line 1 end
]
7356 set allparents
($id) $olds
7357 if {![info exists allchildren
($id)]} {
7358 set allchildren
($id) {}
7363 if {[llength
$olds] == 1 && [llength
$a] == 1} {
7364 lappend arcids
($a) $id
7365 if {[info exists idtags
($id)]} {
7366 lappend arctags
($a) $id
7368 if {[info exists idheads
($id)]} {
7369 lappend archeads
($a) $id
7371 if {[info exists allparents
($olds)]} {
7372 # seen parent already
7373 if {![info exists arcout
($olds)]} {
7376 lappend arcids
($a) $olds
7377 set arcend
($a) $olds
7380 lappend allchildren
($olds) $id
7381 lappend arcnos
($olds) $a
7385 foreach a
$arcnos($id) {
7386 lappend arcids
($a) $id
7393 lappend allchildren
($p) $id
7394 set a
[incr nextarc
]
7395 set arcstart
($a) $id
7402 if {[info exists allparents
($p)]} {
7403 # seen it already, may need to make a new branch
7404 if {![info exists arcout
($p)]} {
7407 lappend arcids
($a) $p
7411 lappend arcnos
($p) $a
7416 global cached_dheads cached_dtags cached_atags
7417 catch
{unset cached_dheads
}
7418 catch
{unset cached_dtags
}
7419 catch
{unset cached_atags
}
7422 return [expr {$nid >= 1000?
2: 1}]
7426 fconfigure
$fd -blocking 1
7429 # got an error reading the list of commits
7430 # if we were updating, try rereading the whole thing again
7436 error_popup
"[mc "Error reading commit topology information
;\
7437 branch and preceding
/following tag information\
7438 will be incomplete.
"]\n($err)"
7441 if {[incr allcommits
-1] == 0} {
7451 proc recalcarc
{a
} {
7452 global arctags archeads arcids idtags idheads
7456 foreach id
[lrange
$arcids($a) 0 end-1
] {
7457 if {[info exists idtags
($id)]} {
7460 if {[info exists idheads
($id)]} {
7465 set archeads
($a) $ah
7469 global arcnos arcids nextarc arctags archeads idtags idheads
7470 global arcstart arcend arcout allparents growing
7473 if {[llength
$a] != 1} {
7474 puts
"oops splitarc called but [llength $a] arcs already"
7478 set i
[lsearch
-exact $arcids($a) $p]
7480 puts
"oops splitarc $p not in arc $a"
7483 set na
[incr nextarc
]
7484 if {[info exists arcend
($a)]} {
7485 set arcend
($na) $arcend($a)
7487 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
7488 set j
[lsearch
-exact $arcnos($l) $a]
7489 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
7491 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
7492 set arcids
($a) [lrange
$arcids($a) 0 $i]
7494 set arcstart
($na) $p
7496 set arcids
($na) $tail
7497 if {[info exists growing
($a)]} {
7503 if {[llength
$arcnos($id)] == 1} {
7506 set j
[lsearch
-exact $arcnos($id) $a]
7507 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
7511 # reconstruct tags and heads lists
7512 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
7517 set archeads
($na) {}
7521 # Update things for a new commit added that is a child of one
7522 # existing commit. Used when cherry-picking.
7523 proc addnewchild
{id p
} {
7524 global allparents allchildren idtags nextarc
7525 global arcnos arcids arctags arcout arcend arcstart archeads growing
7526 global seeds allcommits
7528 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
7529 set allparents
($id) [list
$p]
7530 set allchildren
($id) {}
7533 lappend allchildren
($p) $id
7534 set a
[incr nextarc
]
7535 set arcstart
($a) $id
7538 set arcids
($a) [list
$p]
7540 if {![info exists arcout
($p)]} {
7543 lappend arcnos
($p) $a
7544 set arcout
($id) [list
$a]
7547 # This implements a cache for the topology information.
7548 # The cache saves, for each arc, the start and end of the arc,
7549 # the ids on the arc, and the outgoing arcs from the end.
7550 proc readcache
{f
} {
7551 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7552 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7557 if {$lim - $a > 500} {
7558 set lim
[expr {$a + 500}]
7562 # finish reading the cache and setting up arctags, etc.
7564 if {$line ne
"1"} {error
"bad final version"}
7566 foreach id
[array names idtags
] {
7567 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7568 [llength
$allparents($id)] == 1} {
7569 set a
[lindex
$arcnos($id) 0]
7570 if {$arctags($a) eq
{}} {
7575 foreach id
[array names idheads
] {
7576 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7577 [llength
$allparents($id)] == 1} {
7578 set a
[lindex
$arcnos($id) 0]
7579 if {$archeads($a) eq
{}} {
7584 foreach id
[lsort
-unique $possible_seeds] {
7585 if {$arcnos($id) eq
{}} {
7591 while {[incr a
] <= $lim} {
7593 if {[llength
$line] != 3} {error
"bad line"}
7594 set s
[lindex
$line 0]
7596 lappend arcout
($s) $a
7597 if {![info exists arcnos
($s)]} {
7598 lappend possible_seeds
$s
7601 set e
[lindex
$line 1]
7606 if {![info exists arcout
($e)]} {
7610 set arcids
($a) [lindex
$line 2]
7611 foreach id
$arcids($a) {
7612 lappend allparents
($s) $id
7614 lappend arcnos
($id) $a
7616 if {![info exists allparents
($s)]} {
7617 set allparents
($s) {}
7622 set nextarc
[expr {$a - 1}]
7635 global nextarc cachedarcs possible_seeds
7639 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7640 # make sure it's an integer
7641 set cachedarcs
[expr {int
([lindex
$line 1])}]
7642 if {$cachedarcs < 0} {error
"bad number of arcs"}
7644 set possible_seeds
{}
7652 proc dropcache
{err
} {
7653 global allcwait nextarc cachedarcs seeds
7655 #puts "dropping cache ($err)"
7656 foreach v
{arcnos arcout arcids arcstart arcend growing \
7657 arctags archeads allparents allchildren
} {
7668 proc writecache
{f
} {
7669 global cachearc cachedarcs allccache
7670 global arcstart arcend arcnos arcids arcout
7674 if {$lim - $a > 1000} {
7675 set lim
[expr {$a + 1000}]
7678 while {[incr a
] <= $lim} {
7679 if {[info exists arcend
($a)]} {
7680 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7682 puts
$f [list
$arcstart($a) {} $arcids($a)]
7687 catch
{file delete
$allccache}
7688 #puts "writing cache failed ($err)"
7691 set cachearc
[expr {$a - 1}]
7692 if {$a > $cachedarcs} {
7701 global nextarc cachedarcs cachearc allccache
7703 if {$nextarc == $cachedarcs} return
7705 set cachedarcs
$nextarc
7707 set f
[open
$allccache w
]
7708 puts
$f [list
1 $cachedarcs]
7713 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7714 # or 0 if neither is true.
7715 proc anc_or_desc
{a b
} {
7716 global arcout arcstart arcend arcnos cached_isanc
7718 if {$arcnos($a) eq
$arcnos($b)} {
7719 # Both are on the same arc(s); either both are the same BMP,
7720 # or if one is not a BMP, the other is also not a BMP or is
7721 # the BMP at end of the arc (and it only has 1 incoming arc).
7722 # Or both can be BMPs with no incoming arcs.
7723 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7726 # assert {[llength $arcnos($a)] == 1}
7727 set arc
[lindex
$arcnos($a) 0]
7728 set i
[lsearch
-exact $arcids($arc) $a]
7729 set j
[lsearch
-exact $arcids($arc) $b]
7730 if {$i < 0 ||
$i > $j} {
7737 if {![info exists arcout
($a)]} {
7738 set arc
[lindex
$arcnos($a) 0]
7739 if {[info exists arcend
($arc)]} {
7740 set aend
$arcend($arc)
7744 set a
$arcstart($arc)
7748 if {![info exists arcout
($b)]} {
7749 set arc
[lindex
$arcnos($b) 0]
7750 if {[info exists arcend
($arc)]} {
7751 set bend
$arcend($arc)
7755 set b
$arcstart($arc)
7765 if {[info exists cached_isanc
($a,$bend)]} {
7766 if {$cached_isanc($a,$bend)} {
7770 if {[info exists cached_isanc
($b,$aend)]} {
7771 if {$cached_isanc($b,$aend)} {
7774 if {[info exists cached_isanc
($a,$bend)]} {
7779 set todo
[list
$a $b]
7782 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7783 set x
[lindex
$todo $i]
7784 if {$anc($x) eq
{}} {
7787 foreach arc
$arcnos($x) {
7788 set xd
$arcstart($arc)
7790 set cached_isanc
($a,$bend) 1
7791 set cached_isanc
($b,$aend) 0
7793 } elseif
{$xd eq
$aend} {
7794 set cached_isanc
($b,$aend) 1
7795 set cached_isanc
($a,$bend) 0
7798 if {![info exists anc
($xd)]} {
7799 set anc
($xd) $anc($x)
7801 } elseif
{$anc($xd) ne
$anc($x)} {
7806 set cached_isanc
($a,$bend) 0
7807 set cached_isanc
($b,$aend) 0
7811 # This identifies whether $desc has an ancestor that is
7812 # a growing tip of the graph and which is not an ancestor of $anc
7813 # and returns 0 if so and 1 if not.
7814 # If we subsequently discover a tag on such a growing tip, and that
7815 # turns out to be a descendent of $anc (which it could, since we
7816 # don't necessarily see children before parents), then $desc
7817 # isn't a good choice to display as a descendent tag of
7818 # $anc (since it is the descendent of another tag which is
7819 # a descendent of $anc). Similarly, $anc isn't a good choice to
7820 # display as a ancestor tag of $desc.
7822 proc is_certain
{desc anc
} {
7823 global arcnos arcout arcstart arcend growing problems
7826 if {[llength
$arcnos($anc)] == 1} {
7827 # tags on the same arc are certain
7828 if {$arcnos($desc) eq
$arcnos($anc)} {
7831 if {![info exists arcout
($anc)]} {
7832 # if $anc is partway along an arc, use the start of the arc instead
7833 set a
[lindex
$arcnos($anc) 0]
7834 set anc
$arcstart($a)
7837 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7840 set a
[lindex
$arcnos($desc) 0]
7846 set anclist
[list
$x]
7850 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7851 set x
[lindex
$anclist $i]
7856 foreach a
$arcout($x) {
7857 if {[info exists growing
($a)]} {
7858 if {![info exists growanc
($x)] && $dl($x)} {
7864 if {[info exists dl
($y)]} {
7868 if {![info exists
done($y)]} {
7871 if {[info exists growanc
($x)]} {
7875 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7876 set z
[lindex
$xl $k]
7877 foreach c
$arcout($z) {
7878 if {[info exists arcend
($c)]} {
7880 if {[info exists dl
($v)] && $dl($v)} {
7882 if {![info exists
done($v)]} {
7885 if {[info exists growanc
($v)]} {
7895 } elseif
{$y eq
$anc ||
!$dl($x)} {
7906 foreach x
[array names growanc
] {
7915 proc validate_arctags
{a
} {
7916 global arctags idtags
7920 foreach id
$arctags($a) {
7922 if {![info exists idtags
($id)]} {
7923 set na
[lreplace
$na $i $i]
7930 proc validate_archeads
{a
} {
7931 global archeads idheads
7934 set na
$archeads($a)
7935 foreach id
$archeads($a) {
7937 if {![info exists idheads
($id)]} {
7938 set na
[lreplace
$na $i $i]
7942 set archeads
($a) $na
7945 # Return the list of IDs that have tags that are descendents of id,
7946 # ignoring IDs that are descendents of IDs already reported.
7947 proc desctags
{id
} {
7948 global arcnos arcstart arcids arctags idtags allparents
7949 global growing cached_dtags
7951 if {![info exists allparents
($id)]} {
7954 set t1
[clock clicks
-milliseconds]
7956 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7957 # part-way along an arc; check that arc first
7958 set a
[lindex
$arcnos($id) 0]
7959 if {$arctags($a) ne
{}} {
7961 set i
[lsearch
-exact $arcids($a) $id]
7963 foreach t
$arctags($a) {
7964 set j
[lsearch
-exact $arcids($a) $t]
7972 set id
$arcstart($a)
7973 if {[info exists idtags
($id)]} {
7977 if {[info exists cached_dtags
($id)]} {
7978 return $cached_dtags($id)
7985 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7986 set id
[lindex
$todo $i]
7988 set ta
[info exists hastaggedancestor
($id)]
7992 # ignore tags on starting node
7993 if {!$ta && $i > 0} {
7994 if {[info exists idtags
($id)]} {
7997 } elseif
{[info exists cached_dtags
($id)]} {
7998 set tagloc
($id) $cached_dtags($id)
8002 foreach a
$arcnos($id) {
8004 if {!$ta && $arctags($a) ne
{}} {
8006 if {$arctags($a) ne
{}} {
8007 lappend tagloc
($id) [lindex
$arctags($a) end
]
8010 if {$ta ||
$arctags($a) ne
{}} {
8011 set tomark
[list
$d]
8012 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8013 set dd [lindex
$tomark $j]
8014 if {![info exists hastaggedancestor
($dd)]} {
8015 if {[info exists
done($dd)]} {
8016 foreach b
$arcnos($dd) {
8017 lappend tomark
$arcstart($b)
8019 if {[info exists tagloc
($dd)]} {
8022 } elseif
{[info exists queued
($dd)]} {
8025 set hastaggedancestor
($dd) 1
8029 if {![info exists queued
($d)]} {
8032 if {![info exists hastaggedancestor
($d)]} {
8039 foreach id
[array names tagloc
] {
8040 if {![info exists hastaggedancestor
($id)]} {
8041 foreach t
$tagloc($id) {
8042 if {[lsearch
-exact $tags $t] < 0} {
8048 set t2
[clock clicks
-milliseconds]
8051 # remove tags that are descendents of other tags
8052 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8053 set a
[lindex
$tags $i]
8054 for {set j
0} {$j < $i} {incr j
} {
8055 set b
[lindex
$tags $j]
8056 set r
[anc_or_desc
$a $b]
8058 set tags
[lreplace
$tags $j $j]
8061 } elseif
{$r == -1} {
8062 set tags
[lreplace
$tags $i $i]
8069 if {[array names growing
] ne
{}} {
8070 # graph isn't finished, need to check if any tag could get
8071 # eclipsed by another tag coming later. Simply ignore any
8072 # tags that could later get eclipsed.
8075 if {[is_certain
$t $origid]} {
8079 if {$tags eq
$ctags} {
8080 set cached_dtags
($origid) $tags
8085 set cached_dtags
($origid) $tags
8087 set t3
[clock clicks
-milliseconds]
8088 if {0 && $t3 - $t1 >= 100} {
8089 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
8090 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8096 global arcnos arcids arcout arcend arctags idtags allparents
8097 global growing cached_atags
8099 if {![info exists allparents
($id)]} {
8102 set t1
[clock clicks
-milliseconds]
8104 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8105 # part-way along an arc; check that arc first
8106 set a
[lindex
$arcnos($id) 0]
8107 if {$arctags($a) ne
{}} {
8109 set i
[lsearch
-exact $arcids($a) $id]
8110 foreach t
$arctags($a) {
8111 set j
[lsearch
-exact $arcids($a) $t]
8117 if {![info exists arcend
($a)]} {
8121 if {[info exists idtags
($id)]} {
8125 if {[info exists cached_atags
($id)]} {
8126 return $cached_atags($id)
8134 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
8135 set id
[lindex
$todo $i]
8137 set td
[info exists hastaggeddescendent
($id)]
8141 # ignore tags on starting node
8142 if {!$td && $i > 0} {
8143 if {[info exists idtags
($id)]} {
8146 } elseif
{[info exists cached_atags
($id)]} {
8147 set tagloc
($id) $cached_atags($id)
8151 foreach a
$arcout($id) {
8152 if {!$td && $arctags($a) ne
{}} {
8154 if {$arctags($a) ne
{}} {
8155 lappend tagloc
($id) [lindex
$arctags($a) 0]
8158 if {![info exists arcend
($a)]} continue
8160 if {$td ||
$arctags($a) ne
{}} {
8161 set tomark
[list
$d]
8162 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
8163 set dd [lindex
$tomark $j]
8164 if {![info exists hastaggeddescendent
($dd)]} {
8165 if {[info exists
done($dd)]} {
8166 foreach b
$arcout($dd) {
8167 if {[info exists arcend
($b)]} {
8168 lappend tomark
$arcend($b)
8171 if {[info exists tagloc
($dd)]} {
8174 } elseif
{[info exists queued
($dd)]} {
8177 set hastaggeddescendent
($dd) 1
8181 if {![info exists queued
($d)]} {
8184 if {![info exists hastaggeddescendent
($d)]} {
8190 set t2
[clock clicks
-milliseconds]
8193 foreach id
[array names tagloc
] {
8194 if {![info exists hastaggeddescendent
($id)]} {
8195 foreach t
$tagloc($id) {
8196 if {[lsearch
-exact $tags $t] < 0} {
8203 # remove tags that are ancestors of other tags
8204 for {set i
0} {$i < [llength
$tags]} {incr i
} {
8205 set a
[lindex
$tags $i]
8206 for {set j
0} {$j < $i} {incr j
} {
8207 set b
[lindex
$tags $j]
8208 set r
[anc_or_desc
$a $b]
8210 set tags
[lreplace
$tags $j $j]
8213 } elseif
{$r == 1} {
8214 set tags
[lreplace
$tags $i $i]
8221 if {[array names growing
] ne
{}} {
8222 # graph isn't finished, need to check if any tag could get
8223 # eclipsed by another tag coming later. Simply ignore any
8224 # tags that could later get eclipsed.
8227 if {[is_certain
$origid $t]} {
8231 if {$tags eq
$ctags} {
8232 set cached_atags
($origid) $tags
8237 set cached_atags
($origid) $tags
8239 set t3
[clock clicks
-milliseconds]
8240 if {0 && $t3 - $t1 >= 100} {
8241 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
8242 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8247 # Return the list of IDs that have heads that are descendents of id,
8248 # including id itself if it has a head.
8249 proc descheads
{id
} {
8250 global arcnos arcstart arcids archeads idheads cached_dheads
8253 if {![info exists allparents
($id)]} {
8257 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
8258 # part-way along an arc; check it first
8259 set a
[lindex
$arcnos($id) 0]
8260 if {$archeads($a) ne
{}} {
8261 validate_archeads
$a
8262 set i
[lsearch
-exact $arcids($a) $id]
8263 foreach t
$archeads($a) {
8264 set j
[lsearch
-exact $arcids($a) $t]
8269 set id
$arcstart($a)
8275 for {set i
0} {$i < [llength
$todo]} {incr i
} {
8276 set id
[lindex
$todo $i]
8277 if {[info exists cached_dheads
($id)]} {
8278 set ret
[concat
$ret $cached_dheads($id)]
8280 if {[info exists idheads
($id)]} {
8283 foreach a
$arcnos($id) {
8284 if {$archeads($a) ne
{}} {
8285 validate_archeads
$a
8286 if {$archeads($a) ne
{}} {
8287 set ret
[concat
$ret $archeads($a)]
8291 if {![info exists seen
($d)]} {
8298 set ret
[lsort
-unique $ret]
8299 set cached_dheads
($origid) $ret
8300 return [concat
$ret $aret]
8303 proc addedtag
{id
} {
8304 global arcnos arcout cached_dtags cached_atags
8306 if {![info exists arcnos
($id)]} return
8307 if {![info exists arcout
($id)]} {
8308 recalcarc
[lindex
$arcnos($id) 0]
8310 catch
{unset cached_dtags
}
8311 catch
{unset cached_atags
}
8314 proc addedhead
{hid
head} {
8315 global arcnos arcout cached_dheads
8317 if {![info exists arcnos
($hid)]} return
8318 if {![info exists arcout
($hid)]} {
8319 recalcarc
[lindex
$arcnos($hid) 0]
8321 catch
{unset cached_dheads
}
8324 proc removedhead
{hid
head} {
8325 global cached_dheads
8327 catch
{unset cached_dheads
}
8330 proc movedhead
{hid
head} {
8331 global arcnos arcout cached_dheads
8333 if {![info exists arcnos
($hid)]} return
8334 if {![info exists arcout
($hid)]} {
8335 recalcarc
[lindex
$arcnos($hid) 0]
8337 catch
{unset cached_dheads
}
8340 proc changedrefs
{} {
8341 global cached_dheads cached_dtags cached_atags
8342 global arctags archeads arcnos arcout idheads idtags
8344 foreach id
[concat
[array names idheads
] [array names idtags
]] {
8345 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
8346 set a
[lindex
$arcnos($id) 0]
8347 if {![info exists donearc
($a)]} {
8353 catch
{unset cached_dtags
}
8354 catch
{unset cached_atags
}
8355 catch
{unset cached_dheads
}
8358 proc rereadrefs
{} {
8359 global idtags idheads idotherrefs mainheadid
8361 set refids
[concat
[array names idtags
] \
8362 [array names idheads
] [array names idotherrefs
]]
8363 foreach id
$refids {
8364 if {![info exists ref
($id)]} {
8365 set ref
($id) [listrefs
$id]
8368 set oldmainhead
$mainheadid
8371 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
8372 [array names idheads
] [array names idotherrefs
]]]
8373 foreach id
$refids {
8374 set v
[listrefs
$id]
8375 if {![info exists ref
($id)] ||
$ref($id) != $v ||
8376 ($id eq
$oldmainhead && $id ne
$mainheadid) ||
8377 ($id eq
$mainheadid && $id ne
$oldmainhead)} {
8384 proc listrefs
{id
} {
8385 global idtags idheads idotherrefs
8388 if {[info exists idtags
($id)]} {
8392 if {[info exists idheads
($id)]} {
8396 if {[info exists idotherrefs
($id)]} {
8397 set z
$idotherrefs($id)
8399 return [list
$x $y $z]
8402 proc showtag
{tag isnew
} {
8403 global ctext tagcontents tagids linknum tagobjid
8406 addtohistory
[list showtag
$tag 0]
8408 $ctext conf
-state normal
8412 if {![info exists tagcontents
($tag)]} {
8414 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
8417 if {[info exists tagcontents
($tag)]} {
8418 set text
$tagcontents($tag)
8420 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
8422 appendwithlinks
$text {}
8423 $ctext conf
-state disabled
8434 proc mkfontdisp
{font top
which} {
8435 global fontattr fontpref
$font
8437 set fontpref
($font) [set $font]
8438 button
$top.
${font}but
-text $which -font optionfont \
8439 -command [list choosefont
$font $which]
8440 label
$top.
$font -relief flat
-font $font \
8441 -text $fontattr($font,family
) -justify left
8442 grid x
$top.
${font}but
$top.
$font -sticky w
8445 proc choosefont
{font
which} {
8446 global fontparam fontlist fonttop fontattr
8448 set fontparam
(which) $which
8449 set fontparam
(font
) $font
8450 set fontparam
(family
) [font actual
$font -family]
8451 set fontparam
(size
) $fontattr($font,size
)
8452 set fontparam
(weight
) $fontattr($font,weight
)
8453 set fontparam
(slant
) $fontattr($font,slant
)
8456 if {![winfo exists
$top]} {
8458 eval font config sample
[font actual
$font]
8460 wm title
$top [mc
"Gitk font chooser"]
8461 label
$top.l
-textvariable fontparam
(which) -font uifont
8462 pack
$top.l
-side top
8463 set fontlist
[lsort
[font families
]]
8465 listbox
$top.f.fam
-listvariable fontlist \
8466 -yscrollcommand [list
$top.f.sb
set]
8467 bind $top.f.fam
<<ListboxSelect>> selfontfam
8468 scrollbar $top.f.sb -command [list $top.f.fam yview]
8469 pack $top.f.sb -side right -fill y
8470 pack $top.f.fam -side left -fill both -expand 1
8471 pack $top.f -side top -fill both -expand 1
8473 spinbox $top.g.size -from 4 -to 40 -width 4 \
8474 -textvariable fontparam(size) \
8475 -validatecommand {string is integer -strict %s}
8476 checkbutton $top.g.bold -padx 5 \
8477 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8478 -variable fontparam(weight) -onvalue bold -offvalue normal
8479 checkbutton $top.g.ital -padx 5 \
8480 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8481 -variable fontparam(slant) -onvalue italic -offvalue roman
8482 pack $top.g.size $top.g.bold $top.g.ital -side left
8483 pack $top.g -side top
8484 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8486 $top.c create text 100 25 -anchor center -text $which -font sample \
8487 -fill black -tags text
8488 bind $top.c <Configure> [list centertext $top.c]
8489 pack $top.c -side top -fill x
8491 button $top.buts.ok -text [mc "OK"] -command fontok -default active \
8493 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal \
8495 grid $top.buts.ok $top.buts.can
8496 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8497 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8498 pack $top.buts -side bottom -fill x
8499 trace add variable fontparam write chg_fontparam
8502 $top.c itemconf text -text $which
8504 set i [lsearch -exact $fontlist $fontparam(family)]
8506 $top.f.fam selection set $i
8511 proc centertext {w} {
8512 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8516 global fontparam fontpref prefstop
8518 set f $fontparam(font)
8519 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8520 if {$fontparam(weight) eq "bold"} {
8521 lappend fontpref($f) "bold"
8523 if {$fontparam(slant) eq "italic"} {
8524 lappend fontpref($f) "italic"
8527 $w conf -text $fontparam(family) -font $fontpref($f)
8533 global fonttop fontparam
8535 if {[info exists fonttop]} {
8536 catch {destroy $fonttop}
8537 catch {font delete sample}
8543 proc selfontfam {} {
8544 global fonttop fontparam
8546 set i [$fonttop.f.fam curselection]
8548 set fontparam(family) [$fonttop.f.fam get $i]
8552 proc chg_fontparam {v sub op} {
8555 font config sample -$sub $fontparam($sub)
8559 global maxwidth maxgraphpct
8560 global oldprefs prefstop showneartags showlocalchanges
8561 global bgcolor fgcolor ctext diffcolors selectbgcolor
8562 global uifont tabstop limitdiffs
8566 if {[winfo exists $top]} {
8570 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8571 limitdiffs tabstop} {
8572 set oldprefs($v) [set $v]
8575 wm title $top [mc "Gitk preferences"]
8576 label $top.ldisp -text [mc "Commit list display options"]
8577 $top.ldisp configure -font uifont
8578 grid $top.ldisp - -sticky w -pady 10
8579 label $top.spacer -text " "
8580 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8582 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8583 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8584 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8586 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8587 grid x $top.maxpctl $top.maxpct -sticky w
8588 frame $top.showlocal
8589 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8590 checkbutton $top.showlocal.b -variable showlocalchanges
8591 pack $top.showlocal.b $top.showlocal.l -side left
8592 grid x $top.showlocal -sticky w
8594 label $top.ddisp -text [mc "Diff display options"]
8595 $top.ddisp configure -font uifont
8596 grid $top.ddisp - -sticky w -pady 10
8597 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8598 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8599 grid x $top.tabstopl $top.tabstop -sticky w
8601 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8602 checkbutton $top.ntag.b -variable showneartags
8603 pack $top.ntag.b $top.ntag.l -side left
8604 grid x $top.ntag -sticky w
8606 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8607 checkbutton $top.ldiff.b -variable limitdiffs
8608 pack $top.ldiff.b $top.ldiff.l -side left
8609 grid x $top.ldiff -sticky w
8611 label $top.cdisp -text [mc "Colors: press to choose"]
8612 $top.cdisp configure -font uifont
8613 grid $top.cdisp - -sticky w -pady 10
8614 label $top.bg -padx 40 -relief sunk -background $bgcolor
8615 button $top.bgbut -text [mc "Background"] -font optionfont \
8616 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8617 grid x $top.bgbut $top.bg -sticky w
8618 label $top.fg -padx 40 -relief sunk -background $fgcolor
8619 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8620 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8621 grid x $top.fgbut $top.fg -sticky w
8622 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8623 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8624 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8625 [list $ctext tag conf d0 -foreground]]
8626 grid x $top.diffoldbut $top.diffold -sticky w
8627 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8628 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8629 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8630 [list $ctext tag conf d1 -foreground]]
8631 grid x $top.diffnewbut $top.diffnew -sticky w
8632 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8633 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8634 -command [list choosecolor diffcolors 2 $top.hunksep \
8635 "diff hunk header" \
8636 [list $ctext tag conf hunksep -foreground]]
8637 grid x $top.hunksepbut $top.hunksep -sticky w
8638 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8639 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8640 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8641 grid x $top.selbgbut $top.selbgsep -sticky w
8643 label $top.cfont -text [mc "Fonts: press to choose"]
8644 $top.cfont configure -font uifont
8645 grid $top.cfont - -sticky w -pady 10
8646 mkfontdisp mainfont $top [mc "Main font"]
8647 mkfontdisp textfont $top [mc "Diff display font"]
8648 mkfontdisp uifont $top [mc "User interface font"]
8651 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8652 $top.buts.ok configure -font uifont
8653 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8654 $top.buts.can configure -font uifont
8655 grid $top.buts.ok $top.buts.can
8656 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8657 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8658 grid $top.buts - - -pady 10 -sticky ew
8659 bind $top <Visibility> "focus $top.buts.ok"
8662 proc choosecolor {v vi w x cmd} {
8665 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8666 -title [mc "Gitk: choose color for %s" $x]]
8667 if {$c eq {}} return
8668 $w conf -background $c
8674 global bglist cflist
8676 $w configure -selectbackground $c
8678 $cflist tag configure highlight \
8679 -background [$cflist cget -selectbackground]
8680 allcanvs itemconf secsel -fill $c
8687 $w conf -background $c
8695 $w conf -foreground $c
8697 allcanvs itemconf text -fill $c
8698 $canv itemconf circle -outline $c
8702 global oldprefs prefstop
8704 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8705 limitdiffs tabstop} {
8707 set $v $oldprefs($v)
8709 catch {destroy $prefstop}
8715 global maxwidth maxgraphpct
8716 global oldprefs prefstop showneartags showlocalchanges
8717 global fontpref mainfont textfont uifont
8718 global limitdiffs treediffs
8720 catch {destroy $prefstop}
8724 if {$mainfont ne $fontpref(mainfont)} {
8725 set mainfont $fontpref(mainfont)
8726 parsefont mainfont $mainfont
8727 eval font configure mainfont [fontflags mainfont]
8728 eval font configure mainfontbold [fontflags mainfont 1]
8732 if {$textfont ne $fontpref(textfont)} {
8733 set textfont $fontpref(textfont)
8734 parsefont textfont $textfont
8735 eval font configure textfont [fontflags textfont]
8736 eval font configure textfontbold [fontflags textfont 1]
8738 if {$uifont ne $fontpref(uifont)} {
8739 set uifont $fontpref(uifont)
8740 parsefont uifont $uifont
8741 eval font configure uifont [fontflags uifont]
8744 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8745 if {$showlocalchanges} {
8751 if {$limitdiffs != $oldprefs(limitdiffs)} {
8752 # treediffs elements are limited by path
8753 catch {unset treediffs}
8755 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8756 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8758 } elseif {$showneartags != $oldprefs(showneartags) ||
8759 $limitdiffs != $oldprefs(limitdiffs)} {
8764 proc formatdate {d} {
8765 global datetimeformat
8767 set d [clock format $d -format $datetimeformat]
8772 # This list of encoding names and aliases is distilled from
8773 # http://www.iana.org/assignments/character-sets.
8774 # Not all of them are supported by Tcl.
8775 set encoding_aliases {
8776 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8777 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8778 { ISO-10646-UTF-1 csISO10646UTF1 }
8779 { ISO_646.basic:1983 ref csISO646basic1983 }
8780 { INVARIANT csINVARIANT }
8781 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8782 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8783 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8784 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8785 { NATS-DANO iso-ir-9-1 csNATSDANO }
8786 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8787 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8788 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8789 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8790 { ISO-2022-KR csISO2022KR }
8792 { ISO-2022-JP csISO2022JP }
8793 { ISO-2022-JP-2 csISO2022JP2 }
8794 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8796 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8797 { IT iso-ir-15 ISO646-IT csISO15Italian }
8798 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8799 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8800 { greek7-old iso-ir-18 csISO18Greek7Old }
8801 { latin-greek iso-ir-19 csISO19LatinGreek }
8802 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8803 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8804 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8805 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8806 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8807 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8808 { INIS iso-ir-49 csISO49INIS }
8809 { INIS-8 iso-ir-50 csISO50INIS8 }
8810 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8811 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8812 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8813 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8814 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8815 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8817 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8818 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8819 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8820 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8821 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8822 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8823 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8824 { greek7 iso-ir-88 csISO88Greek7 }
8825 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8826 { iso-ir-90 csISO90 }
8827 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8828 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8829 csISO92JISC62991984b }
8830 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8831 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8832 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8833 csISO95JIS62291984handadd }
8834 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8835 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8836 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8837 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8839 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8840 { T.61-7bit iso-ir-102 csISO102T617bit }
8841 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8842 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8843 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8844 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8845 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8846 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8847 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8848 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8849 arabic csISOLatinArabic }
8850 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8851 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8852 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8853 greek greek8 csISOLatinGreek }
8854 { T.101-G2 iso-ir-128 csISO128T101G2 }
8855 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8857 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8858 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8859 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8860 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8861 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8862 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8863 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8864 csISOLatinCyrillic }
8865 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8866 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8867 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8868 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8869 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8870 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8871 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8872 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8873 { ISO_10367-box iso-ir-155 csISO10367Box }
8874 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8875 { latin-lap lap iso-ir-158 csISO158Lap }
8876 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8877 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8880 { JIS_X0201 X0201 csHalfWidthKatakana }
8881 { KSC5636 ISO646-KR csKSC5636 }
8882 { ISO-10646-UCS-2 csUnicode }
8883 { ISO-10646-UCS-4 csUCS4 }
8884 { DEC-MCS dec csDECMCS }
8885 { hp-roman8 roman8 r8 csHPRoman8 }
8886 { macintosh mac csMacintosh }
8887 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8889 { IBM038 EBCDIC-INT cp038 csIBM038 }
8890 { IBM273 CP273 csIBM273 }
8891 { IBM274 EBCDIC-BE CP274 csIBM274 }
8892 { IBM275 EBCDIC-BR cp275 csIBM275 }
8893 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8894 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8895 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8896 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8897 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8898 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8899 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8900 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8901 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8902 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8903 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8904 { IBM437 cp437 437 csPC8CodePage437 }
8905 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8906 { IBM775 cp775 csPC775Baltic }
8907 { IBM850 cp850 850 csPC850Multilingual }
8908 { IBM851 cp851 851 csIBM851 }
8909 { IBM852 cp852 852 csPCp852 }
8910 { IBM855 cp855 855 csIBM855 }
8911 { IBM857 cp857 857 csIBM857 }
8912 { IBM860 cp860 860 csIBM860 }
8913 { IBM861 cp861 861 cp-is csIBM861 }
8914 { IBM862 cp862 862 csPC862LatinHebrew }
8915 { IBM863 cp863 863 csIBM863 }
8916 { IBM864 cp864 csIBM864 }
8917 { IBM865 cp865 865 csIBM865 }
8918 { IBM866 cp866 866 csIBM866 }
8919 { IBM868 CP868 cp-ar csIBM868 }
8920 { IBM869 cp869 869 cp-gr csIBM869 }
8921 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8922 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8923 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8924 { IBM891 cp891 csIBM891 }
8925 { IBM903 cp903 csIBM903 }
8926 { IBM904 cp904 904 csIBBM904 }
8927 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8928 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8929 { IBM1026 CP1026 csIBM1026 }
8930 { EBCDIC-AT-DE csIBMEBCDICATDE }
8931 { EBCDIC-AT-DE-A csEBCDICATDEA }
8932 { EBCDIC-CA-FR csEBCDICCAFR }
8933 { EBCDIC-DK-NO csEBCDICDKNO }
8934 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8935 { EBCDIC-FI-SE csEBCDICFISE }
8936 { EBCDIC-FI-SE-A csEBCDICFISEA }
8937 { EBCDIC-FR csEBCDICFR }
8938 { EBCDIC-IT csEBCDICIT }
8939 { EBCDIC-PT csEBCDICPT }
8940 { EBCDIC-ES csEBCDICES }
8941 { EBCDIC-ES-A csEBCDICESA }
8942 { EBCDIC-ES-S csEBCDICESS }
8943 { EBCDIC-UK csEBCDICUK }
8944 { EBCDIC-US csEBCDICUS }
8945 { UNKNOWN-8BIT csUnknown8BiT }
8946 { MNEMONIC csMnemonic }
8951 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8952 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8953 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8954 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8955 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8956 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8957 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8958 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8959 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8960 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8961 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8962 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8963 { IBM1047 IBM-1047 }
8964 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8965 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8966 { UNICODE-1-1 csUnicode11 }
8969 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8970 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8972 { ISO-8859-15 ISO_8859-15 Latin-9 }
8973 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8974 { GBK CP936 MS936 windows-936 }
8975 { JIS_Encoding csJISEncoding }
8976 { Shift_JIS MS_Kanji csShiftJIS }
8977 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8979 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8980 { ISO-10646-UCS-Basic csUnicodeASCII }
8981 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8982 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8983 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8984 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8985 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8986 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8987 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8988 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8989 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8990 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8991 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8992 { Ventura-US csVenturaUS }
8993 { Ventura-International csVenturaInternational }
8994 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8995 { PC8-Turkish csPC8Turkish }
8996 { IBM-Symbols csIBMSymbols }
8997 { IBM-Thai csIBMThai }
8998 { HP-Legal csHPLegal }
8999 { HP-Pi-font csHPPiFont }
9000 { HP-Math8 csHPMath8 }
9001 { Adobe-Symbol-Encoding csHPPSMath }
9002 { HP-DeskTop csHPDesktop }
9003 { Ventura-Math csVenturaMath }
9004 { Microsoft-Publishing csMicrosoftPublishing }
9005 { Windows-31J csWindows31J }
9010 proc tcl_encoding {enc} {
9011 global encoding_aliases
9012 set names [encoding names]
9013 set lcnames [string tolower $names]
9014 set enc [string tolower $enc]
9015 set i [lsearch -exact $lcnames $enc]
9017 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9018 if {[regsub {^iso[-_]} $enc iso encx]} {
9019 set i [lsearch -exact $lcnames $encx]
9023 foreach l $encoding_aliases {
9024 set ll [string tolower $l]
9025 if {[lsearch -exact $ll $enc] < 0} continue
9026 # look through the aliases for one that tcl knows about
9028 set i [lsearch -exact $lcnames $e]
9030 if {[regsub {^iso[-_]} $e iso ex]} {
9031 set i [lsearch -exact $lcnames $ex]
9040 return [lindex $names $i]
9045 # First check that Tcl/Tk is recent enough
9046 if {[catch {package require Tk 8.4} err]} {
9047 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9048 Gitk requires at least Tcl/Tk 8.4."]
9054 set wrcomcmd "git diff-tree --stdin -p --pretty"
9058 set gitencoding [exec git config --get i18n.commitencoding]
9060 if {$gitencoding == ""} {
9061 set gitencoding "utf-8"
9063 set tclencoding [tcl_encoding $gitencoding]
9064 if {$tclencoding == {}} {
9065 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9068 set mainfont {Helvetica 9}
9069 set textfont {Courier 9}
9070 set uifont {Helvetica 9 bold}
9072 set findmergefiles 0
9080 set cmitmode "patch"
9081 set wrapcomment "none"
9085 set showlocalchanges 1
9087 set datetimeformat "%Y-%m-%d %H:%M:%S"
9089 set colors {green red blue magenta darkgrey brown orange}
9092 set diffcolors {red "#00a000" blue}
9094 set selectbgcolor gray85
9096 ## For msgcat loading, first locate the installation location.
9097 if { [info exists ::env(GITK_MSGSDIR)] } {
9098 ## Msgsdir was manually set in the environment.
9099 set gitk_msgsdir $::env(GITK_MSGSDIR)
9101 ## Let's guess the prefix from argv0.
9102 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9103 set gitk_libdir [file join $gitk_prefix share gitk lib]
9104 set gitk_msgsdir [file join $gitk_libdir msgs]
9108 ## Internationalization (i18n) through msgcat and gettext. See
9109 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9110 package require msgcat
9111 namespace import ::msgcat::mc
9112 ## And eventually load the actual message catalog
9113 ::msgcat::mcload $gitk_msgsdir
9115 catch {source ~/.gitk}
9117 font create optionfont -family sans-serif -size -12
9119 parsefont mainfont $mainfont
9120 eval font create mainfont [fontflags mainfont]
9121 eval font create mainfontbold [fontflags mainfont 1]
9123 parsefont textfont $textfont
9124 eval font create textfont [fontflags textfont]
9125 eval font create textfontbold [fontflags textfont 1]
9127 parsefont uifont $uifont
9128 eval font create uifont [fontflags uifont]
9130 # check that we can find a .git directory somewhere...
9131 if {[catch {set gitdir [gitdir]}]} {
9132 show_error {} . [mc "Cannot find a git repository here."]
9135 if {![file isdirectory $gitdir]} {
9136 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9142 set cmdline_files {}
9147 "-d" { set datemode 1 }
9150 lappend revtreeargs $arg
9153 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9157 lappend revtreeargs $arg
9163 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9164 # no -- on command line, but some arguments (other than -d)
9166 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9167 set cmdline_files [split $f "\n"]
9168 set n [llength $cmdline_files]
9169 set revtreeargs [lrange $revtreeargs 0 end-$n]
9170 # Unfortunately git rev-parse doesn't produce an error when
9171 # something is both a revision and a filename. To be consistent
9172 # with git log and git rev-list, check revtreeargs for filenames.
9173 foreach arg $revtreeargs {
9174 if {[file exists $arg]} {
9175 show_error {} . [mc "Ambiguous argument '%s': both revision\
9181 # unfortunately we get both stdout and stderr in $err,
9182 # so look for "fatal:".
9183 set i [string first "fatal:" $err]
9185 set err [string range $err [expr {$i + 6}] end]
9187 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9193 # find the list of unmerged files
9197 set fd [open "| git ls-files -u" r]
9199 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9202 while {[gets $fd line] >= 0} {
9203 set i [string first "\t" $line]
9204 if {$i < 0} continue
9205 set fname [string range $line [expr {$i+1}] end]
9206 if {[lsearch -exact $mlist $fname] >= 0} continue
9208 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9209 lappend mlist $fname
9214 if {$nr_unmerged == 0} {
9215 show_error {} . [mc "No files selected: --merge specified but\
9216 no files are unmerged."]
9218 show_error {} . [mc "No files selected: --merge specified but\
9219 no unmerged files are within file limit."]
9223 set cmdline_files $mlist
9226 set nullid "0000000000000000000000000000000000000000"
9227 set nullid2 "0000000000000000000000000000000000000001"
9229 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9236 set highlight_paths {}
9238 set searchdirn -forwards
9242 set markingmatches 0
9243 set linkentercount 0
9244 set need_redisplay 0
9251 set selectedhlview [mc "None"]
9252 set highlight_related [mc "None"]
9253 set highlight_files {}
9266 # wait for the window to become visible
9268 wm title . "[file tail $argv0]: [file tail [pwd]]"
9271 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9272 # create a view for the files/dirs specified on the command line
9276 set viewname(1) [mc "Command line"]
9277 set viewfiles(1) $cmdline_files
9278 set viewargs(1) $revtreeargs
9281 .bar.view entryconf [mc "Edit view..."] -state normal
9282 .bar.view entryconf [mc "Delete view"] -state normal
9285 if {[info exists permviews]} {
9286 foreach v $permviews {
9289 set viewname($n) [lindex $v 0]
9290 set viewfiles($n) [lindex $v 1]
9291 set viewargs($n) [lindex $v 2]