Merge branch 'master' into dev
[git/mingw.git] / gitk
blobaadc18db92e8a5f02d65bf0b332a73c5755decea
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
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.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
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.
24 proc run args {
25 global isonrunq runq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
30 after idle dorunq
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} {
41 global runq
43 fileevent $fd readable {}
44 if {$runq eq {}} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
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]
79 } else {
80 fileevent $fd readable [list filereadable $fd $script]
82 } elseif {$fd eq {}} {
83 unset isonrunq($script)
85 set t0 $t1
86 if {$t1 - $tstart >= 80} break
88 if {$runq ne {}} {
89 after idle dorunq
93 # Start off a git rev-list process and arrange to read its output
94 proc start_rev_list {view} {
95 global startmsecs
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
107 varcinit $view
109 set commits [eval exec git rev-parse --default HEAD --revs-only \
110 $viewargs($view)]
111 set viewincl($view) {}
112 foreach c $commits {
113 if {![string match "^*" $c]} {
114 lappend viewincl($view) $c
117 if {[catch {
118 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
119 --boundary $commits "--" $viewfiles($view)] r]
120 } err]} {
121 error_popup "[mc "Error executing git log:"] $err"
122 exit 1
124 set i [incr loginstance]
125 set viewinstances($view) [list $i]
126 set commfd($i) $fd
127 set leftover($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} {
138 set progressdirn 1
139 set progresscoords {0 0}
140 set proglastnc 0
144 proc stop_rev_list {view} {
145 global commfd viewinstances leftover
147 foreach inst $viewinstances($view) {
148 set fd $commfd($inst)
149 catch {
150 set pid [pid $fd]
151 exec kill $pid
153 catch {close $fd}
154 nukefile $fd
155 unset commfd($inst)
156 unset leftover($inst)
158 set viewinstances($view) {}
161 proc getcommits {} {
162 global canv curview
164 initlayout
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
173 global mainheadid
175 set oldmainid $mainheadid
176 rereadrefs
177 if {$showlocalchanges} {
178 if {$mainheadid ne $oldmainid} {
179 dohidelocalchanges
181 if {[commitinview $mainheadid $curview]} {
182 dodiffindex
185 set view $curview
186 set commits [exec git rev-parse --default HEAD --revs-only \
187 $viewargs($view)]
188 set pos {}
189 set neg {}
190 foreach c $commits {
191 if {[string match "^*" $c]} {
192 lappend neg $c
193 } else {
194 if {!([info exists varcid($view,$c)] ||
195 [lsearch -exact $viewincl($view) $c] >= 0)} {
196 lappend pos $c
200 if {$pos eq {}} {
201 return
203 foreach id $viewincl($view) {
204 lappend neg "^$id"
206 set viewincl($view) [concat $viewincl($view) $pos]
207 if {[catch {
208 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
209 --boundary $pos $neg "--" $viewfiles($view)] r]
210 } err]} {
211 error_popup "Error executing git log: $err"
212 exit 1
214 if {$viewactive($view) == 0} {
215 set startmsecs [clock clicks -milliseconds]
217 set i [incr loginstance]
218 lappend viewinstances($view) $i
219 set commfd($i) $fd
220 set leftover($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"
229 if {$showneartags} {
230 getallcommits
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}
242 adjustprogress
244 resetvarcs $curview
245 catch {unset selectedline}
246 catch {unset currentid}
247 catch {unset thickerline}
248 catch {unset treediffs}
249 readrefs
250 changedrefs
251 if {$showneartags} {
252 getallcommits
254 clear_display
255 catch {unset commitinterest}
256 catch {unset cached_commitrow}
257 setcanvscroll
258 getcommits
261 # This makes a string representation of a positive integer which
262 # sorts as a string in numerical order
263 proc strrep {n} {
264 if {$n < 16} {
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) {}
289 set varcmod($view) 0
290 set vrowmod($view) 0
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,*] {
299 unset varcid($vid)
300 unset children($vid)
301 unset parents($vid)
303 # some commits might have children but haven't been seen yet
304 foreach vid [array names children $view,*] {
305 unset children($vid)
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)]
322 set vid $view,$id
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]} {
329 set cdate 0
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]"
337 } else {
338 set tok {}
340 set ka 0
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} {
345 set ki $kid
346 set ka $k
347 set tok [lindex $varctok($view) $k]
350 if {$ka != 0} {
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} {
357 set c $ka
358 set b [lindex $vdownptr($view) $ka]
359 } else {
360 set b [lindex $vleftptr($view) $c]
362 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
363 set c $b
364 set b [lindex $vleftptr($view) $c]
366 if {$c == $ka} {
367 lset vdownptr($view) $ka $a
368 lappend vbackptr($view) 0
369 } else {
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
376 if {$b != 0} {
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
386 return $a
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]
396 if {$i <= 0} return
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]
425 set todo {}
426 set isrelated($a) 1
427 set kidchanged($a) 1
428 set ntot 0
429 while {$a != 0} {
430 if {[info exists isrelated($a)]} {
431 lappend todo $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
439 incr ntot
440 set b [lindex $vdownptr($v) $a]
441 if {$b == 0} {
442 while {$a != 0} {
443 set b [lindex $vleftptr($v) $a]
444 if {$b != 0} break
445 set a [lindex $vupptr($v) $a]
448 set a $b
450 foreach a $todo {
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] \
455 $children($v,$id)]
457 set oldtok [lindex $varctok($v) $a]
458 if {!$datemode} {
459 set tok {}
460 } else {
461 set tok $oldtok
463 set ka 0
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} {
468 set ki $kid
469 set ka $k
470 set tok [lindex $varctok($v) $k]
473 if {$ka != 0} {
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} {
479 continue
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
485 } else {
486 set sortkids($p) 1
489 lset varctok($v) $a $tok
490 set b [lindex $vupptr($v) $a]
491 if {$b != $ka} {
492 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
493 modify_arc $v $ka
495 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
496 modify_arc $v $b
498 set c [lindex $vbackptr($v) $a]
499 set d [lindex $vleftptr($v) $a]
500 if {$c == 0} {
501 lset vdownptr($v) $b $d
502 } else {
503 lset vleftptr($v) $c $d
505 if {$d != 0} {
506 lset vbackptr($v) $d $c
508 lset vupptr($v) $a $ka
509 set c [lindex $vlastins($v) $ka]
510 if {$c == 0 || \
511 [string compare $tok [lindex $varctok($v) $c]] < 0} {
512 set c $ka
513 set b [lindex $vdownptr($v) $ka]
514 } else {
515 set b [lindex $vleftptr($v) $c]
517 while {$b != 0 && \
518 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
519 set c $b
520 set b [lindex $vleftptr($v) $c]
522 if {$c == $ka} {
523 lset vdownptr($v) $ka $a
524 lset vbackptr($v) $a 0
525 } else {
526 lset vleftptr($v) $c $a
527 lset vbackptr($v) $a $c
529 lset vleftptr($v) $a $b
530 if {$b != 0} {
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] \
539 $children($v,$id)]
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]} {
551 splitvarc $p $v
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} {
558 renumbervarc $pa $v
562 proc insertrow {id p v} {
563 global varcid varccommits parents children cmitlisted
564 global commitidx varctok vtokmod
566 set a $varcid($v,$p)
567 set i [lsearch -exact $varccommits($v,$a) $p]
568 if {$i < 0} {
569 puts "oops: insertrow can't find [shortids $p] on arc $a"
570 return
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
577 incr commitidx($v)
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} {
581 modify_arc $v $a $i
583 drawvisible
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"
592 return
594 set p [lindex $parents($v,$id) 0]
595 set a $varcid($v,$id)
596 set i [lsearch -exact $varccommits($v,$a) $id]
597 if {$i < 0} {
598 puts "oops: removerow can't find [shortids $id] on arc $a"
599 return
601 unset varcid($v,$id)
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]
608 if {$j >= 0} {
609 set children($v,$p) [lreplace $children($v,$p) $j $j]
611 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
612 modify_arc $v $a $i
614 if {[info exist currentid] && $id eq $currentid} {
615 unset currentid
616 unset selectedline
618 drawvisible
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]
633 set varcmod($v) $a
634 if {$v == $curview} {
635 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
636 set a [lindex $vupptr($v) $a]
637 set lim {}
639 set r 0
640 if {$a != 0} {
641 if {$lim eq {}} {
642 set lim [llength $varccommits($v,$a)]
644 set r [expr {[lindex $varcrow($v) $a] + $lim}]
646 set vrowmod($v) $r
647 undolayout $r
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}]
662 set a $varcmod($v)
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]
668 if {$a == 0} {
669 set a [lindex $vdownptr($v) 0]
670 if {$a == 0} return
671 set vrownum($v) {0}
672 set varcorder($v) [list $a]
673 lset varcix($v) $a 0
674 lset varcrow($v) $a 0
675 set arcn 0
676 set row 0
677 } else {
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} {
681 return
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}
696 while {1} {
697 set p $a
698 incr row [llength $varccommits($v,$a)]
699 # go down if possible
700 set b [lindex $vdownptr($v) $a]
701 if {$b == 0} {
702 # if not, go left, or go up until we can go left
703 while {$a != 0} {
704 set b [lindex $vleftptr($v) $a]
705 if {$b != 0} break
706 set a [lindex $vupptr($v) $a]
708 if {$a == 0} break
710 set a $b
711 incr arcn
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]
718 set varcmod($v) $p
719 set vrowmod($v) $row
720 if {[info exists currentid]} {
721 set selectedline [rowofcommit $currentid]
725 # Test whether view $v contains commit $id
726 proc commitinview {id v} {
727 global varcid
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 set v $curview
738 if {![info exists varcid($v,$id)]} {
739 puts "oops rowofcommit no arc for [shortids $id]"
740 return {}
742 set a $varcid($v,$id)
743 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
744 update_arcrows $v
746 if {[info exists cached_commitrow($id)]} {
747 return $cached_commitrow($id)
749 set i [lsearch -exact $varccommits($v,$a) $id]
750 if {$i < 0} {
751 puts "oops didn't find commit [shortids $id] in arc $a"
752 return {}
754 incr i [lindex $varcrow($v) $a]
755 set cached_commitrow($id) $i
756 return $i
759 proc bsearch {l elt} {
760 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
761 return 0
763 set lo 0
764 set hi [llength $l]
765 while {$hi - $lo > 1} {
766 set mid [expr {int(($lo + $hi) / 2)}]
767 set t [lindex $l $mid]
768 if {$elt < $t} {
769 set hi $mid
770 } elseif {$elt > $t} {
771 set lo $mid
772 } else {
773 return $mid
776 return $lo
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)]
795 if {$l < $r + $al} {
796 if {$l < $r} {
797 set pad [ntimes [expr {$r - $l}] {}]
798 set displayorder [concat $displayorder $pad]
799 set parentlist [concat $parentlist $pad]
800 } elseif {$l > $r} {
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 {}} {
809 set i $r
810 foreach id $varccommits($curview,$a) {
811 lset displayorder $i $id
812 lset parentlist $i $parents($curview,$id)
813 incr i
816 incr r $al
820 proc commitonrow {row} {
821 global displayorder
823 set id [lindex $displayorder $row]
824 if {$id eq {}} {
825 make_disporder $row [expr {$row + 1}]
826 set id [lindex $displayorder $row]
828 return $id
831 proc closevarcs {v} {
832 global varctok varccommits varcid parents children
833 global cmitlisted commitidx commitinterest vtokmod
835 set missing_parents 0
836 set scripts {}
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
843 incr missing_parents
844 set cmitlisted($v,$p) 0
845 set parents($v,$p) {}
846 if {[llength $children($v,$p)] == 1 &&
847 [llength $parents($v,$id)] == 1} {
848 set b $a
849 } else {
850 set b [newvarc $v $p]
852 set varcid($v,$p) $b
853 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
854 modify_arc $v $b
856 lappend varccommits($v,$b) $p
857 incr commitidx($v)
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} {
867 foreach s $scripts {
868 eval $s
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]} {
883 set stuff "\0"
885 if {$stuff == {}} {
886 if {![eof $fd]} {
887 return 1
889 global commfd viewcomplete viewactive viewname progresscoords
890 global viewinstances
891 unset commfd($inst)
892 set i [lsearch -exact $viewinstances($view) $inst]
893 if {$i >= 0} {
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]} {
899 set fv {}
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"} {
907 append err \
908 " (Note: arguments to gitk are passed to git rev-list\
909 to allow selection of commits to be displayed.)"
911 } else {
912 set err "Error reading commits$fv: $err"
914 error_popup $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
920 closevarcs $view
921 notbusy $view
922 set progresscoords {0 0}
923 adjustprogress
925 if {$view == $curview} {
926 run chewcommits $view
928 return 0
930 set start 0
931 set gotsome 0
932 set scripts {}
933 while 1 {
934 set i [string first "\0" $stuff $start]
935 if {$i < 0} {
936 append leftover($inst) [string range $stuff $start end]
937 break
939 if {$start == 0} {
940 set cmit $leftover($inst)
941 append cmit [string range $stuff 0 [expr {$i - 1}]]
942 set leftover($inst) {}
943 } else {
944 set cmit [string range $stuff $start [expr {$i - 1}]]
946 set start [expr {$i + 1}]
947 set j [string first "\n" $cmit]
948 set ok 0
949 set listed 1
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] {
954 "-" {set listed 0}
955 "<" {set listed 2}
956 ">" {set listed 3}
958 set ids [string range $ids 1 end]
960 set ok 1
961 foreach id $ids {
962 if {[string length $id] != 40} {
963 set ok 0
964 break
968 if {!$ok} {
969 set shortcmit $cmit
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}"
974 exit 1
976 set id [lindex $ids 0]
977 set vid $view,$id
978 if {!$listed && [info exists parents($vid)]} continue
979 if {$listed} {
980 set olds [lrange $ids 1 end]
981 } else {
982 set olds {}
984 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
985 set cmitlisted($vid) $listed
986 set parents($vid) $olds
987 set a 0
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 &&
993 (!$datemode ||
994 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
995 set a $varcid($view,$k)
998 if {$a == 0} {
999 # new arc
1000 set a [newvarc $view $id]
1002 set varcid($vid) $a
1003 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1004 modify_arc $view $a
1006 lappend varccommits($view,$a) $id
1008 set i 0
1009 foreach p $olds {
1010 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1011 set vp $view,$p
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] \
1015 $children($vp)]
1016 catch {unset ordertok}
1018 if {[info exists varcid($view,$p)]} {
1019 fix_reversal $p $a $view
1022 incr i
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)
1032 set gotsome 1
1034 if {$gotsome} {
1035 run chewcommits $view
1036 foreach s $scripts {
1037 eval $s
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}]
1048 if {$r >= 1.0} {
1049 set r 1.0
1050 set progressdirn 0
1052 if {$r > 0.2} {
1053 set l [expr {$r - 0.2}]
1055 } else {
1056 set l [expr {$l - $inc}]
1057 if {$l <= 0.0} {
1058 set l 0.0
1059 set progressdirn 1
1061 set r [expr {$l + 0.2}]
1063 set progresscoords [list $l $r]
1064 adjustprogress
1067 return 2
1070 proc chewcommits {view} {
1071 global curview hlview viewcomplete
1072 global pending_select
1074 if {$view == $curview} {
1075 layoutmore
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]
1083 selectline $row 1
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"
1089 } else {
1090 show_status [mc "No commits selected"]
1092 notbusy layout
1095 if {[info exists hlview] && $view == $hlview} {
1096 vhighlightmore
1098 return 0
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
1109 set inhdr 1
1110 set comment {}
1111 set headline {}
1112 set auname {}
1113 set audate {}
1114 set comname {}
1115 set comdate {}
1116 set hdrend [string first "\n\n" $contents]
1117 if {$hdrend < 0} {
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]
1133 set headline {}
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]
1137 if {$i >= 0} {
1138 set headline [string range $headline 0 $i]
1140 set headline [string trimright $headline]
1141 set i [string first "\r" $headline]
1142 if {$i >= 0} {
1143 set headline [string trimright [string range $headline 0 $i]]
1145 if {!$listed} {
1146 # git rev-list indents the comment by 4 spaces;
1147 # if we got this via git cat-file, add the indentation
1148 set newcomment {}
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
1168 } else {
1169 readcommit $id
1170 if {![info exists commitinfo($id)]} {
1171 set commitinfo($id) [list [mc "No commit information available"]]
1174 return 1
1177 proc readrefs {} {
1178 global tagids idtags headids idheads tagobjid
1179 global otherrefids idotherrefs mainhead mainheadid
1181 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1182 catch {unset $v}
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]
1206 } else {
1207 set tagobjid($name) $id
1209 set tagids($name) $id
1210 lappend idtags($id) $name
1211 } else {
1212 set otherrefids($name) $id
1213 lappend idotherrefs($id) $name
1216 catch {close $refd}
1217 set mainhead {}
1218 set mainheadid {}
1219 catch {
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} {
1237 break
1240 return $row
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} {
1257 unset idheads($id)
1258 } else {
1259 set i [lsearch -exact $idheads($id) $name]
1260 if {$i >= 0} {
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"
1274 tkwait window $top
1277 proc error_popup msg {
1278 set w .error
1279 toplevel $w
1280 wm transient $w .
1281 show_error $w $w $msg
1284 proc confirm_popup msg {
1285 global confirm_ok
1286 set confirm_ok 0
1287 set w .confirm
1288 toplevel $w
1289 wm transient $w .
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"
1297 tkwait window $w
1298 return $confirm_ok
1301 proc makewindow {} {
1302 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1303 global tabstop
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
1315 global have_tk85
1317 menu .bar
1318 .bar add cascade -label [mc "File"] -menu .bar.file
1319 .bar configure -font uifont
1320 menu .bar.file
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
1327 menu .bar.edit
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 \
1336 -state disabled
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
1342 menu .bar.help
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)
1364 frame .tf.histframe
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
1370 canvas $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
1376 canvas $canv2 \
1377 -selectbackground $selectbgcolor \
1378 -background $bgcolor -bd 0 -yscrollincr $linespc
1379 .tf.histframe.pwclist add $canv2
1380 set canv3 .tf.histframe.pwclist.canv3
1381 canvas $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
1396 frame .tf.bar
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}
1445 set fprogcoord 0
1446 set rprogcoord 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 \
1457 -side left -fill y
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
1468 set findstring {}
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
1493 .ctop add .tf
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)
1505 } else {
1506 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1508 frame .bleft.top
1509 frame .bleft.mid
1511 button .bleft.top.search -text [mc "Search"] -command dosearch \
1512 -font uifont
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"]: " \
1526 -font uifont
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
1540 if {$have_tk85} {
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
1573 set mergemax 16
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)
1581 # lower right
1582 frame .bright
1583 frame .bright.mode
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"]
1594 text $cflist \
1595 -selectbackground $selectbgcolor \
1596 -background $bgcolor -foreground $fgcolor \
1597 -font mainfont \
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
1612 .ctop add .pwbottom
1614 # restore window position if known
1615 if {[info exists geometry(main)]} {
1616 wm geometry . "$geometry(main)"
1619 if {[tk windowingsystem] eq {aqua}} {
1620 set M1B M1
1621 } else {
1622 set M1B Control
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 }
1632 } else {
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"
1665 bindkey z "goback"
1666 bindkey x "goforw"
1667 bindkey i "selnextline -1"
1668 bindkey k "selnextline 1"
1669 bindkey j "goback"
1670 bindkey l "goforw"
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}
1677 bindkey f nextfile
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"] \
1713 -command cherrypick
1714 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1715 -command resethead
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"] \
1731 -command cobranch
1732 $headctxmenu add command -label [mc "Remove this branch"] \
1733 -command rmbranch
1735 global flist_menu
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]
1750 if {$w ne ""} {
1751 set u [expr {$D < 0 ? 5 : -5}]
1752 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1753 allcanvs yview scroll $u units
1754 } else {
1755 catch {
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] {
1767 if {$c == $w} {
1768 $c scan $op $x $y
1769 } else {
1770 $c scan $op 0 $y
1775 proc scrollcanv {cscroll f0 f1} {
1776 $cscroll set $f0 $f1
1777 drawvisible
1778 flushhighlights
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} {
1785 global entries
1786 bind . $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
1797 # the entry widgets
1798 proc click {w} {
1799 global ctext entries
1800 foreach e [concat $entries $ctext] {
1801 if {$w == $e} return
1803 focus .
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
1822 update
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]
1835 update
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
1849 catch {
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)]}"
1885 puts $f "}"
1886 close $f
1887 file rename -force "~/.gitk-new" "~/.gitk"
1889 set stuffsaved 1
1892 proc resizeclistpanes {win w} {
1893 global oldwidth
1894 if {[info exists oldwidth($win)]} {
1895 set s0 [$win sash coord 0]
1896 set s1 [$win sash coord 1]
1897 if {$w < 60} {
1898 set sash0 [expr {int($w/2 - 2)}]
1899 set sash1 [expr {int($w*5/6 - 2)}]
1900 } else {
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])}]
1904 if {$sash0 < 30} {
1905 set sash0 30
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} {
1924 global oldwidth
1925 if {[info exists oldwidth($win)]} {
1926 set s0 [$win sash coord 0]
1927 if {$w < 60} {
1928 set sash0 [expr {int($w*3/4 - 2)}]
1929 } else {
1930 set factor [expr {1.0 * $w / $oldwidth($win)}]
1931 set sash0 [expr {int($factor * [lindex $s0 0])}]
1932 if {$sash0 < 45} {
1933 set sash0 45
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
1946 eval $canv $args
1947 eval $canv2 $args
1948 eval $canv3 $args
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
1958 proc about {} {
1959 global uifont
1960 set w .about
1961 if {[winfo exists $w]} {
1962 raise $w
1963 return
1965 toplevel $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"
1984 proc keys {} {
1985 global uifont
1986 set w .keys
1987 if {[winfo exists $w]} {
1988 raise $w
1989 return
1991 if {[tk windowingsystem] eq {aqua}} {
1992 set M1T Cmd
1993 } else {
1994 set M1T Ctrl
1996 toplevel $w
1997 wm title $w [mc "Gitk key bindings"]
1998 message $w.m -text [mc "
1999 Gitk key bindings:
2001 <$M1T-Q> Quit
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
2023 <$M1T-F> Find
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
2035 <F5> Update
2036 "] \
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
2054 set ix 0
2055 set treeindex() 0
2056 set lev 0
2057 set prefix {}
2058 set prefixend -1
2059 set prefendstack {}
2060 set htstack {}
2061 set ht 0
2062 set treecontents() {}
2063 $w conf -state normal
2064 foreach f $l {
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]
2076 incr lev -1
2078 set tail [string range $f [expr {$prefixend+1}] end]
2079 while {[set slash [string first "/" $tail]] >= 0} {
2080 lappend htstack $ht
2081 set ht 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
2087 append prefix $d
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} {
2093 set ht 1
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
2098 set str "\n"
2099 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2100 $w insert end $str
2101 $w image create end -align center -image $bm -padx 1 \
2102 -name a:$ix
2103 $w insert end $d [highlight_tag $prefix]
2104 $w mark set s:$ix "end -1c"
2105 $w mark gravity s:$ix left
2107 incr lev
2109 if {$tail ne {}} {
2110 if {$lev <= $openlevs} {
2111 incr ht
2112 set str "\n"
2113 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2114 $w insert end $str
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
2134 set y 2
2135 set prefix {}
2136 while {1} {
2137 foreach e $treecontents($prefix) {
2138 if {$y == $l} {
2139 return "$prefix$e"
2141 set n 1
2142 if {[string index $e end] eq "/"} {
2143 set n $treeheight($prefix$e)
2144 if {$y + $n > $l} {
2145 append prefix $e
2146 incr y
2147 break
2150 incr y $n
2155 proc highlight_tree {y prefix} {
2156 global treeheight treecontents cflist
2158 foreach e $treecontents($prefix) {
2159 set path $prefix$e
2160 if {[highlight_tag $path] ne {}} {
2161 $cflist tag add bold $y.0 "$y.0 lineend"
2163 incr y
2164 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2165 set y [highlight_tree $y $path]
2168 return $y
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
2195 set lev 0
2196 set str "\n"
2197 set n [llength $treecontents($dir)]
2198 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2199 incr lev
2200 append str "\t"
2201 incr treeheight($x) $n
2203 foreach e $treecontents($dir) {
2204 set de $dir$e
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 \
2212 -name a:$iy
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
2217 } else {
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]
2228 if {$l < $top} {
2229 $w yview $l.0
2230 } elseif {$l + $n + 1 > $top + $ht} {
2231 set top [expr {$l + $n + 2 - $ht}]
2232 if {$l < $top} {
2233 set top $l
2235 $w yview $top.0
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"
2247 set cflist_top $l
2248 if {$l == 1} {
2249 $ctext yview 1.0
2250 return
2252 set e [linetoelt $l]
2253 if {[string index $e end] ne "/"} {
2254 showfile $e
2255 } elseif {$treediropen($e)} {
2256 treeclosedir $w $e
2257 } else {
2258 treeopendir $w $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,
2274 0x00, 0x00};
2275 } -maskdata {
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,
2281 0x08, 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,
2289 0x00, 0x00};
2290 } -maskdata {
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,
2296 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};
2305 } -maskdata {
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};
2312 set rectdata {
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};
2319 set rectmask {
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
2336 if {$first ne {}} {
2337 $cflist insert end $first
2338 set cflist_top 1
2339 $cflist tag add highlight 1.0 "1.0 lineend"
2340 } else {
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]} {
2352 return "bold"
2355 return {}
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"
2370 } else {
2371 highlight_tree 2 {}
2373 $cflist conf -state disabled
2376 proc unhighlight_filelist {} {
2377 global cflist
2379 $cflist conf -state normal
2380 $cflist tag remove bold 1.0 end
2381 $cflist conf -state disabled
2384 proc add_flist {fl} {
2385 global cflist
2387 $cflist conf -state normal
2388 foreach f $fl {
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"
2403 set cflist_top $l
2404 if {$l == 1} {
2405 $ctext yview 1.0
2406 } else {
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
2415 stopfinding
2416 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2417 if {$l <= 1} return
2418 if {$cmitmode eq "tree"} {
2419 set e [linetoelt $l]
2420 if {[string index $e end] eq "/"} return
2421 } else {
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:"]} {
2433 set findstring $x
2434 } else {
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]} {
2444 return $str
2446 if {![string match "*\['\"\\]*" $str]} {
2447 return "\"$str\""
2449 if {![string match "*'*" $str]} {
2450 return "'$str'"
2452 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2455 proc shellarglist {l} {
2456 set str {}
2457 foreach a $l {
2458 if {$str ne {}} {
2459 append str " "
2461 append str [shellquote $a]
2463 return $str
2466 proc shelldequote {str} {
2467 set ret {}
2468 set used -1
2469 while {1} {
2470 incr used
2471 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2472 append ret [string range $str $used end]
2473 set used [string length $str]
2474 break
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}]]
2480 set used $first
2482 if {$ch eq " " || $ch eq "\t"} break
2483 incr used
2484 if {$ch eq "'"} {
2485 set first [string first "'" $str $used]
2486 if {$first < 0} {
2487 error "unmatched single-quote"
2489 append ret [string range $str $used [expr {$first - 1}]]
2490 set used $first
2491 continue
2493 if {$ch eq "\\"} {
2494 if {$used >= [string length $str]} {
2495 error "trailing backslash"
2497 append ret [string index $str $used]
2498 continue
2500 # here ch == "\""
2501 while {1} {
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}]]
2509 set used $first
2511 if {$ch eq "\""} break
2512 incr used
2513 append ret [string index $str $used]
2514 incr used
2517 return [list $used $ret]
2520 proc shellsplit {str} {
2521 set l {}
2522 while {1} {
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]
2529 lappend l $word
2531 return $l
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
2541 set top .gitkview
2542 if {[winfo exists $top]} {
2543 raise $top
2544 return
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"]
2552 proc editview {} {
2553 global curview
2554 global viewname viewperm newviewname newviewperm
2555 global viewargs newviewargs
2557 set top .gitkvedit-$curview
2558 if {[winfo exists $top]} {
2559 raise $top
2560 return
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
2570 global uifont
2572 toplevel $top
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) \
2578 -font uifont
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
2599 frame $top.buts
2600 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n] \
2601 -font uifont
2602 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top] \
2603 -font uifont
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
2608 focus $top.t
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
2616 break
2621 proc allviewmenus {n op args} {
2622 # global viewhlmenu
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
2633 if {[catch {
2634 set newargs [shellsplit $newviewargs($n)]
2635 } err]} {
2636 error_popup "[mc "Error in commit selection arguments:"] $err"
2637 wm raise $top
2638 focus $top
2639 return
2641 set files {}
2642 foreach f [split [$top.t get 0.0 end] "\n"] {
2643 set ft [string trim $f]
2644 if {$ft ne {}} {
2645 lappend files $ft
2648 if {![info exists viewfiles($n)]} {
2649 # creating a new view
2650 incr nextviewnum
2651 set viewname($n) $newviewname($n)
2652 set viewperm($n) $newviewperm($n)
2653 set viewfiles($n) $files
2654 set viewargs($n) $newargs
2655 addviewmenu $n
2656 if {!$newishighlight} {
2657 run showview $n
2658 } else {
2659 run addvhighlight $n
2661 } else {
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} {
2675 run reloadcommits
2679 catch {destroy $top}
2682 proc delview {} {
2683 global curview viewperm hlview selectedhlview
2685 if {$curview == 0} return
2686 if {[info exists hlview] && $hlview == $curview} {
2687 set selectedhlview [mc "None"]
2688 unset hlview
2690 allviewmenus $curview delete
2691 set viewperm($curview) 0
2692 showview 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
2704 proc showview {n} {
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
2710 global treediffs
2711 global pending_select
2712 global commitidx
2713 global selectedview selectfirst
2714 global hlview selectedhlview commitinterest
2716 if {$n == $curview} return
2717 set selid {}
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
2733 unselectline
2734 normalline
2735 catch {unset treediffs}
2736 clear_display
2737 if {[info exists hlview] && $hlview == $n} {
2738 unset hlview
2739 set selectedhlview [mc "None"]
2741 catch {unset commitinterest}
2742 catch {unset cached_commitrow}
2743 catch {unset ordertok}
2745 set curview $n
2746 set selectedview $n
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"}]
2750 run refill_reflist
2751 if {![info exists viewcomplete($n)]} {
2752 if {$selid ne {}} {
2753 set pending_select $selid
2755 getcommits
2756 return
2759 set displayorder {}
2760 set parentlist {}
2761 set rowidlist {}
2762 set rowisopt {}
2763 set rowfinal {}
2764 set numcommits $commitidx($n)
2766 catch {unset colormap}
2767 catch {unset rowtextx}
2768 set nextcolor 0
2769 set canvxmax [$canv cget -width]
2770 set curview $n
2771 set row 0
2772 setcanvscroll
2773 set yf 0
2774 set row {}
2775 set selectfirst 0
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}]
2781 if {$ytop < 0} {
2782 set ytop 0
2784 set yf [expr {$ytop * 1.0 / $ymax}]
2786 allcanvs yview moveto $yf
2787 drawvisible
2788 if {$row ne {}} {
2789 selectline $row 0
2790 } elseif {$selid ne {}} {
2791 set pending_select $selid
2792 } else {
2793 set row [first_real_row]
2794 if {$row < $numcommits} {
2795 selectline $row 0
2796 } else {
2797 set selectfirst 1
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)
2826 return 0
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} {
2835 $canv delete secsel
2836 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2837 -outline {{}} -tags secsel \
2838 -fill [$canv cget -selectbackground]]
2839 $canv lower $t
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]]
2853 $canv2 lower $t
2857 proc unbolden {} {
2858 global boldrows
2860 set stillbold {}
2861 foreach row $boldrows {
2862 if {![ishighlighted $row]} {
2863 bolden $row mainfont
2864 } else {
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]} {
2875 delvhighlight
2877 set hlview $n
2878 if {$n != $curview && ![info exists viewcomplete($n)]} {
2879 start_rev_list $n
2881 set vhl_done $commitidx($hlview)
2882 if {$vhl_done > 0} {
2883 drawvisible
2887 proc delvhighlight {} {
2888 global hlview vhighlights
2890 if {![info exists hlview]} return
2891 unset hlview
2892 catch {unset vhighlights}
2893 unbolden
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
2915 set vhl_done $max
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
2926 } else {
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}
2938 unset filehighlight
2939 catch {unset fhighlights}
2940 unbolden
2941 unhighlight_filelist
2943 set highlight_paths {}
2944 after cancel do_file_hl $fh_serial
2945 incr 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
2954 stopfinding
2955 if {$findstring ne {}} {
2956 if {$gdttype eq [mc "containing:"]} {
2957 if {$highlight_files ne {}} {
2958 set highlight_files {}
2959 hfiles_change
2961 findcom_change
2962 } else {
2963 if {$findpattern ne {}} {
2964 set findpattern {}
2965 findcom_change
2967 set highlight_files $findstring
2968 hfiles_change
2970 drawvisible
2972 # enable/disable findtype/findloc menus too
2975 proc find_change {name ix op} {
2976 global gdttype findstring highlight_files
2978 stopfinding
2979 if {$gdttype eq [mc "containing:"]} {
2980 findcom_change
2981 } else {
2982 if {$highlight_files ne $findstring} {
2983 set highlight_files $findstring
2984 hfiles_change
2987 drawvisible
2990 proc findcom_change args {
2991 global nhighlights boldnamerows
2992 global findpattern findtype findstring gdttype
2994 stopfinding
2995 # delete previous highlights, if any
2996 foreach row $boldnamerows {
2997 bolden_name $row mainfont
2999 set boldnamerows {}
3000 catch {unset nhighlights}
3001 unbolden
3002 unmarkmatches
3003 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3004 set findpattern {}
3005 } elseif {$findtype eq [mc "Regexp"]} {
3006 set findpattern $findstring
3007 } else {
3008 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3009 $findstring]
3010 set findpattern "*$e*"
3014 proc makepatterns {l} {
3015 set ret {}
3016 foreach e $l {
3017 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3018 if {[string index $ee end] eq "/"} {
3019 lappend ret "$ee*"
3020 } else {
3021 lappend ret $ee
3022 lappend ret "$ee/*"
3025 return $ret
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]
3034 highlight_filelist
3035 set gdtargs [concat -- $paths]
3036 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3037 set gdtargs [list "-S$highlight_files"]
3038 } else {
3039 # must be "containing:", i.e. we're searching commit info
3040 return
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
3046 set fhl_list {}
3047 drawvisible
3048 flushhighlights
3051 proc flushhighlights {} {
3052 global filehighlight fhl_list
3054 if {[info exists filehighlight]} {
3055 lappend fhl_list {}
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]} {
3074 return 0
3076 set nr 0
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]} {
3097 # strange...
3098 puts "oops, git diff-tree died"
3099 catch {close $filehighlight}
3100 unset filehighlight
3101 return 0
3103 if {[info exists find_dirn]} {
3104 run findmore
3106 return 1
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]
3116 } else {
3117 return [string match $findpattern $f]
3121 proc askfindhighlight {row id} {
3122 global nhighlights commitinfo iddrawn
3123 global findloc
3124 global markingmatches
3126 if {![info exists commitinfo($id)]} {
3127 getcommit $id
3129 set info $commitinfo($id)
3130 set isbold 0
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) &&
3134 [doesmatch $f]} {
3135 if {$ty eq [mc "Author"]} {
3136 set isbold 2
3137 break
3139 set isbold 1
3142 if {$isbold && [info exists iddrawn($id)]} {
3143 if {![ishighlighted $row]} {
3144 bolden $row mainfontbold
3145 if {$isbold > 1} {
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]
3165 if {$m ne {}} {
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]
3172 if {$m ne {}} {
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
3182 rhighlight_none
3183 if {$highlight_related ne [mc "None"]} {
3184 run drawvisible
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"]} {
3198 rhighlight_none
3199 run drawvisible
3203 proc rhighlight_none {} {
3204 global rhighlights
3206 catch {unset rhighlights}
3207 unbolden
3210 proc is_descendent {a} {
3211 global curview children descendent desc_todo
3213 set v $curview
3214 set la [rowofcommit $a]
3215 set todo $desc_todo
3216 set leftover {}
3217 set done 0
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
3222 continue
3224 foreach nk $children($v,$do) {
3225 if {![info exists descendent($nk)]} {
3226 set descendent($nk) 1
3227 lappend todo $nk
3228 if {$nk eq $a} {
3229 set done 1
3233 if {$done} {
3234 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3235 return
3238 set descendent($a) 0
3239 set desc_todo $leftover
3242 proc is_ancestor {a} {
3243 global curview parents ancestor anc_todo
3245 set v $curview
3246 set la [rowofcommit $a]
3247 set todo $anc_todo
3248 set leftover {}
3249 set done 0
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
3254 continue
3256 foreach np $parents($v,$do) {
3257 if {![info exists ancestor($np)]} {
3258 set ancestor($np) 1
3259 lappend todo $np
3260 if {$np eq $a} {
3261 set done 1
3265 if {$done} {
3266 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3267 return
3270 set ancestor($a) 0
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
3279 set isbold 0
3280 if {$highlight_related eq [mc "Descendent"] ||
3281 $highlight_related eq [mc "Not descendent"]} {
3282 if {![info exists descendent($id)]} {
3283 is_descendent $id
3285 if {$descendent($id) == ($highlight_related eq [mc "Descendent"])} {
3286 set isbold 1
3288 } elseif {$highlight_related eq [mc "Ancestor"] ||
3289 $highlight_related eq [mc "Not ancestor"]} {
3290 if {![info exists ancestor($id)]} {
3291 is_ancestor $id
3293 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3294 set isbold 1
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} {
3308 set res {}
3309 foreach id $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]
3314 } else {
3315 lappend res $id
3318 return $res
3321 proc ntimes {n o} {
3322 set ret {}
3323 set o [list $o]
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]
3330 return $ret
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)
3340 set origid $id
3341 set todo {}
3342 while {1} {
3343 if {[info exists varcid($curview,$id)]} {
3344 set a $varcid($curview,$id)
3345 set p [lindex $varcstart($curview) $a]
3346 } else {
3347 set p [lindex $children($curview,$id) 0]
3349 if {[info exists ordertok($p)]} {
3350 set tok $ordertok($p)
3351 break
3353 if {[llength $children($curview,$p)] == 0} {
3354 # it's a root
3355 set tok [lindex $varctok($curview) $a]
3356 break
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]
3362 break
3364 if {[llength $parents($curview,$id)] == 1} {
3365 lappend todo [list $p {}]
3366 } else {
3367 set j [lsearch -exact $parents($curview,$id) $p]
3368 if {$j < 0} {
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
3380 return $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]
3387 if {$i < 0} {
3388 set i 0
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]]} {}
3395 incr i
3396 } else {
3397 if {$t > [ordertoken [lindex $idlist $i]]} {
3398 while {[incr i] < [llength $idlist] &&
3399 $t >= [ordertoken [lindex $idlist $i]]} {}
3402 return $i
3405 proc initlayout {} {
3406 global rowidlist rowisopt rowfinal displayorder parentlist
3407 global numcommits canvxmax canv
3408 global nextcolor
3409 global colormap rowtextx
3410 global selectfirst
3412 set numcommits 0
3413 set displayorder {}
3414 set parentlist {}
3415 set nextcolor 0
3416 set rowidlist {}
3417 set rowisopt {}
3418 set rowfinal {}
3419 set canvxmax [$canv cget -width]
3420 catch {unset colormap}
3421 catch {unset rowtextx}
3422 set selectfirst 1
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
3439 set f [$canv yview]
3440 set y0 [expr {int([lindex $f 0] * $ymax)}]
3441 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3442 if {$r0 < 0} {
3443 set r0 0
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} {
3461 allcanvs delete all
3463 set r0 $numcommits
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
3469 setcanvscroll
3471 set rows [visiblerows]
3472 set r1 [lindex $rows 1]
3473 if {$r1 >= $canshow} {
3474 set r1 [expr {$canshow - 1}]
3476 if {$r0 <= $r1} {
3477 drawcommits $r0 $r1
3479 if {[info exists pending_select] &&
3480 [commitinview $pending_select $curview]} {
3481 selectline [rowofcommit $pending_select] 1
3483 if {$selectfirst} {
3484 if {[info exists selectedline] || [info exists pending_select]} {
3485 set selectfirst 0
3486 } else {
3487 set l [first_real_row]
3488 selectline $l 1
3489 set selectfirst 0
3494 proc doshowlocalchanges {} {
3495 global curview mainheadid
3497 if {[commitinview $mainheadid $curview]} {
3498 dodiffindex
3499 } else {
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
3513 incr lserial
3516 # spawn off a process to do git diff-index --cached HEAD
3517 proc dodiffindex {} {
3518 global lserial showlocalchanges
3520 if {!$showlocalchanges} return
3521 incr lserial
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
3530 set isdiff 1
3531 if {[gets $fd line] < 0} {
3532 if {![eof $fd]} {
3533 return 1
3535 set isdiff 0
3537 # we only need to see one line and we don't really care what it says...
3538 close $fd
3540 if {$serial != $lserial} {
3541 return 0
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
3561 return 0
3564 proc readdifffiles {fd serial} {
3565 global mainheadid nullid nullid2 curview
3566 global commitinfo commitdata lserial
3568 set isdiff 1
3569 if {[gets $fd line] < 0} {
3570 if {![eof $fd]} {
3571 return 1
3573 set isdiff 0
3575 # we only need to see one line and we don't really care what it says...
3576 close $fd
3578 if {$serial != $lserial} {
3579 return 0
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]} {
3588 set p $nullid2
3589 } else {
3590 set p $mainheadid
3592 insertrow $nullid $p $curview
3593 } elseif {!$isdiff && [commitinview $nullid $curview]} {
3594 removerow $nullid $curview
3596 return 0
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]} {
3605 return -1
3607 if {[rowofcommit $kid] > $row} {
3608 return [rowofcommit $kid]
3612 if {[commitinview $id $curview]} {
3613 return [rowofcommit $id]
3615 return -1
3618 proc prevuse {id row} {
3619 global curview children
3621 set ret -1
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]
3630 return $ret
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}]
3638 if {$r < 0} {
3639 set r 0
3641 set ra [expr {$row - $downarrowlen}]
3642 if {$ra < 0} {
3643 set ra 0
3645 set rb [expr {$row + $uparrowlen}]
3646 if {$rb > $commitidx($curview)} {
3647 set rb $commitidx($curview)
3649 make_disporder $r [expr {$rb + 1}]
3650 set ids {}
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]
3656 if {$rn >= $row &&
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]
3674 while {$r < $rb} {
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]
3681 incr r
3682 set id [lindex $displayorder $r]
3683 if {$id ne {}} {
3684 set firstkid [lindex $children($curview,$id) 0]
3685 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3686 lappend ids [list [ordertoken $id] $id]
3690 set idlist {}
3691 foreach idx [lsort -unique $ids] {
3692 lappend idlist [lindex $idx 1]
3694 return $idlist
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]
3723 changedrow $r
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}]
3735 set idlist {}
3736 if {$row > 0} {
3737 set rm1 [expr {$row - 1}]
3738 foreach id [lindex $rowidlist $rm1] {
3739 if {$id ne {}} {
3740 lappend idlist $id
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]
3749 set final 1
3750 } else {
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]
3777 if {$col < 0} {
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)} {
3786 set x $col
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)} {
3810 set final 0
3812 set l [llength $rowidlist]
3813 if {$row == $l} {
3814 lappend rowidlist $idlist
3815 lappend rowisopt 0
3816 lappend rowfinal $final
3817 } elseif {$row < $l} {
3818 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3819 lset rowidlist $row $idlist
3820 changedrow $row
3822 lset rowfinal $row $final
3823 } else {
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]]
3832 return $row
3835 proc changedrow {row} {
3836 global displayorder iddrawn rowisopt need_redisplay
3838 set l [llength $rowisopt]
3839 if {$row < $l} {
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} {
3855 global rowidlist
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 {}]
3862 if {$i > 0} {
3863 set aft [lreplace $aft $i $i]
3865 lset rowidlist $row [concat $bef $pad $aft]
3866 changedrow $row
3869 proc optimize_rows {row col endrow} {
3870 global rowidlist rowisopt displayorder curview children
3872 if {$row < 1} {
3873 set row 1
3875 for {} {$row < $endrow} {incr row; set col 0} {
3876 if {[lindex $rowisopt $row]} continue
3877 set haspad 0
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
3883 if {$ym >= 0} {
3884 set pprevidlist [lindex $rowidlist $ym]
3885 if {$pprevidlist eq {}} continue
3886 } else {
3887 set pprevidlist {}
3889 set x0 -1
3890 set xm -1
3891 for {} {$col < [llength $idlist]} {incr col} {
3892 set id [lindex $idlist $col]
3893 if {[lindex $previdlist $col] eq $id} continue
3894 if {$id eq {}} {
3895 set haspad 1
3896 continue
3898 set x0 [lsearch -exact $previdlist $id]
3899 if {$x0 < 0} continue
3900 set z [expr {$x0 - $col}]
3901 set isarrow 0
3902 set z0 {}
3903 if {$ym >= 0} {
3904 set xm [lsearch -exact $pprevidlist $id]
3905 if {$xm >= 0} {
3906 set z0 [expr {$xm - $x0}]
3909 if {$z0 eq {}} {
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]} {
3913 set isarrow 1
3916 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3917 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3918 set isarrow 1
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
3923 # or at 45 degrees.
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
3929 if {$y0 > 0} {
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}]
3935 if {$z0 ne {}} {
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]
3946 incr col $npad
3947 set z [expr {$x0 - $col}]
3948 set haspad 1
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]
3954 if {$xc >= 0} {
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
3961 incr x0
3962 optimize_rows $y0 $x0 $row
3963 set previdlist [lindex $rowidlist $y0]
3966 if {!$haspad} {
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]
3972 if {$x0 < 0} {
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
3987 changedrow $row
3993 proc xc {row col} {
3994 global canvx0 linespc
3995 return [expr {$canvx0 + $col * $linespc}]
3998 proc yc {row} {
3999 global canvy0 linespc
4000 return [expr {$canvy0 + $row * $linespc}]
4003 proc linewidth {id} {
4004 global thickerline lthickness
4006 set wid $lthickness
4007 if {[info exists thickerline] && $id eq $thickerline} {
4008 set wid [expr {2 * $lthickness}]
4010 return $wid
4013 proc rowranges {id} {
4014 global curview children uparrowlen downarrowlen
4015 global rowidlist
4017 set kids $children($curview,$id)
4018 if {$kids eq {}} {
4019 return {}
4021 set ret {}
4022 lappend kids $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}]
4028 } else {
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} {}
4041 } else {
4042 while {[incr r] <= $row &&
4043 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4044 incr r -1
4046 lappend ret $r
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} {}
4052 } else {
4053 while {[incr r -1] >= $prevrow &&
4054 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4055 incr r
4057 lappend ret $r
4060 if {$child eq $id} {
4061 lappend ret $row
4063 set prev $child
4064 set prevrow $row
4066 return $ret
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}]
4075 set arrowhigh 1
4076 while {1} {
4077 set c [lsearch -exact [lindex $rowidlist $le] $id]
4078 if {$c < 0} {
4079 incr le -1
4080 break
4082 lappend cols $c
4083 set x [lindex $displayorder $le]
4084 if {$x eq $id} {
4085 set arrowhigh 0
4086 break
4088 if {[info exists iddrawn($x)] || $le == $endrow} {
4089 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4090 if {$c >= 0} {
4091 lappend cols $c
4092 set arrowhigh 0
4094 break
4096 incr le
4098 if {$le <= $row} {
4099 return $row
4102 set lines {}
4103 set i 0
4104 set joinhigh 0
4105 if {[info exists linesegs($id)]} {
4106 set lines $linesegs($id)
4107 foreach li $lines {
4108 set r0 [lindex $li 0]
4109 if {$r0 > $row} {
4110 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4111 set joinhigh 1
4113 break
4115 incr i
4118 set joinlow 0
4119 if {$i > 0} {
4120 set li [lindex $lines [expr {$i-1}]]
4121 set r1 [lindex $li 1]
4122 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4123 set joinlow 1
4127 set x [lindex $cols [expr {$le - $row}]]
4128 set xp [lindex $cols [expr {$le - 1 - $row}]]
4129 set dir [expr {$xp - $x}]
4130 if {$joinhigh} {
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]
4139 } else {
4140 set coords [list [xc $le $x] [yc $le]]
4142 if {$joinlow} {
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} {
4149 set arrowlow 0
4152 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4153 for {set y $le} {[incr y -1] > $row} {} {
4154 set x $xp
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]
4160 set dir $ndir
4162 if {!$joinlow} {
4163 if {$xp < 0} {
4164 # join parent line to first child
4165 set ch [lindex $displayorder $row]
4166 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4167 if {$xc < 0} {
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)}]
4172 set x1 [xc $row $x]
4173 if {$xc < $x} {
4174 set x2 [expr {$x1 - $d}]
4175 } else {
4176 set x2 [expr {$x1 + $d}]
4178 set y2 [yc $row]
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]
4186 set x $xc
4188 lappend coords [xc $row $x] [yc $row]
4189 } else {
4190 set xn [xc $row $xp]
4191 set yn [yc $row]
4192 lappend coords $xn $yn
4194 if {!$joinhigh} {
4195 assigncolor $id
4196 set t [$canv create line $coords -width [linewidth $id] \
4197 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4198 $canv lower $t
4199 bindline $t $id
4200 set lines [linsert $lines $i [list $row $le $t]]
4201 } else {
4202 $canv coords $ith $coords
4203 if {$arrow ne $ah} {
4204 $canv itemconf $ith -arrow $arrow
4206 lset lines $i 0 $row
4208 } else {
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]
4216 if {!$joinhigh} {
4217 lset lines [expr {$i-1}] 1 $le
4218 } else {
4219 # coalesce two pieces
4220 $canv delete $ith
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
4232 return $le
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]
4245 set y [yc $row]
4246 set y2 [yc $row2]
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
4251 set rmx 0
4252 foreach p $olds {
4253 set i [lsearch -exact $ids $p]
4254 if {$i < 0} {
4255 puts "oops, parent $p of $id not in list"
4256 continue
4258 set x2 [xc $row2 $i]
4259 if {$x2 > $rmx} {
4260 set rmx $x2
4262 set j [lsearch -exact $rowids $p]
4263 if {$j < 0} {
4264 # drawlineseg will do this one for us
4265 continue
4267 assigncolor $p
4268 # should handle duplicated parents here...
4269 set coords [list $x $y]
4270 if {$i != $col} {
4271 # if attaching to a vertical segment, draw a smaller
4272 # slant for visual distinctness
4273 if {$i == $j} {
4274 if {$i < $col} {
4275 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4276 } else {
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
4282 } else {
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
4290 } else {
4291 lappend coords $x2 $y2
4293 set t [$canv create line $coords -width [linewidth $p] \
4294 -fill $colormap($p) -tags lines.$p]
4295 $canv lower $t
4296 bindline $t $p
4298 if {$rmx > [lindex $idpos($id) 1]} {
4299 lset idpos($id) 1 $rmx
4300 redrawtags $id
4304 proc drawlines {id} {
4305 global canv
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} {
4320 set ofill red
4321 } elseif {$id eq $nullid2} {
4322 set ofill green
4323 } else {
4324 set ofill [expr {$listed != 0? "blue": "white"}]
4326 set x [xc $row $col]
4327 set y [yc $row]
4328 set orad [expr {$linespc / 3}]
4329 if {$listed <= 1} {
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]
4340 } else {
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]
4348 $canv raise $t
4349 $canv bind $t <1> {selcanvline {} %x %y}
4350 set rmx [llength [lindex $rowidlist $row]]
4351 set olds [lindex $parentlist $row]
4352 if {$olds ne {}} {
4353 set nextids [lindex $rowidlist [expr {$row + 1}]]
4354 foreach p $olds {
4355 set i [lsearch -exact $nextids $p]
4356 if {$i > $rmx} {
4357 set rmx $i
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]
4372 set font mainfont
4373 set nfont mainfont
4374 set isbold [ishighlighted $row]
4375 if {$isbold > 0} {
4376 lappend boldrows $row
4377 set font mainfontbold
4378 if {$isbold > 1} {
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} {
4391 make_secsel $row
4393 set xr [expr {$xt + [font measure $font $headline]}]
4394 if {$xr > $canvxmax} {
4395 set canvxmax $xr
4396 setcanvscroll
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]
4425 if {$col < 0} {
4426 puts "oops, row $row id $id not in list"
4427 return
4429 if {![info exists commitinfo($id)]} {
4430 getcommit $id
4432 assigncolor $id
4433 drawcmittext $id $row $col
4434 set iddrawn($id) 1
4435 incr nrows_drawn
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
4446 if {$row < 0} {
4447 set row 0
4449 if {$endrow eq {}} {
4450 set endrow $row
4452 if {$endrow >= $numcommits} {
4453 set endrow [expr {$numcommits - 1}]
4456 set rl1 [expr {$row - $downarrowlen - 3}]
4457 if {$rl1 < 0} {
4458 set rl1 0
4460 set ro1 [expr {$row - 3}]
4461 if {$ro1 < 0} {
4462 set ro1 0
4464 set r2 [expr {$endrow + $uparrowlen + 3}]
4465 if {$r2 > $numcommits} {
4466 set r2 $numcommits
4468 for {set r $rl1} {$r < $r2} {incr r} {
4469 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4470 if {$rl1 < $r} {
4471 layoutrows $rl1 $r
4473 set rl1 [expr {$r + 1}]
4476 if {$rl1 < $r} {
4477 layoutrows $rl1 $r
4479 optimize_rows $ro1 0 $r2
4480 if {$need_redisplay || $nrows_drawn > 2000} {
4481 clear_display
4482 drawvisible
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])]} {
4488 set r $row
4490 set er [expr {$endrow + 1}]
4491 if {$er >= $numcommits ||
4492 ![info exists iddrawn([lindex $displayorder $er])]} {
4493 set er $endrow
4495 for {} {$r <= $er} {incr r} {
4496 set id [lindex $displayorder $r]
4497 set wasdrawn [info exists iddrawn($id)]
4498 drawcmitrow $r
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
4508 if {$lid eq $id} {
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]
4516 } else {
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)}]
4528 if {$r < 0} {
4529 set r 0
4531 if {[llength $rowidlist] > $r} {
4532 incr r -1
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
4537 run drawvisible
4541 proc drawvisible {} {
4542 global canv linespc curview vrowmod selectedline targetrow targetid
4543 global need_redisplay cscroll
4545 set fs [$canv yview]
4546 set ymax [lindex [$canv cget -scrollregion] 3]
4547 if {$ymax eq {} || $ymax == 0} return
4548 set f0 [lindex $fs 0]
4549 set f1 [lindex $fs 1]
4550 set y0 [expr {int($f0 * $ymax)}]
4551 set y1 [expr {int($f1 * $ymax)}]
4553 if {[info exists targetid]} {
4554 set r [rowofcommit $targetid]
4555 if {$r != $targetrow} {
4556 # Fix up the scrollregion and change the scrolling position
4557 # now that our target row has moved.
4558 set diff [expr {($r - $targetrow) * $linespc}]
4559 set targetrow $r
4560 setcanvscroll
4561 set ymax [lindex [$canv cget -scrollregion] 3]
4562 incr y0 $diff
4563 incr y1 $diff
4564 set f0 [expr {$y0 / $ymax}]
4565 set f1 [expr {$y1 / $ymax}]
4566 allcanvs yview moveto $f0
4567 $cscroll set $f0 $f1
4568 set need_redisplay 1
4572 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4573 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4574 if {$endrow >= $vrowmod($curview)} {
4575 update_arcrows $curview
4577 if {[info exists selectedline] &&
4578 $row <= $selectedline && $selectedline <= $endrow} {
4579 set targetrow $selectedline
4580 } else {
4581 set targetrow [expr {int(($row + $endrow) / 2)}]
4583 set targetid [commitonrow $targetrow]
4584 drawcommits $row $endrow
4587 proc clear_display {} {
4588 global iddrawn linesegs need_redisplay nrows_drawn
4589 global vhighlights fhighlights nhighlights rhighlights
4591 allcanvs delete all
4592 catch {unset iddrawn}
4593 catch {unset linesegs}
4594 catch {unset vhighlights}
4595 catch {unset fhighlights}
4596 catch {unset nhighlights}
4597 catch {unset rhighlights}
4598 set need_redisplay 0
4599 set nrows_drawn 0
4602 proc findcrossings {id} {
4603 global rowidlist parentlist numcommits displayorder
4605 set cross {}
4606 set ccross {}
4607 foreach {s e} [rowranges $id] {
4608 if {$e >= $numcommits} {
4609 set e [expr {$numcommits - 1}]
4611 if {$e <= $s} continue
4612 for {set row $e} {[incr row -1] >= $s} {} {
4613 set x [lsearch -exact [lindex $rowidlist $row] $id]
4614 if {$x < 0} break
4615 set olds [lindex $parentlist $row]
4616 set kid [lindex $displayorder $row]
4617 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4618 if {$kidx < 0} continue
4619 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4620 foreach p $olds {
4621 set px [lsearch -exact $nextrow $p]
4622 if {$px < 0} continue
4623 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4624 if {[lsearch -exact $ccross $p] >= 0} continue
4625 if {$x == $px + ($kidx < $px? -1: 1)} {
4626 lappend ccross $p
4627 } elseif {[lsearch -exact $cross $p] < 0} {
4628 lappend cross $p
4634 return [concat $ccross {{}} $cross]
4637 proc assigncolor {id} {
4638 global colormap colors nextcolor
4639 global parents children children curview
4641 if {[info exists colormap($id)]} return
4642 set ncolors [llength $colors]
4643 if {[info exists children($curview,$id)]} {
4644 set kids $children($curview,$id)
4645 } else {
4646 set kids {}
4648 if {[llength $kids] == 1} {
4649 set child [lindex $kids 0]
4650 if {[info exists colormap($child)]
4651 && [llength $parents($curview,$child)] == 1} {
4652 set colormap($id) $colormap($child)
4653 return
4656 set badcolors {}
4657 set origbad {}
4658 foreach x [findcrossings $id] {
4659 if {$x eq {}} {
4660 # delimiter between corner crossings and other crossings
4661 if {[llength $badcolors] >= $ncolors - 1} break
4662 set origbad $badcolors
4664 if {[info exists colormap($x)]
4665 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4666 lappend badcolors $colormap($x)
4669 if {[llength $badcolors] >= $ncolors} {
4670 set badcolors $origbad
4672 set origbad $badcolors
4673 if {[llength $badcolors] < $ncolors - 1} {
4674 foreach child $kids {
4675 if {[info exists colormap($child)]
4676 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4677 lappend badcolors $colormap($child)
4679 foreach p $parents($curview,$child) {
4680 if {[info exists colormap($p)]
4681 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4682 lappend badcolors $colormap($p)
4686 if {[llength $badcolors] >= $ncolors} {
4687 set badcolors $origbad
4690 for {set i 0} {$i <= $ncolors} {incr i} {
4691 set c [lindex $colors $nextcolor]
4692 if {[incr nextcolor] >= $ncolors} {
4693 set nextcolor 0
4695 if {[lsearch -exact $badcolors $c]} break
4697 set colormap($id) $c
4700 proc bindline {t id} {
4701 global canv
4703 $canv bind $t <Enter> "lineenter %x %y $id"
4704 $canv bind $t <Motion> "linemotion %x %y $id"
4705 $canv bind $t <Leave> "lineleave $id"
4706 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4709 proc drawtags {id x xt y1} {
4710 global idtags idheads idotherrefs mainhead
4711 global linespc lthickness
4712 global canv rowtextx curview fgcolor bgcolor
4714 set marks {}
4715 set ntags 0
4716 set nheads 0
4717 if {[info exists idtags($id)]} {
4718 set marks $idtags($id)
4719 set ntags [llength $marks]
4721 if {[info exists idheads($id)]} {
4722 set marks [concat $marks $idheads($id)]
4723 set nheads [llength $idheads($id)]
4725 if {[info exists idotherrefs($id)]} {
4726 set marks [concat $marks $idotherrefs($id)]
4728 if {$marks eq {}} {
4729 return $xt
4732 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4733 set yt [expr {$y1 - 0.5 * $linespc}]
4734 set yb [expr {$yt + $linespc - 1}]
4735 set xvals {}
4736 set wvals {}
4737 set i -1
4738 foreach tag $marks {
4739 incr i
4740 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4741 set wid [font measure mainfontbold $tag]
4742 } else {
4743 set wid [font measure mainfont $tag]
4745 lappend xvals $xt
4746 lappend wvals $wid
4747 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4749 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4750 -width $lthickness -fill black -tags tag.$id]
4751 $canv lower $t
4752 foreach tag $marks x $xvals wid $wvals {
4753 set xl [expr {$x + $delta}]
4754 set xr [expr {$x + $delta + $wid + $lthickness}]
4755 set font mainfont
4756 if {[incr ntags -1] >= 0} {
4757 # draw a tag
4758 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4759 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4760 -width 1 -outline black -fill yellow -tags tag.$id]
4761 $canv bind $t <1> [list showtag $tag 1]
4762 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4763 } else {
4764 # draw a head or other ref
4765 if {[incr nheads -1] >= 0} {
4766 set col green
4767 if {$tag eq $mainhead} {
4768 set font mainfontbold
4770 } else {
4771 set col "#ddddff"
4773 set xl [expr {$xl - $delta/2}]
4774 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4775 -width 1 -outline black -fill $col -tags tag.$id
4776 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4777 set rwid [font measure mainfont $remoteprefix]
4778 set xi [expr {$x + 1}]
4779 set yti [expr {$yt + 1}]
4780 set xri [expr {$x + $rwid}]
4781 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4782 -width 0 -fill "#ffddaa" -tags tag.$id
4785 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4786 -font $font -tags [list tag.$id text]]
4787 if {$ntags >= 0} {
4788 $canv bind $t <1> [list showtag $tag 1]
4789 } elseif {$nheads >= 0} {
4790 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4793 return $xt
4796 proc xcoord {i level ln} {
4797 global canvx0 xspc1 xspc2
4799 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4800 if {$i > 0 && $i == $level} {
4801 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4802 } elseif {$i > $level} {
4803 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4805 return $x
4808 proc show_status {msg} {
4809 global canv fgcolor
4811 clear_display
4812 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4813 -tags text -fill $fgcolor
4816 # Don't change the text pane cursor if it is currently the hand cursor,
4817 # showing that we are over a sha1 ID link.
4818 proc settextcursor {c} {
4819 global ctext curtextcursor
4821 if {[$ctext cget -cursor] == $curtextcursor} {
4822 $ctext config -cursor $c
4824 set curtextcursor $c
4827 proc nowbusy {what {name {}}} {
4828 global isbusy busyname statusw
4830 if {[array names isbusy] eq {}} {
4831 . config -cursor watch
4832 settextcursor watch
4834 set isbusy($what) 1
4835 set busyname($what) $name
4836 if {$name ne {}} {
4837 $statusw conf -text $name
4841 proc notbusy {what} {
4842 global isbusy maincursor textcursor busyname statusw
4844 catch {
4845 unset isbusy($what)
4846 if {$busyname($what) ne {} &&
4847 [$statusw cget -text] eq $busyname($what)} {
4848 $statusw conf -text {}
4851 if {[array names isbusy] eq {}} {
4852 . config -cursor $maincursor
4853 settextcursor $textcursor
4857 proc findmatches {f} {
4858 global findtype findstring
4859 if {$findtype == [mc "Regexp"]} {
4860 set matches [regexp -indices -all -inline $findstring $f]
4861 } else {
4862 set fs $findstring
4863 if {$findtype == [mc "IgnCase"]} {
4864 set f [string tolower $f]
4865 set fs [string tolower $fs]
4867 set matches {}
4868 set i 0
4869 set l [string length $fs]
4870 while {[set j [string first $fs $f $i]] >= 0} {
4871 lappend matches [list $j [expr {$j+$l-1}]]
4872 set i [expr {$j + $l}]
4875 return $matches
4878 proc dofind {{dirn 1} {wrap 1}} {
4879 global findstring findstartline findcurline selectedline numcommits
4880 global gdttype filehighlight fh_serial find_dirn findallowwrap
4882 if {[info exists find_dirn]} {
4883 if {$find_dirn == $dirn} return
4884 stopfinding
4886 focus .
4887 if {$findstring eq {} || $numcommits == 0} return
4888 if {![info exists selectedline]} {
4889 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4890 } else {
4891 set findstartline $selectedline
4893 set findcurline $findstartline
4894 nowbusy finding [mc "Searching"]
4895 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
4896 after cancel do_file_hl $fh_serial
4897 do_file_hl $fh_serial
4899 set find_dirn $dirn
4900 set findallowwrap $wrap
4901 run findmore
4904 proc stopfinding {} {
4905 global find_dirn findcurline fprogcoord
4907 if {[info exists find_dirn]} {
4908 unset find_dirn
4909 unset findcurline
4910 notbusy finding
4911 set fprogcoord 0
4912 adjustprogress
4916 proc findmore {} {
4917 global commitdata commitinfo numcommits findpattern findloc
4918 global findstartline findcurline findallowwrap
4919 global find_dirn gdttype fhighlights fprogcoord
4920 global curview varcorder vrownum varccommits
4922 if {![info exists find_dirn]} {
4923 return 0
4925 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
4926 set l $findcurline
4927 set moretodo 0
4928 if {$find_dirn > 0} {
4929 incr l
4930 if {$l >= $numcommits} {
4931 set l 0
4933 if {$l <= $findstartline} {
4934 set lim [expr {$findstartline + 1}]
4935 } else {
4936 set lim $numcommits
4937 set moretodo $findallowwrap
4939 } else {
4940 if {$l == 0} {
4941 set l $numcommits
4943 incr l -1
4944 if {$l >= $findstartline} {
4945 set lim [expr {$findstartline - 1}]
4946 } else {
4947 set lim -1
4948 set moretodo $findallowwrap
4951 set n [expr {($lim - $l) * $find_dirn}]
4952 if {$n > 500} {
4953 set n 500
4954 set moretodo 1
4956 set found 0
4957 set domore 1
4958 set ai [bsearch $vrownum($curview) $l]
4959 set a [lindex $varcorder($curview) $ai]
4960 set arow [lindex $vrownum($curview) $ai]
4961 set ids [lindex $varccommits($curview,$a)]
4962 set arowend [expr {$arow + [llength $ids]}]
4963 if {$gdttype eq [mc "containing:"]} {
4964 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4965 if {$l < $arow || $l >= $arowend} {
4966 incr ai $find_dirn
4967 set a [lindex $varcorder($curview) $ai]
4968 set arow [lindex $vrownum($curview) $ai]
4969 set ids [lindex $varccommits($curview,$a)]
4970 set arowend [expr {$arow + [llength $ids]}]
4972 set id [lindex $ids [expr {$l - $arow}]]
4973 # shouldn't happen unless git log doesn't give all the commits...
4974 if {![info exists commitdata($id)] ||
4975 ![doesmatch $commitdata($id)]} {
4976 continue
4978 if {![info exists commitinfo($id)]} {
4979 getcommit $id
4981 set info $commitinfo($id)
4982 foreach f $info ty $fldtypes {
4983 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4984 [doesmatch $f]} {
4985 set found 1
4986 break
4989 if {$found} break
4991 } else {
4992 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4993 if {$l < $arow || $l >= $arowend} {
4994 incr ai $find_dirn
4995 set a [lindex $varcorder($curview) $ai]
4996 set arow [lindex $vrownum($curview) $ai]
4997 set ids [lindex $varccommits($curview,$a)]
4998 set arowend [expr {$arow + [llength $ids]}]
5000 set id [lindex $ids [expr {$l - $arow}]]
5001 if {![info exists fhighlights($l)]} {
5002 askfilehighlight $l $id
5003 if {$domore} {
5004 set domore 0
5005 set findcurline [expr {$l - $find_dirn}]
5007 } elseif {$fhighlights($l)} {
5008 set found $domore
5009 break
5013 if {$found || ($domore && !$moretodo)} {
5014 unset findcurline
5015 unset find_dirn
5016 notbusy finding
5017 set fprogcoord 0
5018 adjustprogress
5019 if {$found} {
5020 findselectline $l
5021 } else {
5022 bell
5024 return 0
5026 if {!$domore} {
5027 flushhighlights
5028 } else {
5029 set findcurline [expr {$l - $find_dirn}]
5031 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5032 if {$n < 0} {
5033 incr n $numcommits
5035 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5036 adjustprogress
5037 return $domore
5040 proc findselectline {l} {
5041 global findloc commentend ctext findcurline markingmatches gdttype
5043 set markingmatches 1
5044 set findcurline $l
5045 selectline $l 1
5046 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5047 # highlight the matches in the comments
5048 set f [$ctext get 1.0 $commentend]
5049 set matches [findmatches $f]
5050 foreach match $matches {
5051 set start [lindex $match 0]
5052 set end [expr {[lindex $match 1] + 1}]
5053 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5056 drawvisible
5059 # mark the bits of a headline or author that match a find string
5060 proc markmatches {canv l str tag matches font row} {
5061 global selectedline
5063 set bbox [$canv bbox $tag]
5064 set x0 [lindex $bbox 0]
5065 set y0 [lindex $bbox 1]
5066 set y1 [lindex $bbox 3]
5067 foreach match $matches {
5068 set start [lindex $match 0]
5069 set end [lindex $match 1]
5070 if {$start > $end} continue
5071 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5072 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5073 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5074 [expr {$x0+$xlen+2}] $y1 \
5075 -outline {} -tags [list match$l matches] -fill yellow]
5076 $canv lower $t
5077 if {[info exists selectedline] && $row == $selectedline} {
5078 $canv raise $t secsel
5083 proc unmarkmatches {} {
5084 global markingmatches
5086 allcanvs delete matches
5087 set markingmatches 0
5088 stopfinding
5091 proc selcanvline {w x y} {
5092 global canv canvy0 ctext linespc
5093 global rowtextx
5094 set ymax [lindex [$canv cget -scrollregion] 3]
5095 if {$ymax == {}} return
5096 set yfrac [lindex [$canv yview] 0]
5097 set y [expr {$y + $yfrac * $ymax}]
5098 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5099 if {$l < 0} {
5100 set l 0
5102 if {$w eq $canv} {
5103 set xmax [lindex [$canv cget -scrollregion] 2]
5104 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5105 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5107 unmarkmatches
5108 selectline $l 1
5111 proc commit_descriptor {p} {
5112 global commitinfo
5113 if {![info exists commitinfo($p)]} {
5114 getcommit $p
5116 set l "..."
5117 if {[llength $commitinfo($p)] > 1} {
5118 set l [lindex $commitinfo($p) 0]
5120 return "$p ($l)\n"
5123 # append some text to the ctext widget, and make any SHA1 ID
5124 # that we know about be a clickable link.
5125 proc appendwithlinks {text tags} {
5126 global ctext linknum curview pendinglinks
5128 set start [$ctext index "end - 1c"]
5129 $ctext insert end $text $tags
5130 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5131 foreach l $links {
5132 set s [lindex $l 0]
5133 set e [lindex $l 1]
5134 set linkid [string range $text $s $e]
5135 incr e
5136 $ctext tag delete link$linknum
5137 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5138 setlink $linkid link$linknum
5139 incr linknum
5143 proc setlink {id lk} {
5144 global curview ctext pendinglinks commitinterest
5146 if {[commitinview $id $curview]} {
5147 $ctext tag conf $lk -foreground blue -underline 1
5148 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5149 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5150 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5151 } else {
5152 lappend pendinglinks($id) $lk
5153 lappend commitinterest($id) {makelink %I}
5157 proc makelink {id} {
5158 global pendinglinks
5160 if {![info exists pendinglinks($id)]} return
5161 foreach lk $pendinglinks($id) {
5162 setlink $id $lk
5164 unset pendinglinks($id)
5167 proc linkcursor {w inc} {
5168 global linkentercount curtextcursor
5170 if {[incr linkentercount $inc] > 0} {
5171 $w configure -cursor hand2
5172 } else {
5173 $w configure -cursor $curtextcursor
5174 if {$linkentercount < 0} {
5175 set linkentercount 0
5180 proc viewnextline {dir} {
5181 global canv linespc
5183 $canv delete hover
5184 set ymax [lindex [$canv cget -scrollregion] 3]
5185 set wnow [$canv yview]
5186 set wtop [expr {[lindex $wnow 0] * $ymax}]
5187 set newtop [expr {$wtop + $dir * $linespc}]
5188 if {$newtop < 0} {
5189 set newtop 0
5190 } elseif {$newtop > $ymax} {
5191 set newtop $ymax
5193 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5196 # add a list of tag or branch names at position pos
5197 # returns the number of names inserted
5198 proc appendrefs {pos ids var} {
5199 global ctext linknum curview $var maxrefs
5201 if {[catch {$ctext index $pos}]} {
5202 return 0
5204 $ctext conf -state normal
5205 $ctext delete $pos "$pos lineend"
5206 set tags {}
5207 foreach id $ids {
5208 foreach tag [set $var\($id\)] {
5209 lappend tags [list $tag $id]
5212 if {[llength $tags] > $maxrefs} {
5213 $ctext insert $pos "many ([llength $tags])"
5214 } else {
5215 set tags [lsort -index 0 -decreasing $tags]
5216 set sep {}
5217 foreach ti $tags {
5218 set id [lindex $ti 1]
5219 set lk link$linknum
5220 incr linknum
5221 $ctext tag delete $lk
5222 $ctext insert $pos $sep
5223 $ctext insert $pos [lindex $ti 0] $lk
5224 setlink $id $lk
5225 set sep ", "
5228 $ctext conf -state disabled
5229 return [llength $tags]
5232 # called when we have finished computing the nearby tags
5233 proc dispneartags {delay} {
5234 global selectedline currentid showneartags tagphase
5236 if {![info exists selectedline] || !$showneartags} return
5237 after cancel dispnexttag
5238 if {$delay} {
5239 after 200 dispnexttag
5240 set tagphase -1
5241 } else {
5242 after idle dispnexttag
5243 set tagphase 0
5247 proc dispnexttag {} {
5248 global selectedline currentid showneartags tagphase ctext
5250 if {![info exists selectedline] || !$showneartags} return
5251 switch -- $tagphase {
5253 set dtags [desctags $currentid]
5254 if {$dtags ne {}} {
5255 appendrefs precedes $dtags idtags
5259 set atags [anctags $currentid]
5260 if {$atags ne {}} {
5261 appendrefs follows $atags idtags
5265 set dheads [descheads $currentid]
5266 if {$dheads ne {}} {
5267 if {[appendrefs branch $dheads idheads] > 1
5268 && [$ctext get "branch -3c"] eq "h"} {
5269 # turn "Branch" into "Branches"
5270 $ctext conf -state normal
5271 $ctext insert "branch -2c" "es"
5272 $ctext conf -state disabled
5277 if {[incr tagphase] <= 2} {
5278 after idle dispnexttag
5282 proc make_secsel {l} {
5283 global linehtag linentag linedtag canv canv2 canv3
5285 if {![info exists linehtag($l)]} return
5286 $canv delete secsel
5287 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5288 -tags secsel -fill [$canv cget -selectbackground]]
5289 $canv lower $t
5290 $canv2 delete secsel
5291 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5292 -tags secsel -fill [$canv2 cget -selectbackground]]
5293 $canv2 lower $t
5294 $canv3 delete secsel
5295 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5296 -tags secsel -fill [$canv3 cget -selectbackground]]
5297 $canv3 lower $t
5300 proc selectline {l isnew} {
5301 global canv ctext commitinfo selectedline
5302 global canvy0 linespc parents children curview
5303 global currentid sha1entry
5304 global commentend idtags linknum
5305 global mergemax numcommits pending_select
5306 global cmitmode showneartags allcommits
5308 catch {unset pending_select}
5309 $canv delete hover
5310 normalline
5311 unsel_reflist
5312 stopfinding
5313 if {$l < 0 || $l >= $numcommits} return
5314 set y [expr {$canvy0 + $l * $linespc}]
5315 set ymax [lindex [$canv cget -scrollregion] 3]
5316 set ytop [expr {$y - $linespc - 1}]
5317 set ybot [expr {$y + $linespc + 1}]
5318 set wnow [$canv yview]
5319 set wtop [expr {[lindex $wnow 0] * $ymax}]
5320 set wbot [expr {[lindex $wnow 1] * $ymax}]
5321 set wh [expr {$wbot - $wtop}]
5322 set newtop $wtop
5323 if {$ytop < $wtop} {
5324 if {$ybot < $wtop} {
5325 set newtop [expr {$y - $wh / 2.0}]
5326 } else {
5327 set newtop $ytop
5328 if {$newtop > $wtop - $linespc} {
5329 set newtop [expr {$wtop - $linespc}]
5332 } elseif {$ybot > $wbot} {
5333 if {$ytop > $wbot} {
5334 set newtop [expr {$y - $wh / 2.0}]
5335 } else {
5336 set newtop [expr {$ybot - $wh}]
5337 if {$newtop < $wtop + $linespc} {
5338 set newtop [expr {$wtop + $linespc}]
5342 if {$newtop != $wtop} {
5343 if {$newtop < 0} {
5344 set newtop 0
5346 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5347 drawvisible
5350 make_secsel $l
5352 set id [commitonrow $l]
5353 if {$isnew} {
5354 addtohistory [list selbyid $id]
5357 set selectedline $l
5358 set currentid $id
5359 $sha1entry delete 0 end
5360 $sha1entry insert 0 $id
5361 $sha1entry selection from 0
5362 $sha1entry selection to end
5363 rhighlight_sel $id
5365 $ctext conf -state normal
5366 clear_ctext
5367 set linknum 0
5368 set info $commitinfo($id)
5369 set date [formatdate [lindex $info 2]]
5370 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5371 set date [formatdate [lindex $info 4]]
5372 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5373 if {[info exists idtags($id)]} {
5374 $ctext insert end [mc "Tags:"]
5375 foreach tag $idtags($id) {
5376 $ctext insert end " $tag"
5378 $ctext insert end "\n"
5381 set headers {}
5382 set olds $parents($curview,$id)
5383 if {[llength $olds] > 1} {
5384 set np 0
5385 foreach p $olds {
5386 if {$np >= $mergemax} {
5387 set tag mmax
5388 } else {
5389 set tag m$np
5391 $ctext insert end "[mc "Parent"]: " $tag
5392 appendwithlinks [commit_descriptor $p] {}
5393 incr np
5395 } else {
5396 foreach p $olds {
5397 append headers "[mc "Parent"]: [commit_descriptor $p]"
5401 foreach c $children($curview,$id) {
5402 append headers "[mc "Child"]: [commit_descriptor $c]"
5405 # make anything that looks like a SHA1 ID be a clickable link
5406 appendwithlinks $headers {}
5407 if {$showneartags} {
5408 if {![info exists allcommits]} {
5409 getallcommits
5411 $ctext insert end "[mc "Branch"]: "
5412 $ctext mark set branch "end -1c"
5413 $ctext mark gravity branch left
5414 $ctext insert end "\n[mc "Follows"]: "
5415 $ctext mark set follows "end -1c"
5416 $ctext mark gravity follows left
5417 $ctext insert end "\n[mc "Precedes"]: "
5418 $ctext mark set precedes "end -1c"
5419 $ctext mark gravity precedes left
5420 $ctext insert end "\n"
5421 dispneartags 1
5423 $ctext insert end "\n"
5424 set comment [lindex $info 5]
5425 if {[string first "\r" $comment] >= 0} {
5426 set comment [string map {"\r" "\n "} $comment]
5428 appendwithlinks $comment {comment}
5430 $ctext tag remove found 1.0 end
5431 $ctext conf -state disabled
5432 set commentend [$ctext index "end - 1c"]
5434 init_flist [mc "Comments"]
5435 if {$cmitmode eq "tree"} {
5436 gettree $id
5437 } elseif {[llength $olds] <= 1} {
5438 startdiff $id
5439 } else {
5440 mergediff $id
5444 proc selfirstline {} {
5445 unmarkmatches
5446 selectline 0 1
5449 proc sellastline {} {
5450 global numcommits
5451 unmarkmatches
5452 set l [expr {$numcommits - 1}]
5453 selectline $l 1
5456 proc selnextline {dir} {
5457 global selectedline
5458 focus .
5459 if {![info exists selectedline]} return
5460 set l [expr {$selectedline + $dir}]
5461 unmarkmatches
5462 selectline $l 1
5465 proc selnextpage {dir} {
5466 global canv linespc selectedline numcommits
5468 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5469 if {$lpp < 1} {
5470 set lpp 1
5472 allcanvs yview scroll [expr {$dir * $lpp}] units
5473 drawvisible
5474 if {![info exists selectedline]} return
5475 set l [expr {$selectedline + $dir * $lpp}]
5476 if {$l < 0} {
5477 set l 0
5478 } elseif {$l >= $numcommits} {
5479 set l [expr $numcommits - 1]
5481 unmarkmatches
5482 selectline $l 1
5485 proc unselectline {} {
5486 global selectedline currentid
5488 catch {unset selectedline}
5489 catch {unset currentid}
5490 allcanvs delete secsel
5491 rhighlight_none
5494 proc reselectline {} {
5495 global selectedline
5497 if {[info exists selectedline]} {
5498 selectline $selectedline 0
5502 proc addtohistory {cmd} {
5503 global history historyindex curview
5505 set elt [list $curview $cmd]
5506 if {$historyindex > 0
5507 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5508 return
5511 if {$historyindex < [llength $history]} {
5512 set history [lreplace $history $historyindex end $elt]
5513 } else {
5514 lappend history $elt
5516 incr historyindex
5517 if {$historyindex > 1} {
5518 .tf.bar.leftbut conf -state normal
5519 } else {
5520 .tf.bar.leftbut conf -state disabled
5522 .tf.bar.rightbut conf -state disabled
5525 proc godo {elt} {
5526 global curview
5528 set view [lindex $elt 0]
5529 set cmd [lindex $elt 1]
5530 if {$curview != $view} {
5531 showview $view
5533 eval $cmd
5536 proc goback {} {
5537 global history historyindex
5538 focus .
5540 if {$historyindex > 1} {
5541 incr historyindex -1
5542 godo [lindex $history [expr {$historyindex - 1}]]
5543 .tf.bar.rightbut conf -state normal
5545 if {$historyindex <= 1} {
5546 .tf.bar.leftbut conf -state disabled
5550 proc goforw {} {
5551 global history historyindex
5552 focus .
5554 if {$historyindex < [llength $history]} {
5555 set cmd [lindex $history $historyindex]
5556 incr historyindex
5557 godo $cmd
5558 .tf.bar.leftbut conf -state normal
5560 if {$historyindex >= [llength $history]} {
5561 .tf.bar.rightbut conf -state disabled
5565 proc gettree {id} {
5566 global treefilelist treeidlist diffids diffmergeid treepending
5567 global nullid nullid2
5569 set diffids $id
5570 catch {unset diffmergeid}
5571 if {![info exists treefilelist($id)]} {
5572 if {![info exists treepending]} {
5573 if {$id eq $nullid} {
5574 set cmd [list | git ls-files]
5575 } elseif {$id eq $nullid2} {
5576 set cmd [list | git ls-files --stage -t]
5577 } else {
5578 set cmd [list | git ls-tree -r $id]
5580 if {[catch {set gtf [open $cmd r]}]} {
5581 return
5583 set treepending $id
5584 set treefilelist($id) {}
5585 set treeidlist($id) {}
5586 fconfigure $gtf -blocking 0
5587 filerun $gtf [list gettreeline $gtf $id]
5589 } else {
5590 setfilelist $id
5594 proc gettreeline {gtf id} {
5595 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5597 set nl 0
5598 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5599 if {$diffids eq $nullid} {
5600 set fname $line
5601 } else {
5602 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5603 set i [string first "\t" $line]
5604 if {$i < 0} continue
5605 set sha1 [lindex $line 2]
5606 set fname [string range $line [expr {$i+1}] end]
5607 if {[string index $fname 0] eq "\""} {
5608 set fname [lindex $fname 0]
5610 lappend treeidlist($id) $sha1
5612 lappend treefilelist($id) $fname
5614 if {![eof $gtf]} {
5615 return [expr {$nl >= 1000? 2: 1}]
5617 close $gtf
5618 unset treepending
5619 if {$cmitmode ne "tree"} {
5620 if {![info exists diffmergeid]} {
5621 gettreediffs $diffids
5623 } elseif {$id ne $diffids} {
5624 gettree $diffids
5625 } else {
5626 setfilelist $id
5628 return 0
5631 proc showfile {f} {
5632 global treefilelist treeidlist diffids nullid nullid2
5633 global ctext commentend
5635 set i [lsearch -exact $treefilelist($diffids) $f]
5636 if {$i < 0} {
5637 puts "oops, $f not in list for id $diffids"
5638 return
5640 if {$diffids eq $nullid} {
5641 if {[catch {set bf [open $f r]} err]} {
5642 puts "oops, can't read $f: $err"
5643 return
5645 } else {
5646 set blob [lindex $treeidlist($diffids) $i]
5647 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5648 puts "oops, error reading blob $blob: $err"
5649 return
5652 fconfigure $bf -blocking 0
5653 filerun $bf [list getblobline $bf $diffids]
5654 $ctext config -state normal
5655 clear_ctext $commentend
5656 $ctext insert end "\n"
5657 $ctext insert end "$f\n" filesep
5658 $ctext config -state disabled
5659 $ctext yview $commentend
5660 settabs 0
5663 proc getblobline {bf id} {
5664 global diffids cmitmode ctext
5666 if {$id ne $diffids || $cmitmode ne "tree"} {
5667 catch {close $bf}
5668 return 0
5670 $ctext config -state normal
5671 set nl 0
5672 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5673 $ctext insert end "$line\n"
5675 if {[eof $bf]} {
5676 # delete last newline
5677 $ctext delete "end - 2c" "end - 1c"
5678 close $bf
5679 return 0
5681 $ctext config -state disabled
5682 return [expr {$nl >= 1000? 2: 1}]
5685 proc mergediff {id} {
5686 global diffmergeid mdifffd
5687 global diffids
5688 global parents
5689 global limitdiffs viewfiles curview
5691 set diffmergeid $id
5692 set diffids $id
5693 # this doesn't seem to actually affect anything...
5694 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5695 if {$limitdiffs && $viewfiles($curview) ne {}} {
5696 set cmd [concat $cmd -- $viewfiles($curview)]
5698 if {[catch {set mdf [open $cmd r]} err]} {
5699 error_popup "[mc "Error getting merge diffs:"] $err"
5700 return
5702 fconfigure $mdf -blocking 0
5703 set mdifffd($id) $mdf
5704 set np [llength $parents($curview,$id)]
5705 settabs $np
5706 filerun $mdf [list getmergediffline $mdf $id $np]
5709 proc getmergediffline {mdf id np} {
5710 global diffmergeid ctext cflist mergemax
5711 global difffilestart mdifffd
5713 $ctext conf -state normal
5714 set nr 0
5715 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5716 if {![info exists diffmergeid] || $id != $diffmergeid
5717 || $mdf != $mdifffd($id)} {
5718 close $mdf
5719 return 0
5721 if {[regexp {^diff --cc (.*)} $line match fname]} {
5722 # start of a new file
5723 $ctext insert end "\n"
5724 set here [$ctext index "end - 1c"]
5725 lappend difffilestart $here
5726 add_flist [list $fname]
5727 set l [expr {(78 - [string length $fname]) / 2}]
5728 set pad [string range "----------------------------------------" 1 $l]
5729 $ctext insert end "$pad $fname $pad\n" filesep
5730 } elseif {[regexp {^@@} $line]} {
5731 $ctext insert end "$line\n" hunksep
5732 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5733 # do nothing
5734 } else {
5735 # parse the prefix - one ' ', '-' or '+' for each parent
5736 set spaces {}
5737 set minuses {}
5738 set pluses {}
5739 set isbad 0
5740 for {set j 0} {$j < $np} {incr j} {
5741 set c [string range $line $j $j]
5742 if {$c == " "} {
5743 lappend spaces $j
5744 } elseif {$c == "-"} {
5745 lappend minuses $j
5746 } elseif {$c == "+"} {
5747 lappend pluses $j
5748 } else {
5749 set isbad 1
5750 break
5753 set tags {}
5754 set num {}
5755 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5756 # line doesn't appear in result, parents in $minuses have the line
5757 set num [lindex $minuses 0]
5758 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5759 # line appears in result, parents in $pluses don't have the line
5760 lappend tags mresult
5761 set num [lindex $spaces 0]
5763 if {$num ne {}} {
5764 if {$num >= $mergemax} {
5765 set num "max"
5767 lappend tags m$num
5769 $ctext insert end "$line\n" $tags
5772 $ctext conf -state disabled
5773 if {[eof $mdf]} {
5774 close $mdf
5775 return 0
5777 return [expr {$nr >= 1000? 2: 1}]
5780 proc startdiff {ids} {
5781 global treediffs diffids treepending diffmergeid nullid nullid2
5783 settabs 1
5784 set diffids $ids
5785 catch {unset diffmergeid}
5786 if {![info exists treediffs($ids)] ||
5787 [lsearch -exact $ids $nullid] >= 0 ||
5788 [lsearch -exact $ids $nullid2] >= 0} {
5789 if {![info exists treepending]} {
5790 gettreediffs $ids
5792 } else {
5793 addtocflist $ids
5797 proc path_filter {filter name} {
5798 foreach p $filter {
5799 set l [string length $p]
5800 if {[string index $p end] eq "/"} {
5801 if {[string compare -length $l $p $name] == 0} {
5802 return 1
5804 } else {
5805 if {[string compare -length $l $p $name] == 0 &&
5806 ([string length $name] == $l ||
5807 [string index $name $l] eq "/")} {
5808 return 1
5812 return 0
5815 proc addtocflist {ids} {
5816 global treediffs
5818 add_flist $treediffs($ids)
5819 getblobdiffs $ids
5822 proc diffcmd {ids flags} {
5823 global nullid nullid2
5825 set i [lsearch -exact $ids $nullid]
5826 set j [lsearch -exact $ids $nullid2]
5827 if {$i >= 0} {
5828 if {[llength $ids] > 1 && $j < 0} {
5829 # comparing working directory with some specific revision
5830 set cmd [concat | git diff-index $flags]
5831 if {$i == 0} {
5832 lappend cmd -R [lindex $ids 1]
5833 } else {
5834 lappend cmd [lindex $ids 0]
5836 } else {
5837 # comparing working directory with index
5838 set cmd [concat | git diff-files $flags]
5839 if {$j == 1} {
5840 lappend cmd -R
5843 } elseif {$j >= 0} {
5844 set cmd [concat | git diff-index --cached $flags]
5845 if {[llength $ids] > 1} {
5846 # comparing index with specific revision
5847 if {$i == 0} {
5848 lappend cmd -R [lindex $ids 1]
5849 } else {
5850 lappend cmd [lindex $ids 0]
5852 } else {
5853 # comparing index with HEAD
5854 lappend cmd HEAD
5856 } else {
5857 set cmd [concat | git diff-tree -r $flags $ids]
5859 return $cmd
5862 proc gettreediffs {ids} {
5863 global treediff treepending
5865 set treepending $ids
5866 set treediff {}
5867 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5868 fconfigure $gdtf -blocking 0
5869 filerun $gdtf [list gettreediffline $gdtf $ids]
5872 proc gettreediffline {gdtf ids} {
5873 global treediff treediffs treepending diffids diffmergeid
5874 global cmitmode viewfiles curview limitdiffs
5876 set nr 0
5877 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5878 set i [string first "\t" $line]
5879 if {$i >= 0} {
5880 set file [string range $line [expr {$i+1}] end]
5881 if {[string index $file 0] eq "\""} {
5882 set file [lindex $file 0]
5884 lappend treediff $file
5887 if {![eof $gdtf]} {
5888 return [expr {$nr >= 1000? 2: 1}]
5890 close $gdtf
5891 if {$limitdiffs && $viewfiles($curview) ne {}} {
5892 set flist {}
5893 foreach f $treediff {
5894 if {[path_filter $viewfiles($curview) $f]} {
5895 lappend flist $f
5898 set treediffs($ids) $flist
5899 } else {
5900 set treediffs($ids) $treediff
5902 unset treepending
5903 if {$cmitmode eq "tree"} {
5904 gettree $diffids
5905 } elseif {$ids != $diffids} {
5906 if {![info exists diffmergeid]} {
5907 gettreediffs $diffids
5909 } else {
5910 addtocflist $ids
5912 return 0
5915 # empty string or positive integer
5916 proc diffcontextvalidate {v} {
5917 return [regexp {^(|[1-9][0-9]*)$} $v]
5920 proc diffcontextchange {n1 n2 op} {
5921 global diffcontextstring diffcontext
5923 if {[string is integer -strict $diffcontextstring]} {
5924 if {$diffcontextstring > 0} {
5925 set diffcontext $diffcontextstring
5926 reselectline
5931 proc getblobdiffs {ids} {
5932 global blobdifffd diffids env
5933 global diffinhdr treediffs
5934 global diffcontext
5935 global limitdiffs viewfiles curview
5937 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5938 if {$limitdiffs && $viewfiles($curview) ne {}} {
5939 set cmd [concat $cmd -- $viewfiles($curview)]
5941 if {[catch {set bdf [open $cmd r]} err]} {
5942 puts "error getting diffs: $err"
5943 return
5945 set diffinhdr 0
5946 fconfigure $bdf -blocking 0
5947 set blobdifffd($ids) $bdf
5948 filerun $bdf [list getblobdiffline $bdf $diffids]
5951 proc setinlist {var i val} {
5952 global $var
5954 while {[llength [set $var]] < $i} {
5955 lappend $var {}
5957 if {[llength [set $var]] == $i} {
5958 lappend $var $val
5959 } else {
5960 lset $var $i $val
5964 proc makediffhdr {fname ids} {
5965 global ctext curdiffstart treediffs
5967 set i [lsearch -exact $treediffs($ids) $fname]
5968 if {$i >= 0} {
5969 setinlist difffilestart $i $curdiffstart
5971 set l [expr {(78 - [string length $fname]) / 2}]
5972 set pad [string range "----------------------------------------" 1 $l]
5973 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5976 proc getblobdiffline {bdf ids} {
5977 global diffids blobdifffd ctext curdiffstart
5978 global diffnexthead diffnextnote difffilestart
5979 global diffinhdr treediffs
5981 set nr 0
5982 $ctext conf -state normal
5983 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5984 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5985 close $bdf
5986 return 0
5988 if {![string compare -length 11 "diff --git " $line]} {
5989 # trim off "diff --git "
5990 set line [string range $line 11 end]
5991 set diffinhdr 1
5992 # start of a new file
5993 $ctext insert end "\n"
5994 set curdiffstart [$ctext index "end - 1c"]
5995 $ctext insert end "\n" filesep
5996 # If the name hasn't changed the length will be odd,
5997 # the middle char will be a space, and the two bits either
5998 # side will be a/name and b/name, or "a/name" and "b/name".
5999 # If the name has changed we'll get "rename from" and
6000 # "rename to" or "copy from" and "copy to" lines following this,
6001 # and we'll use them to get the filenames.
6002 # This complexity is necessary because spaces in the filename(s)
6003 # don't get escaped.
6004 set l [string length $line]
6005 set i [expr {$l / 2}]
6006 if {!(($l & 1) && [string index $line $i] eq " " &&
6007 [string range $line 2 [expr {$i - 1}]] eq \
6008 [string range $line [expr {$i + 3}] end])} {
6009 continue
6011 # unescape if quoted and chop off the a/ from the front
6012 if {[string index $line 0] eq "\""} {
6013 set fname [string range [lindex $line 0] 2 end]
6014 } else {
6015 set fname [string range $line 2 [expr {$i - 1}]]
6017 makediffhdr $fname $ids
6019 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6020 $line match f1l f1c f2l f2c rest]} {
6021 $ctext insert end "$line\n" hunksep
6022 set diffinhdr 0
6024 } elseif {$diffinhdr} {
6025 if {![string compare -length 12 "rename from " $line]} {
6026 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6027 if {[string index $fname 0] eq "\""} {
6028 set fname [lindex $fname 0]
6030 set i [lsearch -exact $treediffs($ids) $fname]
6031 if {$i >= 0} {
6032 setinlist difffilestart $i $curdiffstart
6034 } elseif {![string compare -length 10 $line "rename to "] ||
6035 ![string compare -length 8 $line "copy to "]} {
6036 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6037 if {[string index $fname 0] eq "\""} {
6038 set fname [lindex $fname 0]
6040 makediffhdr $fname $ids
6041 } elseif {[string compare -length 3 $line "---"] == 0} {
6042 # do nothing
6043 continue
6044 } elseif {[string compare -length 3 $line "+++"] == 0} {
6045 set diffinhdr 0
6046 continue
6048 $ctext insert end "$line\n" filesep
6050 } else {
6051 set x [string range $line 0 0]
6052 if {$x == "-" || $x == "+"} {
6053 set tag [expr {$x == "+"}]
6054 $ctext insert end "$line\n" d$tag
6055 } elseif {$x == " "} {
6056 $ctext insert end "$line\n"
6057 } else {
6058 # "\ No newline at end of file",
6059 # or something else we don't recognize
6060 $ctext insert end "$line\n" hunksep
6064 $ctext conf -state disabled
6065 if {[eof $bdf]} {
6066 close $bdf
6067 return 0
6069 return [expr {$nr >= 1000? 2: 1}]
6072 proc changediffdisp {} {
6073 global ctext diffelide
6075 $ctext tag conf d0 -elide [lindex $diffelide 0]
6076 $ctext tag conf d1 -elide [lindex $diffelide 1]
6079 proc prevfile {} {
6080 global difffilestart ctext
6081 set prev [lindex $difffilestart 0]
6082 set here [$ctext index @0,0]
6083 foreach loc $difffilestart {
6084 if {[$ctext compare $loc >= $here]} {
6085 $ctext yview $prev
6086 return
6088 set prev $loc
6090 $ctext yview $prev
6093 proc nextfile {} {
6094 global difffilestart ctext
6095 set here [$ctext index @0,0]
6096 foreach loc $difffilestart {
6097 if {[$ctext compare $loc > $here]} {
6098 $ctext yview $loc
6099 return
6104 proc clear_ctext {{first 1.0}} {
6105 global ctext smarktop smarkbot
6106 global pendinglinks
6108 set l [lindex [split $first .] 0]
6109 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6110 set smarktop $l
6112 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6113 set smarkbot $l
6115 $ctext delete $first end
6116 if {$first eq "1.0"} {
6117 catch {unset pendinglinks}
6121 proc settabs {{firstab {}}} {
6122 global firsttabstop tabstop ctext have_tk85
6124 if {$firstab ne {} && $have_tk85} {
6125 set firsttabstop $firstab
6127 set w [font measure textfont "0"]
6128 if {$firsttabstop != 0} {
6129 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6130 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6131 } elseif {$have_tk85 || $tabstop != 8} {
6132 $ctext conf -tabs [expr {$tabstop * $w}]
6133 } else {
6134 $ctext conf -tabs {}
6138 proc incrsearch {name ix op} {
6139 global ctext searchstring searchdirn
6141 $ctext tag remove found 1.0 end
6142 if {[catch {$ctext index anchor}]} {
6143 # no anchor set, use start of selection, or of visible area
6144 set sel [$ctext tag ranges sel]
6145 if {$sel ne {}} {
6146 $ctext mark set anchor [lindex $sel 0]
6147 } elseif {$searchdirn eq "-forwards"} {
6148 $ctext mark set anchor @0,0
6149 } else {
6150 $ctext mark set anchor @0,[winfo height $ctext]
6153 if {$searchstring ne {}} {
6154 set here [$ctext search $searchdirn -- $searchstring anchor]
6155 if {$here ne {}} {
6156 $ctext see $here
6158 searchmarkvisible 1
6162 proc dosearch {} {
6163 global sstring ctext searchstring searchdirn
6165 focus $sstring
6166 $sstring icursor end
6167 set searchdirn -forwards
6168 if {$searchstring ne {}} {
6169 set sel [$ctext tag ranges sel]
6170 if {$sel ne {}} {
6171 set start "[lindex $sel 0] + 1c"
6172 } elseif {[catch {set start [$ctext index anchor]}]} {
6173 set start "@0,0"
6175 set match [$ctext search -count mlen -- $searchstring $start]
6176 $ctext tag remove sel 1.0 end
6177 if {$match eq {}} {
6178 bell
6179 return
6181 $ctext see $match
6182 set mend "$match + $mlen c"
6183 $ctext tag add sel $match $mend
6184 $ctext mark unset anchor
6188 proc dosearchback {} {
6189 global sstring ctext searchstring searchdirn
6191 focus $sstring
6192 $sstring icursor end
6193 set searchdirn -backwards
6194 if {$searchstring ne {}} {
6195 set sel [$ctext tag ranges sel]
6196 if {$sel ne {}} {
6197 set start [lindex $sel 0]
6198 } elseif {[catch {set start [$ctext index anchor]}]} {
6199 set start @0,[winfo height $ctext]
6201 set match [$ctext search -backwards -count ml -- $searchstring $start]
6202 $ctext tag remove sel 1.0 end
6203 if {$match eq {}} {
6204 bell
6205 return
6207 $ctext see $match
6208 set mend "$match + $ml c"
6209 $ctext tag add sel $match $mend
6210 $ctext mark unset anchor
6214 proc searchmark {first last} {
6215 global ctext searchstring
6217 set mend $first.0
6218 while {1} {
6219 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6220 if {$match eq {}} break
6221 set mend "$match + $mlen c"
6222 $ctext tag add found $match $mend
6226 proc searchmarkvisible {doall} {
6227 global ctext smarktop smarkbot
6229 set topline [lindex [split [$ctext index @0,0] .] 0]
6230 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6231 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6232 # no overlap with previous
6233 searchmark $topline $botline
6234 set smarktop $topline
6235 set smarkbot $botline
6236 } else {
6237 if {$topline < $smarktop} {
6238 searchmark $topline [expr {$smarktop-1}]
6239 set smarktop $topline
6241 if {$botline > $smarkbot} {
6242 searchmark [expr {$smarkbot+1}] $botline
6243 set smarkbot $botline
6248 proc scrolltext {f0 f1} {
6249 global searchstring
6251 .bleft.sb set $f0 $f1
6252 if {$searchstring ne {}} {
6253 searchmarkvisible 0
6257 proc setcoords {} {
6258 global linespc charspc canvx0 canvy0
6259 global xspc1 xspc2 lthickness
6261 set linespc [font metrics mainfont -linespace]
6262 set charspc [font measure mainfont "m"]
6263 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6264 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6265 set lthickness [expr {int($linespc / 9) + 1}]
6266 set xspc1(0) $linespc
6267 set xspc2 $linespc
6270 proc redisplay {} {
6271 global canv
6272 global selectedline
6274 set ymax [lindex [$canv cget -scrollregion] 3]
6275 if {$ymax eq {} || $ymax == 0} return
6276 set span [$canv yview]
6277 clear_display
6278 setcanvscroll
6279 allcanvs yview moveto [lindex $span 0]
6280 drawvisible
6281 if {[info exists selectedline]} {
6282 selectline $selectedline 0
6283 allcanvs yview moveto [lindex $span 0]
6287 proc parsefont {f n} {
6288 global fontattr
6290 set fontattr($f,family) [lindex $n 0]
6291 set s [lindex $n 1]
6292 if {$s eq {} || $s == 0} {
6293 set s 10
6294 } elseif {$s < 0} {
6295 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6297 set fontattr($f,size) $s
6298 set fontattr($f,weight) normal
6299 set fontattr($f,slant) roman
6300 foreach style [lrange $n 2 end] {
6301 switch -- $style {
6302 "normal" -
6303 "bold" {set fontattr($f,weight) $style}
6304 "roman" -
6305 "italic" {set fontattr($f,slant) $style}
6310 proc fontflags {f {isbold 0}} {
6311 global fontattr
6313 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6314 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6315 -slant $fontattr($f,slant)]
6318 proc fontname {f} {
6319 global fontattr
6321 set n [list $fontattr($f,family) $fontattr($f,size)]
6322 if {$fontattr($f,weight) eq "bold"} {
6323 lappend n "bold"
6325 if {$fontattr($f,slant) eq "italic"} {
6326 lappend n "italic"
6328 return $n
6331 proc incrfont {inc} {
6332 global mainfont textfont ctext canv cflist showrefstop
6333 global stopped entries fontattr
6335 unmarkmatches
6336 set s $fontattr(mainfont,size)
6337 incr s $inc
6338 if {$s < 1} {
6339 set s 1
6341 set fontattr(mainfont,size) $s
6342 font config mainfont -size $s
6343 font config mainfontbold -size $s
6344 set mainfont [fontname mainfont]
6345 set s $fontattr(textfont,size)
6346 incr s $inc
6347 if {$s < 1} {
6348 set s 1
6350 set fontattr(textfont,size) $s
6351 font config textfont -size $s
6352 font config textfontbold -size $s
6353 set textfont [fontname textfont]
6354 setcoords
6355 settabs
6356 redisplay
6359 proc clearsha1 {} {
6360 global sha1entry sha1string
6361 if {[string length $sha1string] == 40} {
6362 $sha1entry delete 0 end
6366 proc sha1change {n1 n2 op} {
6367 global sha1string currentid sha1but
6368 if {$sha1string == {}
6369 || ([info exists currentid] && $sha1string == $currentid)} {
6370 set state disabled
6371 } else {
6372 set state normal
6374 if {[$sha1but cget -state] == $state} return
6375 if {$state == "normal"} {
6376 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6377 } else {
6378 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6382 proc gotocommit {} {
6383 global sha1string tagids headids curview varcid
6385 if {$sha1string == {}
6386 || ([info exists currentid] && $sha1string == $currentid)} return
6387 if {[info exists tagids($sha1string)]} {
6388 set id $tagids($sha1string)
6389 } elseif {[info exists headids($sha1string)]} {
6390 set id $headids($sha1string)
6391 } else {
6392 set id [string tolower $sha1string]
6393 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6394 set matches [array names varcid "$curview,$id*"]
6395 if {$matches ne {}} {
6396 if {[llength $matches] > 1} {
6397 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6398 return
6400 set id [lindex [split [lindex $matches 0] ","] 1]
6404 if {[commitinview $id $curview]} {
6405 selectline [rowofcommit $id] 1
6406 return
6408 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6409 set msg [mc "SHA1 id %s is not known" $sha1string]
6410 } else {
6411 set msg [mc "Tag/Head %s is not known" $sha1string]
6413 error_popup $msg
6416 proc lineenter {x y id} {
6417 global hoverx hovery hoverid hovertimer
6418 global commitinfo canv
6420 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6421 set hoverx $x
6422 set hovery $y
6423 set hoverid $id
6424 if {[info exists hovertimer]} {
6425 after cancel $hovertimer
6427 set hovertimer [after 500 linehover]
6428 $canv delete hover
6431 proc linemotion {x y id} {
6432 global hoverx hovery hoverid hovertimer
6434 if {[info exists hoverid] && $id == $hoverid} {
6435 set hoverx $x
6436 set hovery $y
6437 if {[info exists hovertimer]} {
6438 after cancel $hovertimer
6440 set hovertimer [after 500 linehover]
6444 proc lineleave {id} {
6445 global hoverid hovertimer canv
6447 if {[info exists hoverid] && $id == $hoverid} {
6448 $canv delete hover
6449 if {[info exists hovertimer]} {
6450 after cancel $hovertimer
6451 unset hovertimer
6453 unset hoverid
6457 proc linehover {} {
6458 global hoverx hovery hoverid hovertimer
6459 global canv linespc lthickness
6460 global commitinfo
6462 set text [lindex $commitinfo($hoverid) 0]
6463 set ymax [lindex [$canv cget -scrollregion] 3]
6464 if {$ymax == {}} return
6465 set yfrac [lindex [$canv yview] 0]
6466 set x [expr {$hoverx + 2 * $linespc}]
6467 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6468 set x0 [expr {$x - 2 * $lthickness}]
6469 set y0 [expr {$y - 2 * $lthickness}]
6470 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6471 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6472 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6473 -fill \#ffff80 -outline black -width 1 -tags hover]
6474 $canv raise $t
6475 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6476 -font mainfont]
6477 $canv raise $t
6480 proc clickisonarrow {id y} {
6481 global lthickness
6483 set ranges [rowranges $id]
6484 set thresh [expr {2 * $lthickness + 6}]
6485 set n [expr {[llength $ranges] - 1}]
6486 for {set i 1} {$i < $n} {incr i} {
6487 set row [lindex $ranges $i]
6488 if {abs([yc $row] - $y) < $thresh} {
6489 return $i
6492 return {}
6495 proc arrowjump {id n y} {
6496 global canv
6498 # 1 <-> 2, 3 <-> 4, etc...
6499 set n [expr {(($n - 1) ^ 1) + 1}]
6500 set row [lindex [rowranges $id] $n]
6501 set yt [yc $row]
6502 set ymax [lindex [$canv cget -scrollregion] 3]
6503 if {$ymax eq {} || $ymax <= 0} return
6504 set view [$canv yview]
6505 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6506 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6507 if {$yfrac < 0} {
6508 set yfrac 0
6510 allcanvs yview moveto $yfrac
6513 proc lineclick {x y id isnew} {
6514 global ctext commitinfo children canv thickerline curview
6516 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6517 unmarkmatches
6518 unselectline
6519 normalline
6520 $canv delete hover
6521 # draw this line thicker than normal
6522 set thickerline $id
6523 drawlines $id
6524 if {$isnew} {
6525 set ymax [lindex [$canv cget -scrollregion] 3]
6526 if {$ymax eq {}} return
6527 set yfrac [lindex [$canv yview] 0]
6528 set y [expr {$y + $yfrac * $ymax}]
6530 set dirn [clickisonarrow $id $y]
6531 if {$dirn ne {}} {
6532 arrowjump $id $dirn $y
6533 return
6536 if {$isnew} {
6537 addtohistory [list lineclick $x $y $id 0]
6539 # fill the details pane with info about this line
6540 $ctext conf -state normal
6541 clear_ctext
6542 settabs 0
6543 $ctext insert end "[mc "Parent"]:\t"
6544 $ctext insert end $id link0
6545 setlink $id link0
6546 set info $commitinfo($id)
6547 $ctext insert end "\n\t[lindex $info 0]\n"
6548 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
6549 set date [formatdate [lindex $info 2]]
6550 $ctext insert end "\t[mc "Date"]:\t$date\n"
6551 set kids $children($curview,$id)
6552 if {$kids ne {}} {
6553 $ctext insert end "\n[mc "Children"]:"
6554 set i 0
6555 foreach child $kids {
6556 incr i
6557 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6558 set info $commitinfo($child)
6559 $ctext insert end "\n\t"
6560 $ctext insert end $child link$i
6561 setlink $child link$i
6562 $ctext insert end "\n\t[lindex $info 0]"
6563 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
6564 set date [formatdate [lindex $info 2]]
6565 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
6568 $ctext conf -state disabled
6569 init_flist {}
6572 proc normalline {} {
6573 global thickerline
6574 if {[info exists thickerline]} {
6575 set id $thickerline
6576 unset thickerline
6577 drawlines $id
6581 proc selbyid {id} {
6582 global curview
6583 if {[commitinview $id $curview]} {
6584 selectline [rowofcommit $id] 1
6588 proc mstime {} {
6589 global startmstime
6590 if {![info exists startmstime]} {
6591 set startmstime [clock clicks -milliseconds]
6593 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6596 proc rowmenu {x y id} {
6597 global rowctxmenu selectedline rowmenuid curview
6598 global nullid nullid2 fakerowmenu mainhead
6600 stopfinding
6601 set rowmenuid $id
6602 if {![info exists selectedline]
6603 || [rowofcommit $id] eq $selectedline} {
6604 set state disabled
6605 } else {
6606 set state normal
6608 if {$id ne $nullid && $id ne $nullid2} {
6609 set menu $rowctxmenu
6610 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6611 } else {
6612 set menu $fakerowmenu
6614 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6615 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6616 $menu entryconfigure [mc "Make patch"] -state $state
6617 tk_popup $menu $x $y
6620 proc diffvssel {dirn} {
6621 global rowmenuid selectedline
6623 if {![info exists selectedline]} return
6624 if {$dirn} {
6625 set oldid [commitonrow $selectedline]
6626 set newid $rowmenuid
6627 } else {
6628 set oldid $rowmenuid
6629 set newid [commitonrow $selectedline]
6631 addtohistory [list doseldiff $oldid $newid]
6632 doseldiff $oldid $newid
6635 proc doseldiff {oldid newid} {
6636 global ctext
6637 global commitinfo
6639 $ctext conf -state normal
6640 clear_ctext
6641 init_flist [mc "Top"]
6642 $ctext insert end "[mc "From"] "
6643 $ctext insert end $oldid link0
6644 setlink $oldid link0
6645 $ctext insert end "\n "
6646 $ctext insert end [lindex $commitinfo($oldid) 0]
6647 $ctext insert end "\n\n[mc "To"] "
6648 $ctext insert end $newid link1
6649 setlink $newid link1
6650 $ctext insert end "\n "
6651 $ctext insert end [lindex $commitinfo($newid) 0]
6652 $ctext insert end "\n"
6653 $ctext conf -state disabled
6654 $ctext tag remove found 1.0 end
6655 startdiff [list $oldid $newid]
6658 proc mkpatch {} {
6659 global rowmenuid currentid commitinfo patchtop patchnum
6661 if {![info exists currentid]} return
6662 set oldid $currentid
6663 set oldhead [lindex $commitinfo($oldid) 0]
6664 set newid $rowmenuid
6665 set newhead [lindex $commitinfo($newid) 0]
6666 set top .patch
6667 set patchtop $top
6668 catch {destroy $top}
6669 toplevel $top
6670 label $top.title -text [mc "Generate patch"]
6671 grid $top.title - -pady 10
6672 label $top.from -text [mc "From:"]
6673 entry $top.fromsha1 -width 40 -relief flat
6674 $top.fromsha1 insert 0 $oldid
6675 $top.fromsha1 conf -state readonly
6676 grid $top.from $top.fromsha1 -sticky w
6677 entry $top.fromhead -width 60 -relief flat
6678 $top.fromhead insert 0 $oldhead
6679 $top.fromhead conf -state readonly
6680 grid x $top.fromhead -sticky w
6681 label $top.to -text [mc "To:"]
6682 entry $top.tosha1 -width 40 -relief flat
6683 $top.tosha1 insert 0 $newid
6684 $top.tosha1 conf -state readonly
6685 grid $top.to $top.tosha1 -sticky w
6686 entry $top.tohead -width 60 -relief flat
6687 $top.tohead insert 0 $newhead
6688 $top.tohead conf -state readonly
6689 grid x $top.tohead -sticky w
6690 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6691 grid $top.rev x -pady 10
6692 label $top.flab -text [mc "Output file:"]
6693 entry $top.fname -width 60
6694 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6695 incr patchnum
6696 grid $top.flab $top.fname -sticky w
6697 frame $top.buts
6698 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6699 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6700 grid $top.buts.gen $top.buts.can
6701 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6702 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6703 grid $top.buts - -pady 10 -sticky ew
6704 focus $top.fname
6707 proc mkpatchrev {} {
6708 global patchtop
6710 set oldid [$patchtop.fromsha1 get]
6711 set oldhead [$patchtop.fromhead get]
6712 set newid [$patchtop.tosha1 get]
6713 set newhead [$patchtop.tohead get]
6714 foreach e [list fromsha1 fromhead tosha1 tohead] \
6715 v [list $newid $newhead $oldid $oldhead] {
6716 $patchtop.$e conf -state normal
6717 $patchtop.$e delete 0 end
6718 $patchtop.$e insert 0 $v
6719 $patchtop.$e conf -state readonly
6723 proc mkpatchgo {} {
6724 global patchtop nullid nullid2
6726 set oldid [$patchtop.fromsha1 get]
6727 set newid [$patchtop.tosha1 get]
6728 set fname [$patchtop.fname get]
6729 set cmd [diffcmd [list $oldid $newid] -p]
6730 # trim off the initial "|"
6731 set cmd [lrange $cmd 1 end]
6732 lappend cmd >$fname &
6733 if {[catch {eval exec $cmd} err]} {
6734 error_popup "[mc "Error creating patch:"] $err"
6736 catch {destroy $patchtop}
6737 unset patchtop
6740 proc mkpatchcan {} {
6741 global patchtop
6743 catch {destroy $patchtop}
6744 unset patchtop
6747 proc mktag {} {
6748 global rowmenuid mktagtop commitinfo
6750 set top .maketag
6751 set mktagtop $top
6752 catch {destroy $top}
6753 toplevel $top
6754 label $top.title -text [mc "Create tag"]
6755 grid $top.title - -pady 10
6756 label $top.id -text [mc "ID:"]
6757 entry $top.sha1 -width 40 -relief flat
6758 $top.sha1 insert 0 $rowmenuid
6759 $top.sha1 conf -state readonly
6760 grid $top.id $top.sha1 -sticky w
6761 entry $top.head -width 60 -relief flat
6762 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6763 $top.head conf -state readonly
6764 grid x $top.head -sticky w
6765 label $top.tlab -text [mc "Tag name:"]
6766 entry $top.tag -width 60
6767 grid $top.tlab $top.tag -sticky w
6768 frame $top.buts
6769 button $top.buts.gen -text [mc "Create"] -command mktaggo
6770 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6771 grid $top.buts.gen $top.buts.can
6772 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6773 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6774 grid $top.buts - -pady 10 -sticky ew
6775 focus $top.tag
6778 proc domktag {} {
6779 global mktagtop env tagids idtags
6781 set id [$mktagtop.sha1 get]
6782 set tag [$mktagtop.tag get]
6783 if {$tag == {}} {
6784 error_popup [mc "No tag name specified"]
6785 return
6787 if {[info exists tagids($tag)]} {
6788 error_popup [mc "Tag \"%s\" already exists" $tag]
6789 return
6791 if {[catch {
6792 set dir [gitdir]
6793 set fname [file join $dir "refs/tags" $tag]
6794 set f [open $fname w]
6795 puts $f $id
6796 close $f
6797 } err]} {
6798 error_popup "[mc "Error creating tag:"] $err"
6799 return
6802 set tagids($tag) $id
6803 lappend idtags($id) $tag
6804 redrawtags $id
6805 addedtag $id
6806 dispneartags 0
6807 run refill_reflist
6810 proc redrawtags {id} {
6811 global canv linehtag idpos currentid curview
6812 global canvxmax iddrawn
6814 if {![commitinview $id $curview]} return
6815 if {![info exists iddrawn($id)]} return
6816 set row [rowofcommit $id]
6817 $canv delete tag.$id
6818 set xt [eval drawtags $id $idpos($id)]
6819 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
6820 set text [$canv itemcget $linehtag($row) -text]
6821 set font [$canv itemcget $linehtag($row) -font]
6822 set xr [expr {$xt + [font measure $font $text]}]
6823 if {$xr > $canvxmax} {
6824 set canvxmax $xr
6825 setcanvscroll
6827 if {[info exists currentid] && $currentid == $id} {
6828 make_secsel $row
6832 proc mktagcan {} {
6833 global mktagtop
6835 catch {destroy $mktagtop}
6836 unset mktagtop
6839 proc mktaggo {} {
6840 domktag
6841 mktagcan
6844 proc writecommit {} {
6845 global rowmenuid wrcomtop commitinfo wrcomcmd
6847 set top .writecommit
6848 set wrcomtop $top
6849 catch {destroy $top}
6850 toplevel $top
6851 label $top.title -text [mc "Write commit to file"]
6852 grid $top.title - -pady 10
6853 label $top.id -text [mc "ID:"]
6854 entry $top.sha1 -width 40 -relief flat
6855 $top.sha1 insert 0 $rowmenuid
6856 $top.sha1 conf -state readonly
6857 grid $top.id $top.sha1 -sticky w
6858 entry $top.head -width 60 -relief flat
6859 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6860 $top.head conf -state readonly
6861 grid x $top.head -sticky w
6862 label $top.clab -text [mc "Command:"]
6863 entry $top.cmd -width 60 -textvariable wrcomcmd
6864 grid $top.clab $top.cmd -sticky w -pady 10
6865 label $top.flab -text [mc "Output file:"]
6866 entry $top.fname -width 60
6867 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6868 grid $top.flab $top.fname -sticky w
6869 frame $top.buts
6870 button $top.buts.gen -text [mc "Write"] -command wrcomgo
6871 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
6872 grid $top.buts.gen $top.buts.can
6873 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6874 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6875 grid $top.buts - -pady 10 -sticky ew
6876 focus $top.fname
6879 proc wrcomgo {} {
6880 global wrcomtop
6882 set id [$wrcomtop.sha1 get]
6883 set cmd "echo $id | [$wrcomtop.cmd get]"
6884 set fname [$wrcomtop.fname get]
6885 if {[catch {exec sh -c $cmd >$fname &} err]} {
6886 error_popup "[mc "Error writing commit:"] $err"
6888 catch {destroy $wrcomtop}
6889 unset wrcomtop
6892 proc wrcomcan {} {
6893 global wrcomtop
6895 catch {destroy $wrcomtop}
6896 unset wrcomtop
6899 proc mkbranch {} {
6900 global rowmenuid mkbrtop
6902 set top .makebranch
6903 catch {destroy $top}
6904 toplevel $top
6905 label $top.title -text [mc "Create new branch"]
6906 grid $top.title - -pady 10
6907 label $top.id -text [mc "ID:"]
6908 entry $top.sha1 -width 40 -relief flat
6909 $top.sha1 insert 0 $rowmenuid
6910 $top.sha1 conf -state readonly
6911 grid $top.id $top.sha1 -sticky w
6912 label $top.nlab -text [mc "Name:"]
6913 entry $top.name -width 40
6914 grid $top.nlab $top.name -sticky w
6915 frame $top.buts
6916 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
6917 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
6918 grid $top.buts.go $top.buts.can
6919 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6920 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6921 grid $top.buts - -pady 10 -sticky ew
6922 focus $top.name
6925 proc mkbrgo {top} {
6926 global headids idheads
6928 set name [$top.name get]
6929 set id [$top.sha1 get]
6930 if {$name eq {}} {
6931 error_popup [mc "Please specify a name for the new branch"]
6932 return
6934 catch {destroy $top}
6935 nowbusy newbranch
6936 update
6937 if {[catch {
6938 exec git branch $name $id
6939 } err]} {
6940 notbusy newbranch
6941 error_popup $err
6942 } else {
6943 set headids($name) $id
6944 lappend idheads($id) $name
6945 addedhead $id $name
6946 notbusy newbranch
6947 redrawtags $id
6948 dispneartags 0
6949 run refill_reflist
6953 proc cherrypick {} {
6954 global rowmenuid curview
6955 global mainhead
6957 set oldhead [exec git rev-parse HEAD]
6958 set dheads [descheads $rowmenuid]
6959 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6960 set ok [confirm_popup [mc "Commit %s is already\
6961 included in branch %s -- really re-apply it?" \
6962 [string range $rowmenuid 0 7] $mainhead]]
6963 if {!$ok} return
6965 nowbusy cherrypick [mc "Cherry-picking"]
6966 update
6967 # Unfortunately git-cherry-pick writes stuff to stderr even when
6968 # no error occurs, and exec takes that as an indication of error...
6969 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6970 notbusy cherrypick
6971 error_popup $err
6972 return
6974 set newhead [exec git rev-parse HEAD]
6975 if {$newhead eq $oldhead} {
6976 notbusy cherrypick
6977 error_popup [mc "No changes committed"]
6978 return
6980 addnewchild $newhead $oldhead
6981 if {[commitinview $oldhead $curview]} {
6982 insertrow $newhead $oldhead $curview
6983 if {$mainhead ne {}} {
6984 movehead $newhead $mainhead
6985 movedhead $newhead $mainhead
6987 redrawtags $oldhead
6988 redrawtags $newhead
6990 notbusy cherrypick
6993 proc resethead {} {
6994 global mainheadid mainhead rowmenuid confirm_ok resettype
6996 set confirm_ok 0
6997 set w ".confirmreset"
6998 toplevel $w
6999 wm transient $w .
7000 wm title $w [mc "Confirm reset"]
7001 message $w.m -text \
7002 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7003 -justify center -aspect 1000
7004 pack $w.m -side top -fill x -padx 20 -pady 20
7005 frame $w.f -relief sunken -border 2
7006 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7007 grid $w.f.rt -sticky w
7008 set resettype mixed
7009 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7010 -text [mc "Soft: Leave working tree and index untouched"]
7011 grid $w.f.soft -sticky w
7012 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7013 -text [mc "Mixed: Leave working tree untouched, reset index"]
7014 grid $w.f.mixed -sticky w
7015 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7016 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7017 grid $w.f.hard -sticky w
7018 pack $w.f -side top -fill x
7019 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7020 pack $w.ok -side left -fill x -padx 20 -pady 20
7021 button $w.cancel -text [mc Cancel] -command "destroy $w"
7022 pack $w.cancel -side right -fill x -padx 20 -pady 20
7023 bind $w <Visibility> "grab $w; focus $w"
7024 tkwait window $w
7025 if {!$confirm_ok} return
7026 if {[catch {set fd [open \
7027 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
7028 error_popup $err
7029 } else {
7030 dohidelocalchanges
7031 filerun $fd [list readresetstat $fd]
7032 nowbusy reset [mc "Resetting"]
7036 proc readresetstat {fd} {
7037 global mainhead mainheadid showlocalchanges rprogcoord
7039 if {[gets $fd line] >= 0} {
7040 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7041 set rprogcoord [expr {1.0 * $m / $n}]
7042 adjustprogress
7044 return 1
7046 set rprogcoord 0
7047 adjustprogress
7048 notbusy reset
7049 if {[catch {close $fd} err]} {
7050 error_popup $err
7052 set oldhead $mainheadid
7053 set newhead [exec git rev-parse HEAD]
7054 if {$newhead ne $oldhead} {
7055 movehead $newhead $mainhead
7056 movedhead $newhead $mainhead
7057 set mainheadid $newhead
7058 redrawtags $oldhead
7059 redrawtags $newhead
7061 if {$showlocalchanges} {
7062 doshowlocalchanges
7064 return 0
7067 # context menu for a head
7068 proc headmenu {x y id head} {
7069 global headmenuid headmenuhead headctxmenu mainhead
7071 stopfinding
7072 set headmenuid $id
7073 set headmenuhead $head
7074 set state normal
7075 if {$head eq $mainhead} {
7076 set state disabled
7078 $headctxmenu entryconfigure 0 -state $state
7079 $headctxmenu entryconfigure 1 -state $state
7080 tk_popup $headctxmenu $x $y
7083 proc cobranch {} {
7084 global headmenuid headmenuhead mainhead headids
7085 global showlocalchanges mainheadid
7087 # check the tree is clean first??
7088 set oldmainhead $mainhead
7089 nowbusy checkout [mc "Checking out"]
7090 update
7091 dohidelocalchanges
7092 if {[catch {
7093 exec git checkout -q $headmenuhead
7094 } err]} {
7095 notbusy checkout
7096 error_popup $err
7097 } else {
7098 notbusy checkout
7099 set mainhead $headmenuhead
7100 set mainheadid $headmenuid
7101 if {[info exists headids($oldmainhead)]} {
7102 redrawtags $headids($oldmainhead)
7104 redrawtags $headmenuid
7106 if {$showlocalchanges} {
7107 dodiffindex
7111 proc rmbranch {} {
7112 global headmenuid headmenuhead mainhead
7113 global idheads
7115 set head $headmenuhead
7116 set id $headmenuid
7117 # this check shouldn't be needed any more...
7118 if {$head eq $mainhead} {
7119 error_popup [mc "Cannot delete the currently checked-out branch"]
7120 return
7122 set dheads [descheads $id]
7123 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7124 # the stuff on this branch isn't on any other branch
7125 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7126 branch.\nReally delete branch %s?" $head $head]]} return
7128 nowbusy rmbranch
7129 update
7130 if {[catch {exec git branch -D $head} err]} {
7131 notbusy rmbranch
7132 error_popup $err
7133 return
7135 removehead $id $head
7136 removedhead $id $head
7137 redrawtags $id
7138 notbusy rmbranch
7139 dispneartags 0
7140 run refill_reflist
7143 # Display a list of tags and heads
7144 proc showrefs {} {
7145 global showrefstop bgcolor fgcolor selectbgcolor
7146 global bglist fglist reflistfilter reflist maincursor
7148 set top .showrefs
7149 set showrefstop $top
7150 if {[winfo exists $top]} {
7151 raise $top
7152 refill_reflist
7153 return
7155 toplevel $top
7156 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7157 text $top.list -background $bgcolor -foreground $fgcolor \
7158 -selectbackground $selectbgcolor -font mainfont \
7159 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7160 -width 30 -height 20 -cursor $maincursor \
7161 -spacing1 1 -spacing3 1 -state disabled
7162 $top.list tag configure highlight -background $selectbgcolor
7163 lappend bglist $top.list
7164 lappend fglist $top.list
7165 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7166 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7167 grid $top.list $top.ysb -sticky nsew
7168 grid $top.xsb x -sticky ew
7169 frame $top.f
7170 label $top.f.l -text "[mc "Filter"]: " -font uifont
7171 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
7172 set reflistfilter "*"
7173 trace add variable reflistfilter write reflistfilter_change
7174 pack $top.f.e -side right -fill x -expand 1
7175 pack $top.f.l -side left
7176 grid $top.f - -sticky ew -pady 2
7177 button $top.close -command [list destroy $top] -text [mc "Close"] \
7178 -font uifont
7179 grid $top.close -
7180 grid columnconfigure $top 0 -weight 1
7181 grid rowconfigure $top 0 -weight 1
7182 bind $top.list <1> {break}
7183 bind $top.list <B1-Motion> {break}
7184 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7185 set reflist {}
7186 refill_reflist
7189 proc sel_reflist {w x y} {
7190 global showrefstop reflist headids tagids otherrefids
7192 if {![winfo exists $showrefstop]} return
7193 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7194 set ref [lindex $reflist [expr {$l-1}]]
7195 set n [lindex $ref 0]
7196 switch -- [lindex $ref 1] {
7197 "H" {selbyid $headids($n)}
7198 "T" {selbyid $tagids($n)}
7199 "o" {selbyid $otherrefids($n)}
7201 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7204 proc unsel_reflist {} {
7205 global showrefstop
7207 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7208 $showrefstop.list tag remove highlight 0.0 end
7211 proc reflistfilter_change {n1 n2 op} {
7212 global reflistfilter
7214 after cancel refill_reflist
7215 after 200 refill_reflist
7218 proc refill_reflist {} {
7219 global reflist reflistfilter showrefstop headids tagids otherrefids
7220 global curview commitinterest
7222 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7223 set refs {}
7224 foreach n [array names headids] {
7225 if {[string match $reflistfilter $n]} {
7226 if {[commitinview $headids($n) $curview]} {
7227 lappend refs [list $n H]
7228 } else {
7229 set commitinterest($headids($n)) {run refill_reflist}
7233 foreach n [array names tagids] {
7234 if {[string match $reflistfilter $n]} {
7235 if {[commitinview $tagids($n) $curview]} {
7236 lappend refs [list $n T]
7237 } else {
7238 set commitinterest($tagids($n)) {run refill_reflist}
7242 foreach n [array names otherrefids] {
7243 if {[string match $reflistfilter $n]} {
7244 if {[commitinview $otherrefids($n) $curview]} {
7245 lappend refs [list $n o]
7246 } else {
7247 set commitinterest($otherrefids($n)) {run refill_reflist}
7251 set refs [lsort -index 0 $refs]
7252 if {$refs eq $reflist} return
7254 # Update the contents of $showrefstop.list according to the
7255 # differences between $reflist (old) and $refs (new)
7256 $showrefstop.list conf -state normal
7257 $showrefstop.list insert end "\n"
7258 set i 0
7259 set j 0
7260 while {$i < [llength $reflist] || $j < [llength $refs]} {
7261 if {$i < [llength $reflist]} {
7262 if {$j < [llength $refs]} {
7263 set cmp [string compare [lindex $reflist $i 0] \
7264 [lindex $refs $j 0]]
7265 if {$cmp == 0} {
7266 set cmp [string compare [lindex $reflist $i 1] \
7267 [lindex $refs $j 1]]
7269 } else {
7270 set cmp -1
7272 } else {
7273 set cmp 1
7275 switch -- $cmp {
7276 -1 {
7277 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7278 incr i
7281 incr i
7282 incr j
7285 set l [expr {$j + 1}]
7286 $showrefstop.list image create $l.0 -align baseline \
7287 -image reficon-[lindex $refs $j 1] -padx 2
7288 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7289 incr j
7293 set reflist $refs
7294 # delete last newline
7295 $showrefstop.list delete end-2c end-1c
7296 $showrefstop.list conf -state disabled
7299 # Stuff for finding nearby tags
7300 proc getallcommits {} {
7301 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7302 global idheads idtags idotherrefs allparents tagobjid
7304 if {![info exists allcommits]} {
7305 set nextarc 0
7306 set allcommits 0
7307 set seeds {}
7308 set allcwait 0
7309 set cachedarcs 0
7310 set allccache [file join [gitdir] "gitk.cache"]
7311 if {![catch {
7312 set f [open $allccache r]
7313 set allcwait 1
7314 getcache $f
7315 }]} return
7318 if {$allcwait} {
7319 return
7321 set cmd [list | git rev-list --parents]
7322 set allcupdate [expr {$seeds ne {}}]
7323 if {!$allcupdate} {
7324 set ids "--all"
7325 } else {
7326 set refs [concat [array names idheads] [array names idtags] \
7327 [array names idotherrefs]]
7328 set ids {}
7329 set tagobjs {}
7330 foreach name [array names tagobjid] {
7331 lappend tagobjs $tagobjid($name)
7333 foreach id [lsort -unique $refs] {
7334 if {![info exists allparents($id)] &&
7335 [lsearch -exact $tagobjs $id] < 0} {
7336 lappend ids $id
7339 if {$ids ne {}} {
7340 foreach id $seeds {
7341 lappend ids "^$id"
7345 if {$ids ne {}} {
7346 set fd [open [concat $cmd $ids] r]
7347 fconfigure $fd -blocking 0
7348 incr allcommits
7349 nowbusy allcommits
7350 filerun $fd [list getallclines $fd]
7351 } else {
7352 dispneartags 0
7356 # Since most commits have 1 parent and 1 child, we group strings of
7357 # such commits into "arcs" joining branch/merge points (BMPs), which
7358 # are commits that either don't have 1 parent or don't have 1 child.
7360 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7361 # arcout(id) - outgoing arcs for BMP
7362 # arcids(a) - list of IDs on arc including end but not start
7363 # arcstart(a) - BMP ID at start of arc
7364 # arcend(a) - BMP ID at end of arc
7365 # growing(a) - arc a is still growing
7366 # arctags(a) - IDs out of arcids (excluding end) that have tags
7367 # archeads(a) - IDs out of arcids (excluding end) that have heads
7368 # The start of an arc is at the descendent end, so "incoming" means
7369 # coming from descendents, and "outgoing" means going towards ancestors.
7371 proc getallclines {fd} {
7372 global allparents allchildren idtags idheads nextarc
7373 global arcnos arcids arctags arcout arcend arcstart archeads growing
7374 global seeds allcommits cachedarcs allcupdate
7376 set nid 0
7377 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7378 set id [lindex $line 0]
7379 if {[info exists allparents($id)]} {
7380 # seen it already
7381 continue
7383 set cachedarcs 0
7384 set olds [lrange $line 1 end]
7385 set allparents($id) $olds
7386 if {![info exists allchildren($id)]} {
7387 set allchildren($id) {}
7388 set arcnos($id) {}
7389 lappend seeds $id
7390 } else {
7391 set a $arcnos($id)
7392 if {[llength $olds] == 1 && [llength $a] == 1} {
7393 lappend arcids($a) $id
7394 if {[info exists idtags($id)]} {
7395 lappend arctags($a) $id
7397 if {[info exists idheads($id)]} {
7398 lappend archeads($a) $id
7400 if {[info exists allparents($olds)]} {
7401 # seen parent already
7402 if {![info exists arcout($olds)]} {
7403 splitarc $olds
7405 lappend arcids($a) $olds
7406 set arcend($a) $olds
7407 unset growing($a)
7409 lappend allchildren($olds) $id
7410 lappend arcnos($olds) $a
7411 continue
7414 foreach a $arcnos($id) {
7415 lappend arcids($a) $id
7416 set arcend($a) $id
7417 unset growing($a)
7420 set ao {}
7421 foreach p $olds {
7422 lappend allchildren($p) $id
7423 set a [incr nextarc]
7424 set arcstart($a) $id
7425 set archeads($a) {}
7426 set arctags($a) {}
7427 set archeads($a) {}
7428 set arcids($a) {}
7429 lappend ao $a
7430 set growing($a) 1
7431 if {[info exists allparents($p)]} {
7432 # seen it already, may need to make a new branch
7433 if {![info exists arcout($p)]} {
7434 splitarc $p
7436 lappend arcids($a) $p
7437 set arcend($a) $p
7438 unset growing($a)
7440 lappend arcnos($p) $a
7442 set arcout($id) $ao
7444 if {$nid > 0} {
7445 global cached_dheads cached_dtags cached_atags
7446 catch {unset cached_dheads}
7447 catch {unset cached_dtags}
7448 catch {unset cached_atags}
7450 if {![eof $fd]} {
7451 return [expr {$nid >= 1000? 2: 1}]
7453 set cacheok 1
7454 if {[catch {
7455 fconfigure $fd -blocking 1
7456 close $fd
7457 } err]} {
7458 # got an error reading the list of commits
7459 # if we were updating, try rereading the whole thing again
7460 if {$allcupdate} {
7461 incr allcommits -1
7462 dropcache $err
7463 return
7465 error_popup "[mc "Error reading commit topology information;\
7466 branch and preceding/following tag information\
7467 will be incomplete."]\n($err)"
7468 set cacheok 0
7470 if {[incr allcommits -1] == 0} {
7471 notbusy allcommits
7472 if {$cacheok} {
7473 run savecache
7476 dispneartags 0
7477 return 0
7480 proc recalcarc {a} {
7481 global arctags archeads arcids idtags idheads
7483 set at {}
7484 set ah {}
7485 foreach id [lrange $arcids($a) 0 end-1] {
7486 if {[info exists idtags($id)]} {
7487 lappend at $id
7489 if {[info exists idheads($id)]} {
7490 lappend ah $id
7493 set arctags($a) $at
7494 set archeads($a) $ah
7497 proc splitarc {p} {
7498 global arcnos arcids nextarc arctags archeads idtags idheads
7499 global arcstart arcend arcout allparents growing
7501 set a $arcnos($p)
7502 if {[llength $a] != 1} {
7503 puts "oops splitarc called but [llength $a] arcs already"
7504 return
7506 set a [lindex $a 0]
7507 set i [lsearch -exact $arcids($a) $p]
7508 if {$i < 0} {
7509 puts "oops splitarc $p not in arc $a"
7510 return
7512 set na [incr nextarc]
7513 if {[info exists arcend($a)]} {
7514 set arcend($na) $arcend($a)
7515 } else {
7516 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7517 set j [lsearch -exact $arcnos($l) $a]
7518 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7520 set tail [lrange $arcids($a) [expr {$i+1}] end]
7521 set arcids($a) [lrange $arcids($a) 0 $i]
7522 set arcend($a) $p
7523 set arcstart($na) $p
7524 set arcout($p) $na
7525 set arcids($na) $tail
7526 if {[info exists growing($a)]} {
7527 set growing($na) 1
7528 unset growing($a)
7531 foreach id $tail {
7532 if {[llength $arcnos($id)] == 1} {
7533 set arcnos($id) $na
7534 } else {
7535 set j [lsearch -exact $arcnos($id) $a]
7536 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7540 # reconstruct tags and heads lists
7541 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7542 recalcarc $a
7543 recalcarc $na
7544 } else {
7545 set arctags($na) {}
7546 set archeads($na) {}
7550 # Update things for a new commit added that is a child of one
7551 # existing commit. Used when cherry-picking.
7552 proc addnewchild {id p} {
7553 global allparents allchildren idtags nextarc
7554 global arcnos arcids arctags arcout arcend arcstart archeads growing
7555 global seeds allcommits
7557 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7558 set allparents($id) [list $p]
7559 set allchildren($id) {}
7560 set arcnos($id) {}
7561 lappend seeds $id
7562 lappend allchildren($p) $id
7563 set a [incr nextarc]
7564 set arcstart($a) $id
7565 set archeads($a) {}
7566 set arctags($a) {}
7567 set arcids($a) [list $p]
7568 set arcend($a) $p
7569 if {![info exists arcout($p)]} {
7570 splitarc $p
7572 lappend arcnos($p) $a
7573 set arcout($id) [list $a]
7576 # This implements a cache for the topology information.
7577 # The cache saves, for each arc, the start and end of the arc,
7578 # the ids on the arc, and the outgoing arcs from the end.
7579 proc readcache {f} {
7580 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7581 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7582 global allcwait
7584 set a $nextarc
7585 set lim $cachedarcs
7586 if {$lim - $a > 500} {
7587 set lim [expr {$a + 500}]
7589 if {[catch {
7590 if {$a == $lim} {
7591 # finish reading the cache and setting up arctags, etc.
7592 set line [gets $f]
7593 if {$line ne "1"} {error "bad final version"}
7594 close $f
7595 foreach id [array names idtags] {
7596 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7597 [llength $allparents($id)] == 1} {
7598 set a [lindex $arcnos($id) 0]
7599 if {$arctags($a) eq {}} {
7600 recalcarc $a
7604 foreach id [array names idheads] {
7605 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7606 [llength $allparents($id)] == 1} {
7607 set a [lindex $arcnos($id) 0]
7608 if {$archeads($a) eq {}} {
7609 recalcarc $a
7613 foreach id [lsort -unique $possible_seeds] {
7614 if {$arcnos($id) eq {}} {
7615 lappend seeds $id
7618 set allcwait 0
7619 } else {
7620 while {[incr a] <= $lim} {
7621 set line [gets $f]
7622 if {[llength $line] != 3} {error "bad line"}
7623 set s [lindex $line 0]
7624 set arcstart($a) $s
7625 lappend arcout($s) $a
7626 if {![info exists arcnos($s)]} {
7627 lappend possible_seeds $s
7628 set arcnos($s) {}
7630 set e [lindex $line 1]
7631 if {$e eq {}} {
7632 set growing($a) 1
7633 } else {
7634 set arcend($a) $e
7635 if {![info exists arcout($e)]} {
7636 set arcout($e) {}
7639 set arcids($a) [lindex $line 2]
7640 foreach id $arcids($a) {
7641 lappend allparents($s) $id
7642 set s $id
7643 lappend arcnos($id) $a
7645 if {![info exists allparents($s)]} {
7646 set allparents($s) {}
7648 set arctags($a) {}
7649 set archeads($a) {}
7651 set nextarc [expr {$a - 1}]
7653 } err]} {
7654 dropcache $err
7655 return 0
7657 if {!$allcwait} {
7658 getallcommits
7660 return $allcwait
7663 proc getcache {f} {
7664 global nextarc cachedarcs possible_seeds
7666 if {[catch {
7667 set line [gets $f]
7668 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7669 # make sure it's an integer
7670 set cachedarcs [expr {int([lindex $line 1])}]
7671 if {$cachedarcs < 0} {error "bad number of arcs"}
7672 set nextarc 0
7673 set possible_seeds {}
7674 run readcache $f
7675 } err]} {
7676 dropcache $err
7678 return 0
7681 proc dropcache {err} {
7682 global allcwait nextarc cachedarcs seeds
7684 #puts "dropping cache ($err)"
7685 foreach v {arcnos arcout arcids arcstart arcend growing \
7686 arctags archeads allparents allchildren} {
7687 global $v
7688 catch {unset $v}
7690 set allcwait 0
7691 set nextarc 0
7692 set cachedarcs 0
7693 set seeds {}
7694 getallcommits
7697 proc writecache {f} {
7698 global cachearc cachedarcs allccache
7699 global arcstart arcend arcnos arcids arcout
7701 set a $cachearc
7702 set lim $cachedarcs
7703 if {$lim - $a > 1000} {
7704 set lim [expr {$a + 1000}]
7706 if {[catch {
7707 while {[incr a] <= $lim} {
7708 if {[info exists arcend($a)]} {
7709 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7710 } else {
7711 puts $f [list $arcstart($a) {} $arcids($a)]
7714 } err]} {
7715 catch {close $f}
7716 catch {file delete $allccache}
7717 #puts "writing cache failed ($err)"
7718 return 0
7720 set cachearc [expr {$a - 1}]
7721 if {$a > $cachedarcs} {
7722 puts $f "1"
7723 close $f
7724 return 0
7726 return 1
7729 proc savecache {} {
7730 global nextarc cachedarcs cachearc allccache
7732 if {$nextarc == $cachedarcs} return
7733 set cachearc 0
7734 set cachedarcs $nextarc
7735 catch {
7736 set f [open $allccache w]
7737 puts $f [list 1 $cachedarcs]
7738 run writecache $f
7742 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7743 # or 0 if neither is true.
7744 proc anc_or_desc {a b} {
7745 global arcout arcstart arcend arcnos cached_isanc
7747 if {$arcnos($a) eq $arcnos($b)} {
7748 # Both are on the same arc(s); either both are the same BMP,
7749 # or if one is not a BMP, the other is also not a BMP or is
7750 # the BMP at end of the arc (and it only has 1 incoming arc).
7751 # Or both can be BMPs with no incoming arcs.
7752 if {$a eq $b || $arcnos($a) eq {}} {
7753 return 0
7755 # assert {[llength $arcnos($a)] == 1}
7756 set arc [lindex $arcnos($a) 0]
7757 set i [lsearch -exact $arcids($arc) $a]
7758 set j [lsearch -exact $arcids($arc) $b]
7759 if {$i < 0 || $i > $j} {
7760 return 1
7761 } else {
7762 return -1
7766 if {![info exists arcout($a)]} {
7767 set arc [lindex $arcnos($a) 0]
7768 if {[info exists arcend($arc)]} {
7769 set aend $arcend($arc)
7770 } else {
7771 set aend {}
7773 set a $arcstart($arc)
7774 } else {
7775 set aend $a
7777 if {![info exists arcout($b)]} {
7778 set arc [lindex $arcnos($b) 0]
7779 if {[info exists arcend($arc)]} {
7780 set bend $arcend($arc)
7781 } else {
7782 set bend {}
7784 set b $arcstart($arc)
7785 } else {
7786 set bend $b
7788 if {$a eq $bend} {
7789 return 1
7791 if {$b eq $aend} {
7792 return -1
7794 if {[info exists cached_isanc($a,$bend)]} {
7795 if {$cached_isanc($a,$bend)} {
7796 return 1
7799 if {[info exists cached_isanc($b,$aend)]} {
7800 if {$cached_isanc($b,$aend)} {
7801 return -1
7803 if {[info exists cached_isanc($a,$bend)]} {
7804 return 0
7808 set todo [list $a $b]
7809 set anc($a) a
7810 set anc($b) b
7811 for {set i 0} {$i < [llength $todo]} {incr i} {
7812 set x [lindex $todo $i]
7813 if {$anc($x) eq {}} {
7814 continue
7816 foreach arc $arcnos($x) {
7817 set xd $arcstart($arc)
7818 if {$xd eq $bend} {
7819 set cached_isanc($a,$bend) 1
7820 set cached_isanc($b,$aend) 0
7821 return 1
7822 } elseif {$xd eq $aend} {
7823 set cached_isanc($b,$aend) 1
7824 set cached_isanc($a,$bend) 0
7825 return -1
7827 if {![info exists anc($xd)]} {
7828 set anc($xd) $anc($x)
7829 lappend todo $xd
7830 } elseif {$anc($xd) ne $anc($x)} {
7831 set anc($xd) {}
7835 set cached_isanc($a,$bend) 0
7836 set cached_isanc($b,$aend) 0
7837 return 0
7840 # This identifies whether $desc has an ancestor that is
7841 # a growing tip of the graph and which is not an ancestor of $anc
7842 # and returns 0 if so and 1 if not.
7843 # If we subsequently discover a tag on such a growing tip, and that
7844 # turns out to be a descendent of $anc (which it could, since we
7845 # don't necessarily see children before parents), then $desc
7846 # isn't a good choice to display as a descendent tag of
7847 # $anc (since it is the descendent of another tag which is
7848 # a descendent of $anc). Similarly, $anc isn't a good choice to
7849 # display as a ancestor tag of $desc.
7851 proc is_certain {desc anc} {
7852 global arcnos arcout arcstart arcend growing problems
7854 set certain {}
7855 if {[llength $arcnos($anc)] == 1} {
7856 # tags on the same arc are certain
7857 if {$arcnos($desc) eq $arcnos($anc)} {
7858 return 1
7860 if {![info exists arcout($anc)]} {
7861 # if $anc is partway along an arc, use the start of the arc instead
7862 set a [lindex $arcnos($anc) 0]
7863 set anc $arcstart($a)
7866 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7867 set x $desc
7868 } else {
7869 set a [lindex $arcnos($desc) 0]
7870 set x $arcend($a)
7872 if {$x == $anc} {
7873 return 1
7875 set anclist [list $x]
7876 set dl($x) 1
7877 set nnh 1
7878 set ngrowanc 0
7879 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7880 set x [lindex $anclist $i]
7881 if {$dl($x)} {
7882 incr nnh -1
7884 set done($x) 1
7885 foreach a $arcout($x) {
7886 if {[info exists growing($a)]} {
7887 if {![info exists growanc($x)] && $dl($x)} {
7888 set growanc($x) 1
7889 incr ngrowanc
7891 } else {
7892 set y $arcend($a)
7893 if {[info exists dl($y)]} {
7894 if {$dl($y)} {
7895 if {!$dl($x)} {
7896 set dl($y) 0
7897 if {![info exists done($y)]} {
7898 incr nnh -1
7900 if {[info exists growanc($x)]} {
7901 incr ngrowanc -1
7903 set xl [list $y]
7904 for {set k 0} {$k < [llength $xl]} {incr k} {
7905 set z [lindex $xl $k]
7906 foreach c $arcout($z) {
7907 if {[info exists arcend($c)]} {
7908 set v $arcend($c)
7909 if {[info exists dl($v)] && $dl($v)} {
7910 set dl($v) 0
7911 if {![info exists done($v)]} {
7912 incr nnh -1
7914 if {[info exists growanc($v)]} {
7915 incr ngrowanc -1
7917 lappend xl $v
7924 } elseif {$y eq $anc || !$dl($x)} {
7925 set dl($y) 0
7926 lappend anclist $y
7927 } else {
7928 set dl($y) 1
7929 lappend anclist $y
7930 incr nnh
7935 foreach x [array names growanc] {
7936 if {$dl($x)} {
7937 return 0
7939 return 0
7941 return 1
7944 proc validate_arctags {a} {
7945 global arctags idtags
7947 set i -1
7948 set na $arctags($a)
7949 foreach id $arctags($a) {
7950 incr i
7951 if {![info exists idtags($id)]} {
7952 set na [lreplace $na $i $i]
7953 incr i -1
7956 set arctags($a) $na
7959 proc validate_archeads {a} {
7960 global archeads idheads
7962 set i -1
7963 set na $archeads($a)
7964 foreach id $archeads($a) {
7965 incr i
7966 if {![info exists idheads($id)]} {
7967 set na [lreplace $na $i $i]
7968 incr i -1
7971 set archeads($a) $na
7974 # Return the list of IDs that have tags that are descendents of id,
7975 # ignoring IDs that are descendents of IDs already reported.
7976 proc desctags {id} {
7977 global arcnos arcstart arcids arctags idtags allparents
7978 global growing cached_dtags
7980 if {![info exists allparents($id)]} {
7981 return {}
7983 set t1 [clock clicks -milliseconds]
7984 set argid $id
7985 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7986 # part-way along an arc; check that arc first
7987 set a [lindex $arcnos($id) 0]
7988 if {$arctags($a) ne {}} {
7989 validate_arctags $a
7990 set i [lsearch -exact $arcids($a) $id]
7991 set tid {}
7992 foreach t $arctags($a) {
7993 set j [lsearch -exact $arcids($a) $t]
7994 if {$j >= $i} break
7995 set tid $t
7997 if {$tid ne {}} {
7998 return $tid
8001 set id $arcstart($a)
8002 if {[info exists idtags($id)]} {
8003 return $id
8006 if {[info exists cached_dtags($id)]} {
8007 return $cached_dtags($id)
8010 set origid $id
8011 set todo [list $id]
8012 set queued($id) 1
8013 set nc 1
8014 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8015 set id [lindex $todo $i]
8016 set done($id) 1
8017 set ta [info exists hastaggedancestor($id)]
8018 if {!$ta} {
8019 incr nc -1
8021 # ignore tags on starting node
8022 if {!$ta && $i > 0} {
8023 if {[info exists idtags($id)]} {
8024 set tagloc($id) $id
8025 set ta 1
8026 } elseif {[info exists cached_dtags($id)]} {
8027 set tagloc($id) $cached_dtags($id)
8028 set ta 1
8031 foreach a $arcnos($id) {
8032 set d $arcstart($a)
8033 if {!$ta && $arctags($a) ne {}} {
8034 validate_arctags $a
8035 if {$arctags($a) ne {}} {
8036 lappend tagloc($id) [lindex $arctags($a) end]
8039 if {$ta || $arctags($a) ne {}} {
8040 set tomark [list $d]
8041 for {set j 0} {$j < [llength $tomark]} {incr j} {
8042 set dd [lindex $tomark $j]
8043 if {![info exists hastaggedancestor($dd)]} {
8044 if {[info exists done($dd)]} {
8045 foreach b $arcnos($dd) {
8046 lappend tomark $arcstart($b)
8048 if {[info exists tagloc($dd)]} {
8049 unset tagloc($dd)
8051 } elseif {[info exists queued($dd)]} {
8052 incr nc -1
8054 set hastaggedancestor($dd) 1
8058 if {![info exists queued($d)]} {
8059 lappend todo $d
8060 set queued($d) 1
8061 if {![info exists hastaggedancestor($d)]} {
8062 incr nc
8067 set tags {}
8068 foreach id [array names tagloc] {
8069 if {![info exists hastaggedancestor($id)]} {
8070 foreach t $tagloc($id) {
8071 if {[lsearch -exact $tags $t] < 0} {
8072 lappend tags $t
8077 set t2 [clock clicks -milliseconds]
8078 set loopix $i
8080 # remove tags that are descendents of other tags
8081 for {set i 0} {$i < [llength $tags]} {incr i} {
8082 set a [lindex $tags $i]
8083 for {set j 0} {$j < $i} {incr j} {
8084 set b [lindex $tags $j]
8085 set r [anc_or_desc $a $b]
8086 if {$r == 1} {
8087 set tags [lreplace $tags $j $j]
8088 incr j -1
8089 incr i -1
8090 } elseif {$r == -1} {
8091 set tags [lreplace $tags $i $i]
8092 incr i -1
8093 break
8098 if {[array names growing] ne {}} {
8099 # graph isn't finished, need to check if any tag could get
8100 # eclipsed by another tag coming later. Simply ignore any
8101 # tags that could later get eclipsed.
8102 set ctags {}
8103 foreach t $tags {
8104 if {[is_certain $t $origid]} {
8105 lappend ctags $t
8108 if {$tags eq $ctags} {
8109 set cached_dtags($origid) $tags
8110 } else {
8111 set tags $ctags
8113 } else {
8114 set cached_dtags($origid) $tags
8116 set t3 [clock clicks -milliseconds]
8117 if {0 && $t3 - $t1 >= 100} {
8118 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8119 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8121 return $tags
8124 proc anctags {id} {
8125 global arcnos arcids arcout arcend arctags idtags allparents
8126 global growing cached_atags
8128 if {![info exists allparents($id)]} {
8129 return {}
8131 set t1 [clock clicks -milliseconds]
8132 set argid $id
8133 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8134 # part-way along an arc; check that arc first
8135 set a [lindex $arcnos($id) 0]
8136 if {$arctags($a) ne {}} {
8137 validate_arctags $a
8138 set i [lsearch -exact $arcids($a) $id]
8139 foreach t $arctags($a) {
8140 set j [lsearch -exact $arcids($a) $t]
8141 if {$j > $i} {
8142 return $t
8146 if {![info exists arcend($a)]} {
8147 return {}
8149 set id $arcend($a)
8150 if {[info exists idtags($id)]} {
8151 return $id
8154 if {[info exists cached_atags($id)]} {
8155 return $cached_atags($id)
8158 set origid $id
8159 set todo [list $id]
8160 set queued($id) 1
8161 set taglist {}
8162 set nc 1
8163 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8164 set id [lindex $todo $i]
8165 set done($id) 1
8166 set td [info exists hastaggeddescendent($id)]
8167 if {!$td} {
8168 incr nc -1
8170 # ignore tags on starting node
8171 if {!$td && $i > 0} {
8172 if {[info exists idtags($id)]} {
8173 set tagloc($id) $id
8174 set td 1
8175 } elseif {[info exists cached_atags($id)]} {
8176 set tagloc($id) $cached_atags($id)
8177 set td 1
8180 foreach a $arcout($id) {
8181 if {!$td && $arctags($a) ne {}} {
8182 validate_arctags $a
8183 if {$arctags($a) ne {}} {
8184 lappend tagloc($id) [lindex $arctags($a) 0]
8187 if {![info exists arcend($a)]} continue
8188 set d $arcend($a)
8189 if {$td || $arctags($a) ne {}} {
8190 set tomark [list $d]
8191 for {set j 0} {$j < [llength $tomark]} {incr j} {
8192 set dd [lindex $tomark $j]
8193 if {![info exists hastaggeddescendent($dd)]} {
8194 if {[info exists done($dd)]} {
8195 foreach b $arcout($dd) {
8196 if {[info exists arcend($b)]} {
8197 lappend tomark $arcend($b)
8200 if {[info exists tagloc($dd)]} {
8201 unset tagloc($dd)
8203 } elseif {[info exists queued($dd)]} {
8204 incr nc -1
8206 set hastaggeddescendent($dd) 1
8210 if {![info exists queued($d)]} {
8211 lappend todo $d
8212 set queued($d) 1
8213 if {![info exists hastaggeddescendent($d)]} {
8214 incr nc
8219 set t2 [clock clicks -milliseconds]
8220 set loopix $i
8221 set tags {}
8222 foreach id [array names tagloc] {
8223 if {![info exists hastaggeddescendent($id)]} {
8224 foreach t $tagloc($id) {
8225 if {[lsearch -exact $tags $t] < 0} {
8226 lappend tags $t
8232 # remove tags that are ancestors of other tags
8233 for {set i 0} {$i < [llength $tags]} {incr i} {
8234 set a [lindex $tags $i]
8235 for {set j 0} {$j < $i} {incr j} {
8236 set b [lindex $tags $j]
8237 set r [anc_or_desc $a $b]
8238 if {$r == -1} {
8239 set tags [lreplace $tags $j $j]
8240 incr j -1
8241 incr i -1
8242 } elseif {$r == 1} {
8243 set tags [lreplace $tags $i $i]
8244 incr i -1
8245 break
8250 if {[array names growing] ne {}} {
8251 # graph isn't finished, need to check if any tag could get
8252 # eclipsed by another tag coming later. Simply ignore any
8253 # tags that could later get eclipsed.
8254 set ctags {}
8255 foreach t $tags {
8256 if {[is_certain $origid $t]} {
8257 lappend ctags $t
8260 if {$tags eq $ctags} {
8261 set cached_atags($origid) $tags
8262 } else {
8263 set tags $ctags
8265 } else {
8266 set cached_atags($origid) $tags
8268 set t3 [clock clicks -milliseconds]
8269 if {0 && $t3 - $t1 >= 100} {
8270 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8271 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8273 return $tags
8276 # Return the list of IDs that have heads that are descendents of id,
8277 # including id itself if it has a head.
8278 proc descheads {id} {
8279 global arcnos arcstart arcids archeads idheads cached_dheads
8280 global allparents
8282 if {![info exists allparents($id)]} {
8283 return {}
8285 set aret {}
8286 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8287 # part-way along an arc; check it first
8288 set a [lindex $arcnos($id) 0]
8289 if {$archeads($a) ne {}} {
8290 validate_archeads $a
8291 set i [lsearch -exact $arcids($a) $id]
8292 foreach t $archeads($a) {
8293 set j [lsearch -exact $arcids($a) $t]
8294 if {$j > $i} break
8295 lappend aret $t
8298 set id $arcstart($a)
8300 set origid $id
8301 set todo [list $id]
8302 set seen($id) 1
8303 set ret {}
8304 for {set i 0} {$i < [llength $todo]} {incr i} {
8305 set id [lindex $todo $i]
8306 if {[info exists cached_dheads($id)]} {
8307 set ret [concat $ret $cached_dheads($id)]
8308 } else {
8309 if {[info exists idheads($id)]} {
8310 lappend ret $id
8312 foreach a $arcnos($id) {
8313 if {$archeads($a) ne {}} {
8314 validate_archeads $a
8315 if {$archeads($a) ne {}} {
8316 set ret [concat $ret $archeads($a)]
8319 set d $arcstart($a)
8320 if {![info exists seen($d)]} {
8321 lappend todo $d
8322 set seen($d) 1
8327 set ret [lsort -unique $ret]
8328 set cached_dheads($origid) $ret
8329 return [concat $ret $aret]
8332 proc addedtag {id} {
8333 global arcnos arcout cached_dtags cached_atags
8335 if {![info exists arcnos($id)]} return
8336 if {![info exists arcout($id)]} {
8337 recalcarc [lindex $arcnos($id) 0]
8339 catch {unset cached_dtags}
8340 catch {unset cached_atags}
8343 proc addedhead {hid head} {
8344 global arcnos arcout cached_dheads
8346 if {![info exists arcnos($hid)]} return
8347 if {![info exists arcout($hid)]} {
8348 recalcarc [lindex $arcnos($hid) 0]
8350 catch {unset cached_dheads}
8353 proc removedhead {hid head} {
8354 global cached_dheads
8356 catch {unset cached_dheads}
8359 proc movedhead {hid head} {
8360 global arcnos arcout cached_dheads
8362 if {![info exists arcnos($hid)]} return
8363 if {![info exists arcout($hid)]} {
8364 recalcarc [lindex $arcnos($hid) 0]
8366 catch {unset cached_dheads}
8369 proc changedrefs {} {
8370 global cached_dheads cached_dtags cached_atags
8371 global arctags archeads arcnos arcout idheads idtags
8373 foreach id [concat [array names idheads] [array names idtags]] {
8374 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8375 set a [lindex $arcnos($id) 0]
8376 if {![info exists donearc($a)]} {
8377 recalcarc $a
8378 set donearc($a) 1
8382 catch {unset cached_dtags}
8383 catch {unset cached_atags}
8384 catch {unset cached_dheads}
8387 proc rereadrefs {} {
8388 global idtags idheads idotherrefs mainheadid
8390 set refids [concat [array names idtags] \
8391 [array names idheads] [array names idotherrefs]]
8392 foreach id $refids {
8393 if {![info exists ref($id)]} {
8394 set ref($id) [listrefs $id]
8397 set oldmainhead $mainheadid
8398 readrefs
8399 changedrefs
8400 set refids [lsort -unique [concat $refids [array names idtags] \
8401 [array names idheads] [array names idotherrefs]]]
8402 foreach id $refids {
8403 set v [listrefs $id]
8404 if {![info exists ref($id)] || $ref($id) != $v ||
8405 ($id eq $oldmainhead && $id ne $mainheadid) ||
8406 ($id eq $mainheadid && $id ne $oldmainhead)} {
8407 redrawtags $id
8410 run refill_reflist
8413 proc listrefs {id} {
8414 global idtags idheads idotherrefs
8416 set x {}
8417 if {[info exists idtags($id)]} {
8418 set x $idtags($id)
8420 set y {}
8421 if {[info exists idheads($id)]} {
8422 set y $idheads($id)
8424 set z {}
8425 if {[info exists idotherrefs($id)]} {
8426 set z $idotherrefs($id)
8428 return [list $x $y $z]
8431 proc showtag {tag isnew} {
8432 global ctext tagcontents tagids linknum tagobjid
8434 if {$isnew} {
8435 addtohistory [list showtag $tag 0]
8437 $ctext conf -state normal
8438 clear_ctext
8439 settabs 0
8440 set linknum 0
8441 if {![info exists tagcontents($tag)]} {
8442 catch {
8443 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8446 if {[info exists tagcontents($tag)]} {
8447 set text $tagcontents($tag)
8448 } else {
8449 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
8451 appendwithlinks $text {}
8452 $ctext conf -state disabled
8453 init_flist {}
8456 proc doquit {} {
8457 global stopped
8458 set stopped 100
8459 savestuff .
8460 destroy .
8463 proc mkfontdisp {font top which} {
8464 global fontattr fontpref $font
8466 set fontpref($font) [set $font]
8467 button $top.${font}but -text $which -font optionfont \
8468 -command [list choosefont $font $which]
8469 label $top.$font -relief flat -font $font \
8470 -text $fontattr($font,family) -justify left
8471 grid x $top.${font}but $top.$font -sticky w
8474 proc choosefont {font which} {
8475 global fontparam fontlist fonttop fontattr
8477 set fontparam(which) $which
8478 set fontparam(font) $font
8479 set fontparam(family) [font actual $font -family]
8480 set fontparam(size) $fontattr($font,size)
8481 set fontparam(weight) $fontattr($font,weight)
8482 set fontparam(slant) $fontattr($font,slant)
8483 set top .gitkfont
8484 set fonttop $top
8485 if {![winfo exists $top]} {
8486 font create sample
8487 eval font config sample [font actual $font]
8488 toplevel $top
8489 wm title $top [mc "Gitk font chooser"]
8490 label $top.l -textvariable fontparam(which) -font uifont
8491 pack $top.l -side top
8492 set fontlist [lsort [font families]]
8493 frame $top.f
8494 listbox $top.f.fam -listvariable fontlist \
8495 -yscrollcommand [list $top.f.sb set]
8496 bind $top.f.fam <<ListboxSelect>> selfontfam
8497 scrollbar $top.f.sb -command [list $top.f.fam yview]
8498 pack $top.f.sb -side right -fill y
8499 pack $top.f.fam -side left -fill both -expand 1
8500 pack $top.f -side top -fill both -expand 1
8501 frame $top.g
8502 spinbox $top.g.size -from 4 -to 40 -width 4 \
8503 -textvariable fontparam(size) \
8504 -validatecommand {string is integer -strict %s}
8505 checkbutton $top.g.bold -padx 5 \
8506 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8507 -variable fontparam(weight) -onvalue bold -offvalue normal
8508 checkbutton $top.g.ital -padx 5 \
8509 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8510 -variable fontparam(slant) -onvalue italic -offvalue roman
8511 pack $top.g.size $top.g.bold $top.g.ital -side left
8512 pack $top.g -side top
8513 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8514 -background white
8515 $top.c create text 100 25 -anchor center -text $which -font sample \
8516 -fill black -tags text
8517 bind $top.c <Configure> [list centertext $top.c]
8518 pack $top.c -side top -fill x
8519 frame $top.buts
8520 button $top.buts.ok -text [mc "OK"] -command fontok -default active \
8521 -font uifont
8522 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal \
8523 -font uifont
8524 grid $top.buts.ok $top.buts.can
8525 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8526 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8527 pack $top.buts -side bottom -fill x
8528 trace add variable fontparam write chg_fontparam
8529 } else {
8530 raise $top
8531 $top.c itemconf text -text $which
8533 set i [lsearch -exact $fontlist $fontparam(family)]
8534 if {$i >= 0} {
8535 $top.f.fam selection set $i
8536 $top.f.fam see $i
8540 proc centertext {w} {
8541 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8544 proc fontok {} {
8545 global fontparam fontpref prefstop
8547 set f $fontparam(font)
8548 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8549 if {$fontparam(weight) eq "bold"} {
8550 lappend fontpref($f) "bold"
8552 if {$fontparam(slant) eq "italic"} {
8553 lappend fontpref($f) "italic"
8555 set w $prefstop.$f
8556 $w conf -text $fontparam(family) -font $fontpref($f)
8558 fontcan
8561 proc fontcan {} {
8562 global fonttop fontparam
8564 if {[info exists fonttop]} {
8565 catch {destroy $fonttop}
8566 catch {font delete sample}
8567 unset fonttop
8568 unset fontparam
8572 proc selfontfam {} {
8573 global fonttop fontparam
8575 set i [$fonttop.f.fam curselection]
8576 if {$i ne {}} {
8577 set fontparam(family) [$fonttop.f.fam get $i]
8581 proc chg_fontparam {v sub op} {
8582 global fontparam
8584 font config sample -$sub $fontparam($sub)
8587 proc doprefs {} {
8588 global maxwidth maxgraphpct
8589 global oldprefs prefstop showneartags showlocalchanges
8590 global bgcolor fgcolor ctext diffcolors selectbgcolor
8591 global uifont tabstop limitdiffs
8593 set top .gitkprefs
8594 set prefstop $top
8595 if {[winfo exists $top]} {
8596 raise $top
8597 return
8599 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8600 limitdiffs tabstop} {
8601 set oldprefs($v) [set $v]
8603 toplevel $top
8604 wm title $top [mc "Gitk preferences"]
8605 label $top.ldisp -text [mc "Commit list display options"]
8606 $top.ldisp configure -font uifont
8607 grid $top.ldisp - -sticky w -pady 10
8608 label $top.spacer -text " "
8609 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8610 -font optionfont
8611 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8612 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8613 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8614 -font optionfont
8615 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8616 grid x $top.maxpctl $top.maxpct -sticky w
8617 frame $top.showlocal
8618 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8619 checkbutton $top.showlocal.b -variable showlocalchanges
8620 pack $top.showlocal.b $top.showlocal.l -side left
8621 grid x $top.showlocal -sticky w
8623 label $top.ddisp -text [mc "Diff display options"]
8624 $top.ddisp configure -font uifont
8625 grid $top.ddisp - -sticky w -pady 10
8626 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8627 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8628 grid x $top.tabstopl $top.tabstop -sticky w
8629 frame $top.ntag
8630 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8631 checkbutton $top.ntag.b -variable showneartags
8632 pack $top.ntag.b $top.ntag.l -side left
8633 grid x $top.ntag -sticky w
8634 frame $top.ldiff
8635 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8636 checkbutton $top.ldiff.b -variable limitdiffs
8637 pack $top.ldiff.b $top.ldiff.l -side left
8638 grid x $top.ldiff -sticky w
8640 label $top.cdisp -text [mc "Colors: press to choose"]
8641 $top.cdisp configure -font uifont
8642 grid $top.cdisp - -sticky w -pady 10
8643 label $top.bg -padx 40 -relief sunk -background $bgcolor
8644 button $top.bgbut -text [mc "Background"] -font optionfont \
8645 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8646 grid x $top.bgbut $top.bg -sticky w
8647 label $top.fg -padx 40 -relief sunk -background $fgcolor
8648 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8649 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8650 grid x $top.fgbut $top.fg -sticky w
8651 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8652 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8653 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8654 [list $ctext tag conf d0 -foreground]]
8655 grid x $top.diffoldbut $top.diffold -sticky w
8656 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8657 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8658 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8659 [list $ctext tag conf d1 -foreground]]
8660 grid x $top.diffnewbut $top.diffnew -sticky w
8661 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8662 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8663 -command [list choosecolor diffcolors 2 $top.hunksep \
8664 "diff hunk header" \
8665 [list $ctext tag conf hunksep -foreground]]
8666 grid x $top.hunksepbut $top.hunksep -sticky w
8667 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8668 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8669 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8670 grid x $top.selbgbut $top.selbgsep -sticky w
8672 label $top.cfont -text [mc "Fonts: press to choose"]
8673 $top.cfont configure -font uifont
8674 grid $top.cfont - -sticky w -pady 10
8675 mkfontdisp mainfont $top [mc "Main font"]
8676 mkfontdisp textfont $top [mc "Diff display font"]
8677 mkfontdisp uifont $top [mc "User interface font"]
8679 frame $top.buts
8680 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8681 $top.buts.ok configure -font uifont
8682 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8683 $top.buts.can configure -font uifont
8684 grid $top.buts.ok $top.buts.can
8685 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8686 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8687 grid $top.buts - - -pady 10 -sticky ew
8688 bind $top <Visibility> "focus $top.buts.ok"
8691 proc choosecolor {v vi w x cmd} {
8692 global $v
8694 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8695 -title [mc "Gitk: choose color for %s" $x]]
8696 if {$c eq {}} return
8697 $w conf -background $c
8698 lset $v $vi $c
8699 eval $cmd $c
8702 proc setselbg {c} {
8703 global bglist cflist
8704 foreach w $bglist {
8705 $w configure -selectbackground $c
8707 $cflist tag configure highlight \
8708 -background [$cflist cget -selectbackground]
8709 allcanvs itemconf secsel -fill $c
8712 proc setbg {c} {
8713 global bglist
8715 foreach w $bglist {
8716 $w conf -background $c
8720 proc setfg {c} {
8721 global fglist canv
8723 foreach w $fglist {
8724 $w conf -foreground $c
8726 allcanvs itemconf text -fill $c
8727 $canv itemconf circle -outline $c
8730 proc prefscan {} {
8731 global oldprefs prefstop
8733 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8734 limitdiffs tabstop} {
8735 global $v
8736 set $v $oldprefs($v)
8738 catch {destroy $prefstop}
8739 unset prefstop
8740 fontcan
8743 proc prefsok {} {
8744 global maxwidth maxgraphpct
8745 global oldprefs prefstop showneartags showlocalchanges
8746 global fontpref mainfont textfont uifont
8747 global limitdiffs treediffs
8749 catch {destroy $prefstop}
8750 unset prefstop
8751 fontcan
8752 set fontchanged 0
8753 if {$mainfont ne $fontpref(mainfont)} {
8754 set mainfont $fontpref(mainfont)
8755 parsefont mainfont $mainfont
8756 eval font configure mainfont [fontflags mainfont]
8757 eval font configure mainfontbold [fontflags mainfont 1]
8758 setcoords
8759 set fontchanged 1
8761 if {$textfont ne $fontpref(textfont)} {
8762 set textfont $fontpref(textfont)
8763 parsefont textfont $textfont
8764 eval font configure textfont [fontflags textfont]
8765 eval font configure textfontbold [fontflags textfont 1]
8767 if {$uifont ne $fontpref(uifont)} {
8768 set uifont $fontpref(uifont)
8769 parsefont uifont $uifont
8770 eval font configure uifont [fontflags uifont]
8772 settabs
8773 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8774 if {$showlocalchanges} {
8775 doshowlocalchanges
8776 } else {
8777 dohidelocalchanges
8780 if {$limitdiffs != $oldprefs(limitdiffs)} {
8781 # treediffs elements are limited by path
8782 catch {unset treediffs}
8784 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8785 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8786 redisplay
8787 } elseif {$showneartags != $oldprefs(showneartags) ||
8788 $limitdiffs != $oldprefs(limitdiffs)} {
8789 reselectline
8793 proc formatdate {d} {
8794 global datetimeformat
8795 if {$d ne {}} {
8796 set d [clock format $d -format $datetimeformat]
8798 return $d
8801 # This list of encoding names and aliases is distilled from
8802 # http://www.iana.org/assignments/character-sets.
8803 # Not all of them are supported by Tcl.
8804 set encoding_aliases {
8805 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8806 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8807 { ISO-10646-UTF-1 csISO10646UTF1 }
8808 { ISO_646.basic:1983 ref csISO646basic1983 }
8809 { INVARIANT csINVARIANT }
8810 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8811 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8812 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8813 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8814 { NATS-DANO iso-ir-9-1 csNATSDANO }
8815 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8816 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8817 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8818 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8819 { ISO-2022-KR csISO2022KR }
8820 { EUC-KR csEUCKR }
8821 { ISO-2022-JP csISO2022JP }
8822 { ISO-2022-JP-2 csISO2022JP2 }
8823 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8824 csISO13JISC6220jp }
8825 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8826 { IT iso-ir-15 ISO646-IT csISO15Italian }
8827 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8828 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8829 { greek7-old iso-ir-18 csISO18Greek7Old }
8830 { latin-greek iso-ir-19 csISO19LatinGreek }
8831 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8832 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8833 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8834 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8835 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8836 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8837 { INIS iso-ir-49 csISO49INIS }
8838 { INIS-8 iso-ir-50 csISO50INIS8 }
8839 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8840 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8841 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8842 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8843 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8844 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8845 csISO60Norwegian1 }
8846 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8847 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8848 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8849 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8850 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8851 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8852 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8853 { greek7 iso-ir-88 csISO88Greek7 }
8854 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8855 { iso-ir-90 csISO90 }
8856 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8857 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8858 csISO92JISC62991984b }
8859 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8860 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8861 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8862 csISO95JIS62291984handadd }
8863 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8864 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8865 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8866 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8867 CP819 csISOLatin1 }
8868 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8869 { T.61-7bit iso-ir-102 csISO102T617bit }
8870 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8871 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8872 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8873 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8874 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8875 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8876 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8877 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8878 arabic csISOLatinArabic }
8879 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8880 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8881 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8882 greek greek8 csISOLatinGreek }
8883 { T.101-G2 iso-ir-128 csISO128T101G2 }
8884 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8885 csISOLatinHebrew }
8886 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8887 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8888 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8889 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8890 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8891 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8892 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8893 csISOLatinCyrillic }
8894 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8895 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8896 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8897 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8898 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8899 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8900 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8901 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8902 { ISO_10367-box iso-ir-155 csISO10367Box }
8903 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8904 { latin-lap lap iso-ir-158 csISO158Lap }
8905 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8906 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8907 { us-dk csUSDK }
8908 { dk-us csDKUS }
8909 { JIS_X0201 X0201 csHalfWidthKatakana }
8910 { KSC5636 ISO646-KR csKSC5636 }
8911 { ISO-10646-UCS-2 csUnicode }
8912 { ISO-10646-UCS-4 csUCS4 }
8913 { DEC-MCS dec csDECMCS }
8914 { hp-roman8 roman8 r8 csHPRoman8 }
8915 { macintosh mac csMacintosh }
8916 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8917 csIBM037 }
8918 { IBM038 EBCDIC-INT cp038 csIBM038 }
8919 { IBM273 CP273 csIBM273 }
8920 { IBM274 EBCDIC-BE CP274 csIBM274 }
8921 { IBM275 EBCDIC-BR cp275 csIBM275 }
8922 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8923 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8924 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8925 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8926 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8927 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8928 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8929 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8930 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8931 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8932 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8933 { IBM437 cp437 437 csPC8CodePage437 }
8934 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8935 { IBM775 cp775 csPC775Baltic }
8936 { IBM850 cp850 850 csPC850Multilingual }
8937 { IBM851 cp851 851 csIBM851 }
8938 { IBM852 cp852 852 csPCp852 }
8939 { IBM855 cp855 855 csIBM855 }
8940 { IBM857 cp857 857 csIBM857 }
8941 { IBM860 cp860 860 csIBM860 }
8942 { IBM861 cp861 861 cp-is csIBM861 }
8943 { IBM862 cp862 862 csPC862LatinHebrew }
8944 { IBM863 cp863 863 csIBM863 }
8945 { IBM864 cp864 csIBM864 }
8946 { IBM865 cp865 865 csIBM865 }
8947 { IBM866 cp866 866 csIBM866 }
8948 { IBM868 CP868 cp-ar csIBM868 }
8949 { IBM869 cp869 869 cp-gr csIBM869 }
8950 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8951 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8952 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8953 { IBM891 cp891 csIBM891 }
8954 { IBM903 cp903 csIBM903 }
8955 { IBM904 cp904 904 csIBBM904 }
8956 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8957 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8958 { IBM1026 CP1026 csIBM1026 }
8959 { EBCDIC-AT-DE csIBMEBCDICATDE }
8960 { EBCDIC-AT-DE-A csEBCDICATDEA }
8961 { EBCDIC-CA-FR csEBCDICCAFR }
8962 { EBCDIC-DK-NO csEBCDICDKNO }
8963 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8964 { EBCDIC-FI-SE csEBCDICFISE }
8965 { EBCDIC-FI-SE-A csEBCDICFISEA }
8966 { EBCDIC-FR csEBCDICFR }
8967 { EBCDIC-IT csEBCDICIT }
8968 { EBCDIC-PT csEBCDICPT }
8969 { EBCDIC-ES csEBCDICES }
8970 { EBCDIC-ES-A csEBCDICESA }
8971 { EBCDIC-ES-S csEBCDICESS }
8972 { EBCDIC-UK csEBCDICUK }
8973 { EBCDIC-US csEBCDICUS }
8974 { UNKNOWN-8BIT csUnknown8BiT }
8975 { MNEMONIC csMnemonic }
8976 { MNEM csMnem }
8977 { VISCII csVISCII }
8978 { VIQR csVIQR }
8979 { KOI8-R csKOI8R }
8980 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8981 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8982 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8983 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8984 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8985 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8986 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8987 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8988 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8989 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8990 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8991 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8992 { IBM1047 IBM-1047 }
8993 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8994 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8995 { UNICODE-1-1 csUnicode11 }
8996 { CESU-8 csCESU-8 }
8997 { BOCU-1 csBOCU-1 }
8998 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8999 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9000 l8 }
9001 { ISO-8859-15 ISO_8859-15 Latin-9 }
9002 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9003 { GBK CP936 MS936 windows-936 }
9004 { JIS_Encoding csJISEncoding }
9005 { Shift_JIS MS_Kanji csShiftJIS }
9006 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9007 EUC-JP }
9008 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9009 { ISO-10646-UCS-Basic csUnicodeASCII }
9010 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9011 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9012 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9013 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9014 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9015 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9016 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9017 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9018 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9019 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9020 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9021 { Ventura-US csVenturaUS }
9022 { Ventura-International csVenturaInternational }
9023 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9024 { PC8-Turkish csPC8Turkish }
9025 { IBM-Symbols csIBMSymbols }
9026 { IBM-Thai csIBMThai }
9027 { HP-Legal csHPLegal }
9028 { HP-Pi-font csHPPiFont }
9029 { HP-Math8 csHPMath8 }
9030 { Adobe-Symbol-Encoding csHPPSMath }
9031 { HP-DeskTop csHPDesktop }
9032 { Ventura-Math csVenturaMath }
9033 { Microsoft-Publishing csMicrosoftPublishing }
9034 { Windows-31J csWindows31J }
9035 { GB2312 csGB2312 }
9036 { Big5 csBig5 }
9039 proc tcl_encoding {enc} {
9040 global encoding_aliases
9041 set names [encoding names]
9042 set lcnames [string tolower $names]
9043 set enc [string tolower $enc]
9044 set i [lsearch -exact $lcnames $enc]
9045 if {$i < 0} {
9046 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9047 if {[regsub {^iso[-_]} $enc iso encx]} {
9048 set i [lsearch -exact $lcnames $encx]
9051 if {$i < 0} {
9052 foreach l $encoding_aliases {
9053 set ll [string tolower $l]
9054 if {[lsearch -exact $ll $enc] < 0} continue
9055 # look through the aliases for one that tcl knows about
9056 foreach e $ll {
9057 set i [lsearch -exact $lcnames $e]
9058 if {$i < 0} {
9059 if {[regsub {^iso[-_]} $e iso ex]} {
9060 set i [lsearch -exact $lcnames $ex]
9063 if {$i >= 0} break
9065 break
9068 if {$i >= 0} {
9069 return [lindex $names $i]
9071 return {}
9074 # First check that Tcl/Tk is recent enough
9075 if {[catch {package require Tk 8.4} err]} {
9076 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9077 Gitk requires at least Tcl/Tk 8.4."]
9078 exit 1
9081 # defaults...
9082 set datemode 0
9083 set wrcomcmd "git diff-tree --stdin -p --pretty"
9085 set gitencoding {}
9086 catch {
9087 set gitencoding [exec git config --get i18n.commitencoding]
9089 if {$gitencoding == ""} {
9090 set gitencoding "utf-8"
9092 set tclencoding [tcl_encoding $gitencoding]
9093 if {$tclencoding == {}} {
9094 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9097 set mainfont {Helvetica 9}
9098 set textfont {Courier 9}
9099 set uifont {Helvetica 9 bold}
9100 set tabstop 8
9101 set findmergefiles 0
9102 set maxgraphpct 50
9103 set maxwidth 16
9104 set revlistorder 0
9105 set fastdate 0
9106 set uparrowlen 5
9107 set downarrowlen 5
9108 set mingaplen 100
9109 set cmitmode "patch"
9110 set wrapcomment "none"
9111 set showneartags 1
9112 set maxrefs 20
9113 set maxlinelen 200
9114 set showlocalchanges 1
9115 set limitdiffs 1
9116 set datetimeformat "%Y-%m-%d %H:%M:%S"
9118 set colors {green red blue magenta darkgrey brown orange}
9119 set bgcolor white
9120 set fgcolor black
9121 set diffcolors {red "#00a000" blue}
9122 set diffcontext 3
9123 set selectbgcolor gray85
9125 ## For msgcat loading, first locate the installation location.
9126 if { [info exists ::env(GITK_MSGSDIR)] } {
9127 ## Msgsdir was manually set in the environment.
9128 set gitk_msgsdir $::env(GITK_MSGSDIR)
9129 } else {
9130 ## Let's guess the prefix from argv0.
9131 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9132 set gitk_libdir [file join $gitk_prefix share gitk lib]
9133 set gitk_msgsdir [file join $gitk_libdir msgs]
9134 unset gitk_prefix
9137 ## Internationalization (i18n) through msgcat and gettext. See
9138 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9139 package require msgcat
9140 namespace import ::msgcat::mc
9141 ## And eventually load the actual message catalog
9142 ::msgcat::mcload $gitk_msgsdir
9144 catch {source ~/.gitk}
9146 font create optionfont -family sans-serif -size -12
9148 parsefont mainfont $mainfont
9149 eval font create mainfont [fontflags mainfont]
9150 eval font create mainfontbold [fontflags mainfont 1]
9152 parsefont textfont $textfont
9153 eval font create textfont [fontflags textfont]
9154 eval font create textfontbold [fontflags textfont 1]
9156 parsefont uifont $uifont
9157 eval font create uifont [fontflags uifont]
9159 # check that we can find a .git directory somewhere...
9160 if {[catch {set gitdir [gitdir]}]} {
9161 show_error {} . [mc "Cannot find a git repository here."]
9162 exit 1
9164 if {![file isdirectory $gitdir]} {
9165 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9166 exit 1
9169 set mergeonly 0
9170 set revtreeargs {}
9171 set cmdline_files {}
9172 set i 0
9173 foreach arg $argv {
9174 switch -- $arg {
9175 "" { }
9176 "-d" { set datemode 1 }
9177 "--merge" {
9178 set mergeonly 1
9179 lappend revtreeargs $arg
9181 "--" {
9182 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9183 break
9185 default {
9186 lappend revtreeargs $arg
9189 incr i
9192 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9193 # no -- on command line, but some arguments (other than -d)
9194 if {[catch {
9195 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9196 set cmdline_files [split $f "\n"]
9197 set n [llength $cmdline_files]
9198 set revtreeargs [lrange $revtreeargs 0 end-$n]
9199 # Unfortunately git rev-parse doesn't produce an error when
9200 # something is both a revision and a filename. To be consistent
9201 # with git log and git rev-list, check revtreeargs for filenames.
9202 foreach arg $revtreeargs {
9203 if {[file exists $arg]} {
9204 show_error {} . [mc "Ambiguous argument '%s': both revision\
9205 and filename" $arg]
9206 exit 1
9209 } err]} {
9210 # unfortunately we get both stdout and stderr in $err,
9211 # so look for "fatal:".
9212 set i [string first "fatal:" $err]
9213 if {$i > 0} {
9214 set err [string range $err [expr {$i + 6}] end]
9216 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9217 exit 1
9221 if {$mergeonly} {
9222 # find the list of unmerged files
9223 set mlist {}
9224 set nr_unmerged 0
9225 if {[catch {
9226 set fd [open "| git ls-files -u" r]
9227 } err]} {
9228 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9229 exit 1
9231 while {[gets $fd line] >= 0} {
9232 set i [string first "\t" $line]
9233 if {$i < 0} continue
9234 set fname [string range $line [expr {$i+1}] end]
9235 if {[lsearch -exact $mlist $fname] >= 0} continue
9236 incr nr_unmerged
9237 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9238 lappend mlist $fname
9241 catch {close $fd}
9242 if {$mlist eq {}} {
9243 if {$nr_unmerged == 0} {
9244 show_error {} . [mc "No files selected: --merge specified but\
9245 no files are unmerged."]
9246 } else {
9247 show_error {} . [mc "No files selected: --merge specified but\
9248 no unmerged files are within file limit."]
9250 exit 1
9252 set cmdline_files $mlist
9255 set nullid "0000000000000000000000000000000000000000"
9256 set nullid2 "0000000000000000000000000000000000000001"
9258 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9260 set runq {}
9261 set history {}
9262 set historyindex 0
9263 set fh_serial 0
9264 set nhl_names {}
9265 set highlight_paths {}
9266 set findpattern {}
9267 set searchdirn -forwards
9268 set boldrows {}
9269 set boldnamerows {}
9270 set diffelide {0 0}
9271 set markingmatches 0
9272 set linkentercount 0
9273 set need_redisplay 0
9274 set nrows_drawn 0
9275 set firsttabstop 0
9277 set nextviewnum 1
9278 set curview 0
9279 set selectedview 0
9280 set selectedhlview [mc "None"]
9281 set highlight_related [mc "None"]
9282 set highlight_files {}
9283 set viewfiles(0) {}
9284 set viewperm(0) 0
9285 set viewargs(0) {}
9287 set loginstance 0
9288 set cmdlineok 0
9289 set stopped 0
9290 set stuffsaved 0
9291 set patchnum 0
9292 set lserial 0
9293 setcoords
9294 makewindow
9295 # wait for the window to become visible
9296 tkwait visibility .
9297 wm title . "[file tail $argv0]: [file tail [pwd]]"
9298 readrefs
9300 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9301 # create a view for the files/dirs specified on the command line
9302 set curview 1
9303 set selectedview 1
9304 set nextviewnum 2
9305 set viewname(1) [mc "Command line"]
9306 set viewfiles(1) $cmdline_files
9307 set viewargs(1) $revtreeargs
9308 set viewperm(1) 0
9309 addviewmenu 1
9310 .bar.view entryconf [mc "Edit view..."] -state normal
9311 .bar.view entryconf [mc "Delete view"] -state normal
9314 if {[info exists permviews]} {
9315 foreach v $permviews {
9316 set n $nextviewnum
9317 incr nextviewnum
9318 set viewname($n) [lindex $v 0]
9319 set viewfiles($n) [lindex $v 1]
9320 set viewargs($n) [lindex $v 2]
9321 set viewperm($n) 1
9322 addviewmenu $n
9325 getcommits