gitk: Handle updating with path limiting better
[alt-git.git] / gitk
blob5925ced55b54886e512a65cab9f1399c36a9ff44
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
101 global pending_select mainheadid
103 set startmsecs [clock clicks -milliseconds]
104 set commitidx($view) 0
105 set viewcomplete($view) 0
106 set viewactive($view) 1
107 set vnextroot($view) 0
108 varcinit $view
110 set commits [eval exec git rev-parse --default HEAD --revs-only \
111 $viewargs($view)]
112 set viewincl($view) {}
113 foreach c $commits {
114 if {[regexp {^[0-9a-fA-F]{40}$} $c]} {
115 lappend viewincl($view) $c
118 if {[catch {
119 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
120 --boundary $commits "--" $viewfiles($view)] r]
121 } err]} {
122 error_popup "[mc "Error executing git log:"] $err"
123 exit 1
125 set i [incr loginstance]
126 set viewinstances($view) [list $i]
127 set commfd($i) $fd
128 set leftover($i) {}
129 if {$showlocalchanges} {
130 lappend commitinterest($mainheadid) {dodiffindex}
132 fconfigure $fd -blocking 0 -translation lf -eofchar {}
133 if {$tclencoding != {}} {
134 fconfigure $fd -encoding $tclencoding
136 filerun $fd [list getcommitlines $fd $i $view 0]
137 nowbusy $view [mc "Reading"]
138 if {$view == $curview} {
139 set progressdirn 1
140 set progresscoords {0 0}
141 set proglastnc 0
142 set pending_select $mainheadid
146 proc stop_rev_list {view} {
147 global commfd viewinstances leftover
149 foreach inst $viewinstances($view) {
150 set fd $commfd($inst)
151 catch {
152 set pid [pid $fd]
153 exec kill $pid
155 catch {close $fd}
156 nukefile $fd
157 unset commfd($inst)
158 unset leftover($inst)
160 set viewinstances($view) {}
163 proc getcommits {} {
164 global canv curview
166 initlayout
167 start_rev_list $curview
168 show_status [mc "Reading commits..."]
171 proc updatecommits {} {
172 global curview viewargs viewfiles viewincl viewinstances
173 global viewactive viewcomplete loginstance tclencoding mainheadid
174 global varcid startmsecs commfd showneartags showlocalchanges leftover
175 global mainheadid pending_select
177 set oldmainid $mainheadid
178 rereadrefs
179 if {$showlocalchanges} {
180 if {$mainheadid ne $oldmainid} {
181 dohidelocalchanges
183 if {[commitinview $mainheadid $curview]} {
184 dodiffindex
187 set view $curview
188 set commits [exec git rev-parse --default HEAD --revs-only \
189 $viewargs($view)]
190 set pos {}
191 set neg {}
192 set flags {}
193 foreach c $commits {
194 if {[string match "^*" $c]} {
195 lappend neg $c
196 } elseif {[regexp {^[0-9a-fA-F]{40}$} $c]} {
197 if {!([info exists varcid($view,$c)] ||
198 [lsearch -exact $viewincl($view) $c] >= 0)} {
199 lappend pos $c
201 } else {
202 lappend flags $c
205 if {$pos eq {}} {
206 return
208 foreach id $viewincl($view) {
209 lappend neg "^$id"
211 set viewincl($view) [concat $viewincl($view) $pos]
212 if {[catch {
213 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
214 --boundary $pos $neg $flags "--" $viewfiles($view)] r]
215 } err]} {
216 error_popup "Error executing git log: $err"
217 exit 1
219 if {$viewactive($view) == 0} {
220 set startmsecs [clock clicks -milliseconds]
222 set i [incr loginstance]
223 lappend viewinstances($view) $i
224 set commfd($i) $fd
225 set leftover($i) {}
226 fconfigure $fd -blocking 0 -translation lf -eofchar {}
227 if {$tclencoding != {}} {
228 fconfigure $fd -encoding $tclencoding
230 filerun $fd [list getcommitlines $fd $i $view 1]
231 incr viewactive($view)
232 set viewcomplete($view) 0
233 set pending_select $mainheadid
234 nowbusy $view "Reading"
235 if {$showneartags} {
236 getallcommits
240 proc reloadcommits {} {
241 global curview viewcomplete selectedline currentid thickerline
242 global showneartags treediffs commitinterest cached_commitrow
243 global progresscoords targetid
245 if {!$viewcomplete($curview)} {
246 stop_rev_list $curview
247 set progresscoords {0 0}
248 adjustprogress
250 resetvarcs $curview
251 catch {unset selectedline}
252 catch {unset currentid}
253 catch {unset thickerline}
254 catch {unset treediffs}
255 readrefs
256 changedrefs
257 if {$showneartags} {
258 getallcommits
260 clear_display
261 catch {unset commitinterest}
262 catch {unset cached_commitrow}
263 catch {unset targetid}
264 setcanvscroll
265 getcommits
266 return 0
269 # This makes a string representation of a positive integer which
270 # sorts as a string in numerical order
271 proc strrep {n} {
272 if {$n < 16} {
273 return [format "%x" $n]
274 } elseif {$n < 256} {
275 return [format "x%.2x" $n]
276 } elseif {$n < 65536} {
277 return [format "y%.4x" $n]
279 return [format "z%.8x" $n]
282 # Procedures used in reordering commits from git log (without
283 # --topo-order) into the order for display.
285 proc varcinit {view} {
286 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
287 global vtokmod varcmod vrowmod varcix vlastins
289 set varcstart($view) {{}}
290 set vupptr($view) {0}
291 set vdownptr($view) {0}
292 set vleftptr($view) {0}
293 set vbackptr($view) {0}
294 set varctok($view) {{}}
295 set varcrow($view) {{}}
296 set vtokmod($view) {}
297 set varcmod($view) 0
298 set vrowmod($view) 0
299 set varcix($view) {{}}
300 set vlastins($view) {0}
303 proc resetvarcs {view} {
304 global varcid varccommits parents children vseedcount ordertok
306 foreach vid [array names varcid $view,*] {
307 unset varcid($vid)
308 unset children($vid)
309 unset parents($vid)
311 # some commits might have children but haven't been seen yet
312 foreach vid [array names children $view,*] {
313 unset children($vid)
315 foreach va [array names varccommits $view,*] {
316 unset varccommits($va)
318 foreach vd [array names vseedcount $view,*] {
319 unset vseedcount($vd)
321 catch {unset ordertok}
324 proc newvarc {view id} {
325 global varcid varctok parents children datemode
326 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
327 global commitdata commitinfo vseedcount varccommits vlastins
329 set a [llength $varctok($view)]
330 set vid $view,$id
331 if {[llength $children($vid)] == 0 || $datemode} {
332 if {![info exists commitinfo($id)]} {
333 parsecommit $id $commitdata($id) 1
335 set cdate [lindex $commitinfo($id) 4]
336 if {![string is integer -strict $cdate]} {
337 set cdate 0
339 if {![info exists vseedcount($view,$cdate)]} {
340 set vseedcount($view,$cdate) -1
342 set c [incr vseedcount($view,$cdate)]
343 set cdate [expr {$cdate ^ 0xffffffff}]
344 set tok "s[strrep $cdate][strrep $c]"
345 } else {
346 set tok {}
348 set ka 0
349 if {[llength $children($vid)] > 0} {
350 set kid [lindex $children($vid) end]
351 set k $varcid($view,$kid)
352 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
353 set ki $kid
354 set ka $k
355 set tok [lindex $varctok($view) $k]
358 if {$ka != 0} {
359 set i [lsearch -exact $parents($view,$ki) $id]
360 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
361 append tok [strrep $j]
363 set c [lindex $vlastins($view) $ka]
364 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
365 set c $ka
366 set b [lindex $vdownptr($view) $ka]
367 } else {
368 set b [lindex $vleftptr($view) $c]
370 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
371 set c $b
372 set b [lindex $vleftptr($view) $c]
374 if {$c == $ka} {
375 lset vdownptr($view) $ka $a
376 lappend vbackptr($view) 0
377 } else {
378 lset vleftptr($view) $c $a
379 lappend vbackptr($view) $c
381 lset vlastins($view) $ka $a
382 lappend vupptr($view) $ka
383 lappend vleftptr($view) $b
384 if {$b != 0} {
385 lset vbackptr($view) $b $a
387 lappend varctok($view) $tok
388 lappend varcstart($view) $id
389 lappend vdownptr($view) 0
390 lappend varcrow($view) {}
391 lappend varcix($view) {}
392 set varccommits($view,$a) {}
393 lappend vlastins($view) 0
394 return $a
397 proc splitvarc {p v} {
398 global varcid varcstart varccommits varctok
399 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
401 set oa $varcid($v,$p)
402 set ac $varccommits($v,$oa)
403 set i [lsearch -exact $varccommits($v,$oa) $p]
404 if {$i <= 0} return
405 set na [llength $varctok($v)]
406 # "%" sorts before "0"...
407 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
408 lappend varctok($v) $tok
409 lappend varcrow($v) {}
410 lappend varcix($v) {}
411 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
412 set varccommits($v,$na) [lrange $ac $i end]
413 lappend varcstart($v) $p
414 foreach id $varccommits($v,$na) {
415 set varcid($v,$id) $na
417 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
418 lappend vlastins($v) [lindex $vlastins($v) $oa]
419 lset vdownptr($v) $oa $na
420 lset vlastins($v) $oa 0
421 lappend vupptr($v) $oa
422 lappend vleftptr($v) 0
423 lappend vbackptr($v) 0
424 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
425 lset vupptr($v) $b $na
429 proc renumbervarc {a v} {
430 global parents children varctok varcstart varccommits
431 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
433 set t1 [clock clicks -milliseconds]
434 set todo {}
435 set isrelated($a) 1
436 set kidchanged($a) 1
437 set ntot 0
438 while {$a != 0} {
439 if {[info exists isrelated($a)]} {
440 lappend todo $a
441 set id [lindex $varccommits($v,$a) end]
442 foreach p $parents($v,$id) {
443 if {[info exists varcid($v,$p)]} {
444 set isrelated($varcid($v,$p)) 1
448 incr ntot
449 set b [lindex $vdownptr($v) $a]
450 if {$b == 0} {
451 while {$a != 0} {
452 set b [lindex $vleftptr($v) $a]
453 if {$b != 0} break
454 set a [lindex $vupptr($v) $a]
457 set a $b
459 foreach a $todo {
460 if {![info exists kidchanged($a)]} continue
461 set id [lindex $varcstart($v) $a]
462 if {[llength $children($v,$id)] > 1} {
463 set children($v,$id) [lsort -command [list vtokcmp $v] \
464 $children($v,$id)]
466 set oldtok [lindex $varctok($v) $a]
467 if {!$datemode} {
468 set tok {}
469 } else {
470 set tok $oldtok
472 set ka 0
473 set kid [last_real_child $v,$id]
474 if {$kid ne {}} {
475 set k $varcid($v,$kid)
476 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
477 set ki $kid
478 set ka $k
479 set tok [lindex $varctok($v) $k]
482 if {$ka != 0} {
483 set i [lsearch -exact $parents($v,$ki) $id]
484 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
485 append tok [strrep $j]
487 if {$tok eq $oldtok} {
488 continue
490 set id [lindex $varccommits($v,$a) end]
491 foreach p $parents($v,$id) {
492 if {[info exists varcid($v,$p)]} {
493 set kidchanged($varcid($v,$p)) 1
494 } else {
495 set sortkids($p) 1
498 lset varctok($v) $a $tok
499 set b [lindex $vupptr($v) $a]
500 if {$b != $ka} {
501 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
502 modify_arc $v $ka
504 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
505 modify_arc $v $b
507 set c [lindex $vbackptr($v) $a]
508 set d [lindex $vleftptr($v) $a]
509 if {$c == 0} {
510 lset vdownptr($v) $b $d
511 } else {
512 lset vleftptr($v) $c $d
514 if {$d != 0} {
515 lset vbackptr($v) $d $c
517 if {[lindex $vlastins($v) $b] == $a} {
518 lset vlastins($v) $b $c
520 lset vupptr($v) $a $ka
521 set c [lindex $vlastins($v) $ka]
522 if {$c == 0 || \
523 [string compare $tok [lindex $varctok($v) $c]] < 0} {
524 set c $ka
525 set b [lindex $vdownptr($v) $ka]
526 } else {
527 set b [lindex $vleftptr($v) $c]
529 while {$b != 0 && \
530 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
531 set c $b
532 set b [lindex $vleftptr($v) $c]
534 if {$c == $ka} {
535 lset vdownptr($v) $ka $a
536 lset vbackptr($v) $a 0
537 } else {
538 lset vleftptr($v) $c $a
539 lset vbackptr($v) $a $c
541 lset vleftptr($v) $a $b
542 if {$b != 0} {
543 lset vbackptr($v) $b $a
545 lset vlastins($v) $ka $a
548 foreach id [array names sortkids] {
549 if {[llength $children($v,$id)] > 1} {
550 set children($v,$id) [lsort -command [list vtokcmp $v] \
551 $children($v,$id)]
554 set t2 [clock clicks -milliseconds]
555 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
558 # Fix up the graph after we have found out that in view $v,
559 # $p (a commit that we have already seen) is actually the parent
560 # of the last commit in arc $a.
561 proc fix_reversal {p a v} {
562 global varcid varcstart varctok vupptr
564 set pa $varcid($v,$p)
565 if {$p ne [lindex $varcstart($v) $pa]} {
566 splitvarc $p $v
567 set pa $varcid($v,$p)
569 # seeds always need to be renumbered
570 if {[lindex $vupptr($v) $pa] == 0 ||
571 [string compare [lindex $varctok($v) $a] \
572 [lindex $varctok($v) $pa]] > 0} {
573 renumbervarc $pa $v
577 proc insertrow {id p v} {
578 global cmitlisted children parents varcid varctok vtokmod
579 global varccommits ordertok commitidx numcommits curview
580 global targetid targetrow
582 readcommit $id
583 set vid $v,$id
584 set cmitlisted($vid) 1
585 set children($vid) {}
586 set parents($vid) [list $p]
587 set a [newvarc $v $id]
588 set varcid($vid) $a
589 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
590 modify_arc $v $a
592 lappend varccommits($v,$a) $id
593 set vp $v,$p
594 if {[llength [lappend children($vp) $id]] > 1} {
595 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
596 catch {unset ordertok}
598 fix_reversal $p $a $v
599 incr commitidx($v)
600 if {$v == $curview} {
601 set numcommits $commitidx($v)
602 setcanvscroll
603 if {[info exists targetid]} {
604 if {![comes_before $targetid $p]} {
605 incr targetrow
611 proc insertfakerow {id p} {
612 global varcid varccommits parents children cmitlisted
613 global commitidx varctok vtokmod targetid targetrow curview numcommits
615 set v $curview
616 set a $varcid($v,$p)
617 set i [lsearch -exact $varccommits($v,$a) $p]
618 if {$i < 0} {
619 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
620 return
622 set children($v,$id) {}
623 set parents($v,$id) [list $p]
624 set varcid($v,$id) $a
625 lappend children($v,$p) $id
626 set cmitlisted($v,$id) 1
627 set numcommits [incr commitidx($v)]
628 # note we deliberately don't update varcstart($v) even if $i == 0
629 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
630 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
631 modify_arc $v $a $i
633 if {[info exists targetid]} {
634 if {![comes_before $targetid $p]} {
635 incr targetrow
638 setcanvscroll
639 drawvisible
642 proc removefakerow {id} {
643 global varcid varccommits parents children commitidx
644 global varctok vtokmod cmitlisted currentid selectedline
645 global targetid curview numcommits
647 set v $curview
648 if {[llength $parents($v,$id)] != 1} {
649 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
650 return
652 set p [lindex $parents($v,$id) 0]
653 set a $varcid($v,$id)
654 set i [lsearch -exact $varccommits($v,$a) $id]
655 if {$i < 0} {
656 puts "oops: removefakerow can't find [shortids $id] on arc $a"
657 return
659 unset varcid($v,$id)
660 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
661 unset parents($v,$id)
662 unset children($v,$id)
663 unset cmitlisted($v,$id)
664 set numcommits [incr commitidx($v) -1]
665 set j [lsearch -exact $children($v,$p) $id]
666 if {$j >= 0} {
667 set children($v,$p) [lreplace $children($v,$p) $j $j]
669 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
670 modify_arc $v $a $i
672 if {[info exist currentid] && $id eq $currentid} {
673 unset currentid
674 unset selectedline
676 if {[info exists targetid] && $targetid eq $id} {
677 set targetid $p
679 setcanvscroll
680 drawvisible
683 proc first_real_child {vp} {
684 global children nullid nullid2
686 foreach id $children($vp) {
687 if {$id ne $nullid && $id ne $nullid2} {
688 return $id
691 return {}
694 proc last_real_child {vp} {
695 global children nullid nullid2
697 set kids $children($vp)
698 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
699 set id [lindex $kids $i]
700 if {$id ne $nullid && $id ne $nullid2} {
701 return $id
704 return {}
707 proc vtokcmp {v a b} {
708 global varctok varcid
710 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
711 [lindex $varctok($v) $varcid($v,$b)]]
714 proc modify_arc {v a {lim {}}} {
715 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
717 set vtokmod($v) [lindex $varctok($v) $a]
718 set varcmod($v) $a
719 if {$v == $curview} {
720 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
721 set a [lindex $vupptr($v) $a]
722 set lim {}
724 set r 0
725 if {$a != 0} {
726 if {$lim eq {}} {
727 set lim [llength $varccommits($v,$a)]
729 set r [expr {[lindex $varcrow($v) $a] + $lim}]
731 set vrowmod($v) $r
732 undolayout $r
736 proc update_arcrows {v} {
737 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
738 global varcid vrownum varcorder varcix varccommits
739 global vupptr vdownptr vleftptr varctok
740 global displayorder parentlist curview cached_commitrow
742 set narctot [expr {[llength $varctok($v)] - 1}]
743 set a $varcmod($v)
744 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
745 # go up the tree until we find something that has a row number,
746 # or we get to a seed
747 set a [lindex $vupptr($v) $a]
749 if {$a == 0} {
750 set a [lindex $vdownptr($v) 0]
751 if {$a == 0} return
752 set vrownum($v) {0}
753 set varcorder($v) [list $a]
754 lset varcix($v) $a 0
755 lset varcrow($v) $a 0
756 set arcn 0
757 set row 0
758 } else {
759 set arcn [lindex $varcix($v) $a]
760 # see if a is the last arc; if so, nothing to do
761 if {$arcn == $narctot - 1} {
762 return
764 if {[llength $vrownum($v)] > $arcn + 1} {
765 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
766 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
768 set row [lindex $varcrow($v) $a]
770 if {$v == $curview} {
771 if {[llength $displayorder] > $vrowmod($v)} {
772 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
773 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
775 catch {unset cached_commitrow}
777 while {1} {
778 set p $a
779 incr row [llength $varccommits($v,$a)]
780 # go down if possible
781 set b [lindex $vdownptr($v) $a]
782 if {$b == 0} {
783 # if not, go left, or go up until we can go left
784 while {$a != 0} {
785 set b [lindex $vleftptr($v) $a]
786 if {$b != 0} break
787 set a [lindex $vupptr($v) $a]
789 if {$a == 0} break
791 set a $b
792 incr arcn
793 lappend vrownum($v) $row
794 lappend varcorder($v) $a
795 lset varcix($v) $a $arcn
796 lset varcrow($v) $a $row
798 set vtokmod($v) [lindex $varctok($v) $p]
799 set varcmod($v) $p
800 set vrowmod($v) $row
801 if {[info exists currentid]} {
802 set selectedline [rowofcommit $currentid]
806 # Test whether view $v contains commit $id
807 proc commitinview {id v} {
808 global varcid
810 return [info exists varcid($v,$id)]
813 # Return the row number for commit $id in the current view
814 proc rowofcommit {id} {
815 global varcid varccommits varcrow curview cached_commitrow
816 global varctok vtokmod
818 set v $curview
819 if {![info exists varcid($v,$id)]} {
820 puts "oops rowofcommit no arc for [shortids $id]"
821 return {}
823 set a $varcid($v,$id)
824 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
825 update_arcrows $v
827 if {[info exists cached_commitrow($id)]} {
828 return $cached_commitrow($id)
830 set i [lsearch -exact $varccommits($v,$a) $id]
831 if {$i < 0} {
832 puts "oops didn't find commit [shortids $id] in arc $a"
833 return {}
835 incr i [lindex $varcrow($v) $a]
836 set cached_commitrow($id) $i
837 return $i
840 # Returns 1 if a is on an earlier row than b, otherwise 0
841 proc comes_before {a b} {
842 global varcid varctok curview
844 set v $curview
845 if {$a eq $b || ![info exists varcid($v,$a)] || \
846 ![info exists varcid($v,$b)]} {
847 return 0
849 if {$varcid($v,$a) != $varcid($v,$b)} {
850 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
851 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
853 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
856 proc bsearch {l elt} {
857 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
858 return 0
860 set lo 0
861 set hi [llength $l]
862 while {$hi - $lo > 1} {
863 set mid [expr {int(($lo + $hi) / 2)}]
864 set t [lindex $l $mid]
865 if {$elt < $t} {
866 set hi $mid
867 } elseif {$elt > $t} {
868 set lo $mid
869 } else {
870 return $mid
873 return $lo
876 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
877 proc make_disporder {start end} {
878 global vrownum curview commitidx displayorder parentlist
879 global varccommits varcorder parents vrowmod varcrow
880 global d_valid_start d_valid_end
882 if {$end > $vrowmod($curview)} {
883 update_arcrows $curview
885 set ai [bsearch $vrownum($curview) $start]
886 set start [lindex $vrownum($curview) $ai]
887 set narc [llength $vrownum($curview)]
888 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
889 set a [lindex $varcorder($curview) $ai]
890 set l [llength $displayorder]
891 set al [llength $varccommits($curview,$a)]
892 if {$l < $r + $al} {
893 if {$l < $r} {
894 set pad [ntimes [expr {$r - $l}] {}]
895 set displayorder [concat $displayorder $pad]
896 set parentlist [concat $parentlist $pad]
897 } elseif {$l > $r} {
898 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
899 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
901 foreach id $varccommits($curview,$a) {
902 lappend displayorder $id
903 lappend parentlist $parents($curview,$id)
905 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
906 set i $r
907 foreach id $varccommits($curview,$a) {
908 lset displayorder $i $id
909 lset parentlist $i $parents($curview,$id)
910 incr i
913 incr r $al
917 proc commitonrow {row} {
918 global displayorder
920 set id [lindex $displayorder $row]
921 if {$id eq {}} {
922 make_disporder $row [expr {$row + 1}]
923 set id [lindex $displayorder $row]
925 return $id
928 proc closevarcs {v} {
929 global varctok varccommits varcid parents children
930 global cmitlisted commitidx commitinterest vtokmod
932 set missing_parents 0
933 set scripts {}
934 set narcs [llength $varctok($v)]
935 for {set a 1} {$a < $narcs} {incr a} {
936 set id [lindex $varccommits($v,$a) end]
937 foreach p $parents($v,$id) {
938 if {[info exists varcid($v,$p)]} continue
939 # add p as a new commit
940 incr missing_parents
941 set cmitlisted($v,$p) 0
942 set parents($v,$p) {}
943 if {[llength $children($v,$p)] == 1 &&
944 [llength $parents($v,$id)] == 1} {
945 set b $a
946 } else {
947 set b [newvarc $v $p]
949 set varcid($v,$p) $b
950 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
951 modify_arc $v $b
953 lappend varccommits($v,$b) $p
954 incr commitidx($v)
955 if {[info exists commitinterest($p)]} {
956 foreach script $commitinterest($p) {
957 lappend scripts [string map [list "%I" $p] $script]
959 unset commitinterest($id)
963 if {$missing_parents > 0} {
964 foreach s $scripts {
965 eval $s
970 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
971 # Assumes we already have an arc for $rwid.
972 proc rewrite_commit {v id rwid} {
973 global children parents varcid varctok vtokmod varccommits
975 foreach ch $children($v,$id) {
976 # make $rwid be $ch's parent in place of $id
977 set i [lsearch -exact $parents($v,$ch) $id]
978 if {$i < 0} {
979 puts "oops rewrite_commit didn't find $id in parent list for $ch"
981 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
982 # add $ch to $rwid's children and sort the list if necessary
983 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
984 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
985 $children($v,$rwid)]
987 # fix the graph after joining $id to $rwid
988 set a $varcid($v,$ch)
989 fix_reversal $rwid $a $v
990 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
991 # parentlist is wrong for the last element of arc $a
992 # even if displayorder is right, hence the 3rd arg here
993 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
998 proc getcommitlines {fd inst view updating} {
999 global cmitlisted commitinterest leftover
1000 global commitidx commitdata datemode
1001 global parents children curview hlview
1002 global vnextroot idpending ordertok
1003 global varccommits varcid varctok vtokmod viewfiles
1005 set stuff [read $fd 500000]
1006 # git log doesn't terminate the last commit with a null...
1007 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1008 set stuff "\0"
1010 if {$stuff == {}} {
1011 if {![eof $fd]} {
1012 return 1
1014 global commfd viewcomplete viewactive viewname progresscoords
1015 global viewinstances
1016 unset commfd($inst)
1017 set i [lsearch -exact $viewinstances($view) $inst]
1018 if {$i >= 0} {
1019 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1021 # set it blocking so we wait for the process to terminate
1022 fconfigure $fd -blocking 1
1023 if {[catch {close $fd} err]} {
1024 set fv {}
1025 if {$view != $curview} {
1026 set fv " for the \"$viewname($view)\" view"
1028 if {[string range $err 0 4] == "usage"} {
1029 set err "Gitk: error reading commits$fv:\
1030 bad arguments to git rev-list."
1031 if {$viewname($view) eq "Command line"} {
1032 append err \
1033 " (Note: arguments to gitk are passed to git rev-list\
1034 to allow selection of commits to be displayed.)"
1036 } else {
1037 set err "Error reading commits$fv: $err"
1039 error_popup $err
1041 if {[incr viewactive($view) -1] <= 0} {
1042 set viewcomplete($view) 1
1043 # Check if we have seen any ids listed as parents that haven't
1044 # appeared in the list
1045 closevarcs $view
1046 notbusy $view
1047 set progresscoords {0 0}
1048 adjustprogress
1050 if {$view == $curview} {
1051 run chewcommits $view
1053 return 0
1055 set start 0
1056 set gotsome 0
1057 set scripts {}
1058 while 1 {
1059 set i [string first "\0" $stuff $start]
1060 if {$i < 0} {
1061 append leftover($inst) [string range $stuff $start end]
1062 break
1064 if {$start == 0} {
1065 set cmit $leftover($inst)
1066 append cmit [string range $stuff 0 [expr {$i - 1}]]
1067 set leftover($inst) {}
1068 } else {
1069 set cmit [string range $stuff $start [expr {$i - 1}]]
1071 set start [expr {$i + 1}]
1072 set j [string first "\n" $cmit]
1073 set ok 0
1074 set listed 1
1075 if {$j >= 0 && [string match "commit *" $cmit]} {
1076 set ids [string range $cmit 7 [expr {$j - 1}]]
1077 if {[string match {[-^<>]*} $ids]} {
1078 switch -- [string index $ids 0] {
1079 "-" {set listed 0}
1080 "^" {set listed 2}
1081 "<" {set listed 3}
1082 ">" {set listed 4}
1084 set ids [string range $ids 1 end]
1086 set ok 1
1087 foreach id $ids {
1088 if {[string length $id] != 40} {
1089 set ok 0
1090 break
1094 if {!$ok} {
1095 set shortcmit $cmit
1096 if {[string length $shortcmit] > 80} {
1097 set shortcmit "[string range $shortcmit 0 80]..."
1099 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1100 exit 1
1102 set id [lindex $ids 0]
1103 set vid $view,$id
1105 if {!$listed && $updating && ![info exists varcid($vid)] &&
1106 $viewfiles($view) ne {}} {
1107 # git log doesn't rewrite parents for unlisted commits
1108 # when doing path limiting, so work around that here
1109 # by working out the rewritten parent with git rev-list
1110 # and if we already know about it, using the rewritten
1111 # parent as a substitute parent for $id's children.
1112 if {![catch {
1113 set rwid [exec git rev-list --first-parent --max-count=1 \
1114 $id -- $viewfiles($view)]
1115 }]} {
1116 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1117 # use $rwid in place of $id
1118 rewrite_commit $view $id $rwid
1119 continue
1124 set a 0
1125 if {[info exists varcid($vid)]} {
1126 if {$cmitlisted($vid) || !$listed} continue
1127 set a $varcid($vid)
1129 if {$listed} {
1130 set olds [lrange $ids 1 end]
1131 } else {
1132 set olds {}
1134 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1135 set cmitlisted($vid) $listed
1136 set parents($vid) $olds
1137 if {![info exists children($vid)]} {
1138 set children($vid) {}
1139 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1140 set k [lindex $children($vid) 0]
1141 if {[llength $parents($view,$k)] == 1 &&
1142 (!$datemode ||
1143 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1144 set a $varcid($view,$k)
1147 if {$a == 0} {
1148 # new arc
1149 set a [newvarc $view $id]
1151 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1152 modify_arc $view $a
1154 if {![info exists varcid($vid)]} {
1155 set varcid($vid) $a
1156 lappend varccommits($view,$a) $id
1157 incr commitidx($view)
1160 set i 0
1161 foreach p $olds {
1162 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1163 set vp $view,$p
1164 if {[llength [lappend children($vp) $id]] > 1 &&
1165 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1166 set children($vp) [lsort -command [list vtokcmp $view] \
1167 $children($vp)]
1168 catch {unset ordertok}
1170 if {[info exists varcid($view,$p)]} {
1171 fix_reversal $p $a $view
1174 incr i
1177 if {[info exists commitinterest($id)]} {
1178 foreach script $commitinterest($id) {
1179 lappend scripts [string map [list "%I" $id] $script]
1181 unset commitinterest($id)
1183 set gotsome 1
1185 if {$gotsome} {
1186 run chewcommits $view
1187 foreach s $scripts {
1188 eval $s
1190 if {$view == $curview} {
1191 # update progress bar
1192 global progressdirn progresscoords proglastnc
1193 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1194 set proglastnc $commitidx($view)
1195 set l [lindex $progresscoords 0]
1196 set r [lindex $progresscoords 1]
1197 if {$progressdirn} {
1198 set r [expr {$r + $inc}]
1199 if {$r >= 1.0} {
1200 set r 1.0
1201 set progressdirn 0
1203 if {$r > 0.2} {
1204 set l [expr {$r - 0.2}]
1206 } else {
1207 set l [expr {$l - $inc}]
1208 if {$l <= 0.0} {
1209 set l 0.0
1210 set progressdirn 1
1212 set r [expr {$l + 0.2}]
1214 set progresscoords [list $l $r]
1215 adjustprogress
1218 return 2
1221 proc chewcommits {view} {
1222 global curview hlview viewcomplete
1223 global pending_select
1225 if {$view == $curview} {
1226 layoutmore
1227 if {$viewcomplete($view)} {
1228 global commitidx varctok
1229 global numcommits startmsecs
1230 global mainheadid commitinfo nullid
1232 if {[info exists pending_select]} {
1233 set row [first_real_row]
1234 selectline $row 1
1236 if {$commitidx($curview) > 0} {
1237 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1238 #puts "overall $ms ms for $numcommits commits"
1239 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1240 } else {
1241 show_status [mc "No commits selected"]
1243 notbusy layout
1246 if {[info exists hlview] && $view == $hlview} {
1247 vhighlightmore
1249 return 0
1252 proc readcommit {id} {
1253 if {[catch {set contents [exec git cat-file commit $id]}]} return
1254 parsecommit $id $contents 0
1257 proc parsecommit {id contents listed} {
1258 global commitinfo cdate
1260 set inhdr 1
1261 set comment {}
1262 set headline {}
1263 set auname {}
1264 set audate {}
1265 set comname {}
1266 set comdate {}
1267 set hdrend [string first "\n\n" $contents]
1268 if {$hdrend < 0} {
1269 # should never happen...
1270 set hdrend [string length $contents]
1272 set header [string range $contents 0 [expr {$hdrend - 1}]]
1273 set comment [string range $contents [expr {$hdrend + 2}] end]
1274 foreach line [split $header "\n"] {
1275 set tag [lindex $line 0]
1276 if {$tag == "author"} {
1277 set audate [lindex $line end-1]
1278 set auname [lrange $line 1 end-2]
1279 } elseif {$tag == "committer"} {
1280 set comdate [lindex $line end-1]
1281 set comname [lrange $line 1 end-2]
1284 set headline {}
1285 # take the first non-blank line of the comment as the headline
1286 set headline [string trimleft $comment]
1287 set i [string first "\n" $headline]
1288 if {$i >= 0} {
1289 set headline [string range $headline 0 $i]
1291 set headline [string trimright $headline]
1292 set i [string first "\r" $headline]
1293 if {$i >= 0} {
1294 set headline [string trimright [string range $headline 0 $i]]
1296 if {!$listed} {
1297 # git rev-list indents the comment by 4 spaces;
1298 # if we got this via git cat-file, add the indentation
1299 set newcomment {}
1300 foreach line [split $comment "\n"] {
1301 append newcomment " "
1302 append newcomment $line
1303 append newcomment "\n"
1305 set comment $newcomment
1307 if {$comdate != {}} {
1308 set cdate($id) $comdate
1310 set commitinfo($id) [list $headline $auname $audate \
1311 $comname $comdate $comment]
1314 proc getcommit {id} {
1315 global commitdata commitinfo
1317 if {[info exists commitdata($id)]} {
1318 parsecommit $id $commitdata($id) 1
1319 } else {
1320 readcommit $id
1321 if {![info exists commitinfo($id)]} {
1322 set commitinfo($id) [list [mc "No commit information available"]]
1325 return 1
1328 proc readrefs {} {
1329 global tagids idtags headids idheads tagobjid
1330 global otherrefids idotherrefs mainhead mainheadid
1332 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1333 catch {unset $v}
1335 set refd [open [list | git show-ref -d] r]
1336 while {[gets $refd line] >= 0} {
1337 if {[string index $line 40] ne " "} continue
1338 set id [string range $line 0 39]
1339 set ref [string range $line 41 end]
1340 if {![string match "refs/*" $ref]} continue
1341 set name [string range $ref 5 end]
1342 if {[string match "remotes/*" $name]} {
1343 if {![string match "*/HEAD" $name]} {
1344 set headids($name) $id
1345 lappend idheads($id) $name
1347 } elseif {[string match "heads/*" $name]} {
1348 set name [string range $name 6 end]
1349 set headids($name) $id
1350 lappend idheads($id) $name
1351 } elseif {[string match "tags/*" $name]} {
1352 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1353 # which is what we want since the former is the commit ID
1354 set name [string range $name 5 end]
1355 if {[string match "*^{}" $name]} {
1356 set name [string range $name 0 end-3]
1357 } else {
1358 set tagobjid($name) $id
1360 set tagids($name) $id
1361 lappend idtags($id) $name
1362 } else {
1363 set otherrefids($name) $id
1364 lappend idotherrefs($id) $name
1367 catch {close $refd}
1368 set mainhead {}
1369 set mainheadid {}
1370 catch {
1371 set thehead [exec git symbolic-ref HEAD]
1372 if {[string match "refs/heads/*" $thehead]} {
1373 set mainhead [string range $thehead 11 end]
1374 if {[info exists headids($mainhead)]} {
1375 set mainheadid $headids($mainhead)
1381 # skip over fake commits
1382 proc first_real_row {} {
1383 global nullid nullid2 numcommits
1385 for {set row 0} {$row < $numcommits} {incr row} {
1386 set id [commitonrow $row]
1387 if {$id ne $nullid && $id ne $nullid2} {
1388 break
1391 return $row
1394 # update things for a head moved to a child of its previous location
1395 proc movehead {id name} {
1396 global headids idheads
1398 removehead $headids($name) $name
1399 set headids($name) $id
1400 lappend idheads($id) $name
1403 # update things when a head has been removed
1404 proc removehead {id name} {
1405 global headids idheads
1407 if {$idheads($id) eq $name} {
1408 unset idheads($id)
1409 } else {
1410 set i [lsearch -exact $idheads($id) $name]
1411 if {$i >= 0} {
1412 set idheads($id) [lreplace $idheads($id) $i $i]
1415 unset headids($name)
1418 proc show_error {w top msg} {
1419 message $w.m -text $msg -justify center -aspect 400
1420 pack $w.m -side top -fill x -padx 20 -pady 20
1421 button $w.ok -text [mc OK] -command "destroy $top"
1422 pack $w.ok -side bottom -fill x
1423 bind $top <Visibility> "grab $top; focus $top"
1424 bind $top <Key-Return> "destroy $top"
1425 tkwait window $top
1428 proc error_popup msg {
1429 set w .error
1430 toplevel $w
1431 wm transient $w .
1432 show_error $w $w $msg
1435 proc confirm_popup msg {
1436 global confirm_ok
1437 set confirm_ok 0
1438 set w .confirm
1439 toplevel $w
1440 wm transient $w .
1441 message $w.m -text $msg -justify center -aspect 400
1442 pack $w.m -side top -fill x -padx 20 -pady 20
1443 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1444 pack $w.ok -side left -fill x
1445 button $w.cancel -text [mc Cancel] -command "destroy $w"
1446 pack $w.cancel -side right -fill x
1447 bind $w <Visibility> "grab $w; focus $w"
1448 tkwait window $w
1449 return $confirm_ok
1452 proc setoptions {} {
1453 option add *Panedwindow.showHandle 1 startupFile
1454 option add *Panedwindow.sashRelief raised startupFile
1455 option add *Button.font uifont startupFile
1456 option add *Checkbutton.font uifont startupFile
1457 option add *Radiobutton.font uifont startupFile
1458 option add *Menu.font uifont startupFile
1459 option add *Menubutton.font uifont startupFile
1460 option add *Label.font uifont startupFile
1461 option add *Message.font uifont startupFile
1462 option add *Entry.font uifont startupFile
1465 proc makewindow {} {
1466 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1467 global tabstop
1468 global findtype findtypemenu findloc findstring fstring geometry
1469 global entries sha1entry sha1string sha1but
1470 global diffcontextstring diffcontext
1471 global ignorespace
1472 global maincursor textcursor curtextcursor
1473 global rowctxmenu fakerowmenu mergemax wrapcomment
1474 global highlight_files gdttype
1475 global searchstring sstring
1476 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1477 global headctxmenu progresscanv progressitem progresscoords statusw
1478 global fprogitem fprogcoord lastprogupdate progupdatepending
1479 global rprogitem rprogcoord
1480 global have_tk85
1482 menu .bar
1483 .bar add cascade -label [mc "File"] -menu .bar.file
1484 menu .bar.file
1485 .bar.file add command -label [mc "Update"] -command updatecommits
1486 .bar.file add command -label [mc "Reload"] -command reloadcommits
1487 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1488 .bar.file add command -label [mc "List references"] -command showrefs
1489 .bar.file add command -label [mc "Quit"] -command doquit
1490 menu .bar.edit
1491 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1492 .bar.edit add command -label [mc "Preferences"] -command doprefs
1494 menu .bar.view
1495 .bar add cascade -label [mc "View"] -menu .bar.view
1496 .bar.view add command -label [mc "New view..."] -command {newview 0}
1497 .bar.view add command -label [mc "Edit view..."] -command editview \
1498 -state disabled
1499 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1500 .bar.view add separator
1501 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1502 -variable selectedview -value 0
1504 menu .bar.help
1505 .bar add cascade -label [mc "Help"] -menu .bar.help
1506 .bar.help add command -label [mc "About gitk"] -command about
1507 .bar.help add command -label [mc "Key bindings"] -command keys
1508 .bar.help configure
1509 . configure -menu .bar
1511 # the gui has upper and lower half, parts of a paned window.
1512 panedwindow .ctop -orient vertical
1514 # possibly use assumed geometry
1515 if {![info exists geometry(pwsash0)]} {
1516 set geometry(topheight) [expr {15 * $linespc}]
1517 set geometry(topwidth) [expr {80 * $charspc}]
1518 set geometry(botheight) [expr {15 * $linespc}]
1519 set geometry(botwidth) [expr {50 * $charspc}]
1520 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1521 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1524 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1525 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1526 frame .tf.histframe
1527 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1529 # create three canvases
1530 set cscroll .tf.histframe.csb
1531 set canv .tf.histframe.pwclist.canv
1532 canvas $canv \
1533 -selectbackground $selectbgcolor \
1534 -background $bgcolor -bd 0 \
1535 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1536 .tf.histframe.pwclist add $canv
1537 set canv2 .tf.histframe.pwclist.canv2
1538 canvas $canv2 \
1539 -selectbackground $selectbgcolor \
1540 -background $bgcolor -bd 0 -yscrollincr $linespc
1541 .tf.histframe.pwclist add $canv2
1542 set canv3 .tf.histframe.pwclist.canv3
1543 canvas $canv3 \
1544 -selectbackground $selectbgcolor \
1545 -background $bgcolor -bd 0 -yscrollincr $linespc
1546 .tf.histframe.pwclist add $canv3
1547 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1548 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1550 # a scroll bar to rule them
1551 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1552 pack $cscroll -side right -fill y
1553 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1554 lappend bglist $canv $canv2 $canv3
1555 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1557 # we have two button bars at bottom of top frame. Bar 1
1558 frame .tf.bar
1559 frame .tf.lbar -height 15
1561 set sha1entry .tf.bar.sha1
1562 set entries $sha1entry
1563 set sha1but .tf.bar.sha1label
1564 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1565 -command gotocommit -width 8
1566 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1567 pack .tf.bar.sha1label -side left
1568 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1569 trace add variable sha1string write sha1change
1570 pack $sha1entry -side left -pady 2
1572 image create bitmap bm-left -data {
1573 #define left_width 16
1574 #define left_height 16
1575 static unsigned char left_bits[] = {
1576 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1577 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1578 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1580 image create bitmap bm-right -data {
1581 #define right_width 16
1582 #define right_height 16
1583 static unsigned char right_bits[] = {
1584 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1585 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1586 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1588 button .tf.bar.leftbut -image bm-left -command goback \
1589 -state disabled -width 26
1590 pack .tf.bar.leftbut -side left -fill y
1591 button .tf.bar.rightbut -image bm-right -command goforw \
1592 -state disabled -width 26
1593 pack .tf.bar.rightbut -side left -fill y
1595 # Status label and progress bar
1596 set statusw .tf.bar.status
1597 label $statusw -width 15 -relief sunken
1598 pack $statusw -side left -padx 5
1599 set h [expr {[font metrics uifont -linespace] + 2}]
1600 set progresscanv .tf.bar.progress
1601 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1602 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1603 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1604 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1605 pack $progresscanv -side right -expand 1 -fill x
1606 set progresscoords {0 0}
1607 set fprogcoord 0
1608 set rprogcoord 0
1609 bind $progresscanv <Configure> adjustprogress
1610 set lastprogupdate [clock clicks -milliseconds]
1611 set progupdatepending 0
1613 # build up the bottom bar of upper window
1614 label .tf.lbar.flabel -text "[mc "Find"] "
1615 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1616 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1617 label .tf.lbar.flab2 -text " [mc "commit"] "
1618 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1619 -side left -fill y
1620 set gdttype [mc "containing:"]
1621 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1622 [mc "containing:"] \
1623 [mc "touching paths:"] \
1624 [mc "adding/removing string:"]]
1625 trace add variable gdttype write gdttype_change
1626 pack .tf.lbar.gdttype -side left -fill y
1628 set findstring {}
1629 set fstring .tf.lbar.findstring
1630 lappend entries $fstring
1631 entry $fstring -width 30 -font textfont -textvariable findstring
1632 trace add variable findstring write find_change
1633 set findtype [mc "Exact"]
1634 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1635 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1636 trace add variable findtype write findcom_change
1637 set findloc [mc "All fields"]
1638 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1639 [mc "Comments"] [mc "Author"] [mc "Committer"]
1640 trace add variable findloc write find_change
1641 pack .tf.lbar.findloc -side right
1642 pack .tf.lbar.findtype -side right
1643 pack $fstring -side left -expand 1 -fill x
1645 # Finish putting the upper half of the viewer together
1646 pack .tf.lbar -in .tf -side bottom -fill x
1647 pack .tf.bar -in .tf -side bottom -fill x
1648 pack .tf.histframe -fill both -side top -expand 1
1649 .ctop add .tf
1650 .ctop paneconfigure .tf -height $geometry(topheight)
1651 .ctop paneconfigure .tf -width $geometry(topwidth)
1653 # now build up the bottom
1654 panedwindow .pwbottom -orient horizontal
1656 # lower left, a text box over search bar, scroll bar to the right
1657 # if we know window height, then that will set the lower text height, otherwise
1658 # we set lower text height which will drive window height
1659 if {[info exists geometry(main)]} {
1660 frame .bleft -width $geometry(botwidth)
1661 } else {
1662 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1664 frame .bleft.top
1665 frame .bleft.mid
1667 button .bleft.top.search -text [mc "Search"] -command dosearch
1668 pack .bleft.top.search -side left -padx 5
1669 set sstring .bleft.top.sstring
1670 entry $sstring -width 20 -font textfont -textvariable searchstring
1671 lappend entries $sstring
1672 trace add variable searchstring write incrsearch
1673 pack $sstring -side left -expand 1 -fill x
1674 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1675 -command changediffdisp -variable diffelide -value {0 0}
1676 radiobutton .bleft.mid.old -text [mc "Old version"] \
1677 -command changediffdisp -variable diffelide -value {0 1}
1678 radiobutton .bleft.mid.new -text [mc "New version"] \
1679 -command changediffdisp -variable diffelide -value {1 0}
1680 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1681 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1682 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1683 -from 1 -increment 1 -to 10000000 \
1684 -validate all -validatecommand "diffcontextvalidate %P" \
1685 -textvariable diffcontextstring
1686 .bleft.mid.diffcontext set $diffcontext
1687 trace add variable diffcontextstring write diffcontextchange
1688 lappend entries .bleft.mid.diffcontext
1689 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1690 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1691 -command changeignorespace -variable ignorespace
1692 pack .bleft.mid.ignspace -side left -padx 5
1693 set ctext .bleft.ctext
1694 text $ctext -background $bgcolor -foreground $fgcolor \
1695 -state disabled -font textfont \
1696 -yscrollcommand scrolltext -wrap none
1697 if {$have_tk85} {
1698 $ctext conf -tabstyle wordprocessor
1700 scrollbar .bleft.sb -command "$ctext yview"
1701 pack .bleft.top -side top -fill x
1702 pack .bleft.mid -side top -fill x
1703 pack .bleft.sb -side right -fill y
1704 pack $ctext -side left -fill both -expand 1
1705 lappend bglist $ctext
1706 lappend fglist $ctext
1708 $ctext tag conf comment -wrap $wrapcomment
1709 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1710 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1711 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1712 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1713 $ctext tag conf m0 -fore red
1714 $ctext tag conf m1 -fore blue
1715 $ctext tag conf m2 -fore green
1716 $ctext tag conf m3 -fore purple
1717 $ctext tag conf m4 -fore brown
1718 $ctext tag conf m5 -fore "#009090"
1719 $ctext tag conf m6 -fore magenta
1720 $ctext tag conf m7 -fore "#808000"
1721 $ctext tag conf m8 -fore "#009000"
1722 $ctext tag conf m9 -fore "#ff0080"
1723 $ctext tag conf m10 -fore cyan
1724 $ctext tag conf m11 -fore "#b07070"
1725 $ctext tag conf m12 -fore "#70b0f0"
1726 $ctext tag conf m13 -fore "#70f0b0"
1727 $ctext tag conf m14 -fore "#f0b070"
1728 $ctext tag conf m15 -fore "#ff70b0"
1729 $ctext tag conf mmax -fore darkgrey
1730 set mergemax 16
1731 $ctext tag conf mresult -font textfontbold
1732 $ctext tag conf msep -font textfontbold
1733 $ctext tag conf found -back yellow
1735 .pwbottom add .bleft
1736 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1738 # lower right
1739 frame .bright
1740 frame .bright.mode
1741 radiobutton .bright.mode.patch -text [mc "Patch"] \
1742 -command reselectline -variable cmitmode -value "patch"
1743 radiobutton .bright.mode.tree -text [mc "Tree"] \
1744 -command reselectline -variable cmitmode -value "tree"
1745 grid .bright.mode.patch .bright.mode.tree -sticky ew
1746 pack .bright.mode -side top -fill x
1747 set cflist .bright.cfiles
1748 set indent [font measure mainfont "nn"]
1749 text $cflist \
1750 -selectbackground $selectbgcolor \
1751 -background $bgcolor -foreground $fgcolor \
1752 -font mainfont \
1753 -tabs [list $indent [expr {2 * $indent}]] \
1754 -yscrollcommand ".bright.sb set" \
1755 -cursor [. cget -cursor] \
1756 -spacing1 1 -spacing3 1
1757 lappend bglist $cflist
1758 lappend fglist $cflist
1759 scrollbar .bright.sb -command "$cflist yview"
1760 pack .bright.sb -side right -fill y
1761 pack $cflist -side left -fill both -expand 1
1762 $cflist tag configure highlight \
1763 -background [$cflist cget -selectbackground]
1764 $cflist tag configure bold -font mainfontbold
1766 .pwbottom add .bright
1767 .ctop add .pwbottom
1769 # restore window position if known
1770 if {[info exists geometry(main)]} {
1771 wm geometry . "$geometry(main)"
1774 if {[tk windowingsystem] eq {aqua}} {
1775 set M1B M1
1776 } else {
1777 set M1B Control
1780 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1781 pack .ctop -fill both -expand 1
1782 bindall <1> {selcanvline %W %x %y}
1783 #bindall <B1-Motion> {selcanvline %W %x %y}
1784 if {[tk windowingsystem] == "win32"} {
1785 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1786 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1787 } else {
1788 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1789 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1790 if {[tk windowingsystem] eq "aqua"} {
1791 bindall <MouseWheel> {
1792 set delta [expr {- (%D)}]
1793 allcanvs yview scroll $delta units
1797 bindall <2> "canvscan mark %W %x %y"
1798 bindall <B2-Motion> "canvscan dragto %W %x %y"
1799 bindkey <Home> selfirstline
1800 bindkey <End> sellastline
1801 bind . <Key-Up> "selnextline -1"
1802 bind . <Key-Down> "selnextline 1"
1803 bind . <Shift-Key-Up> "dofind -1 0"
1804 bind . <Shift-Key-Down> "dofind 1 0"
1805 bindkey <Key-Right> "goforw"
1806 bindkey <Key-Left> "goback"
1807 bind . <Key-Prior> "selnextpage -1"
1808 bind . <Key-Next> "selnextpage 1"
1809 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1810 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1811 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1812 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1813 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1814 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1815 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1816 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1817 bindkey <Key-space> "$ctext yview scroll 1 pages"
1818 bindkey p "selnextline -1"
1819 bindkey n "selnextline 1"
1820 bindkey z "goback"
1821 bindkey x "goforw"
1822 bindkey i "selnextline -1"
1823 bindkey k "selnextline 1"
1824 bindkey j "goback"
1825 bindkey l "goforw"
1826 bindkey b "$ctext yview scroll -1 pages"
1827 bindkey d "$ctext yview scroll 18 units"
1828 bindkey u "$ctext yview scroll -18 units"
1829 bindkey / {dofind 1 1}
1830 bindkey <Key-Return> {dofind 1 1}
1831 bindkey ? {dofind -1 1}
1832 bindkey f nextfile
1833 bindkey <F5> updatecommits
1834 bind . <$M1B-q> doquit
1835 bind . <$M1B-f> {dofind 1 1}
1836 bind . <$M1B-g> {dofind 1 0}
1837 bind . <$M1B-r> dosearchback
1838 bind . <$M1B-s> dosearch
1839 bind . <$M1B-equal> {incrfont 1}
1840 bind . <$M1B-plus> {incrfont 1}
1841 bind . <$M1B-KP_Add> {incrfont 1}
1842 bind . <$M1B-minus> {incrfont -1}
1843 bind . <$M1B-KP_Subtract> {incrfont -1}
1844 wm protocol . WM_DELETE_WINDOW doquit
1845 bind . <Button-1> "click %W"
1846 bind $fstring <Key-Return> {dofind 1 1}
1847 bind $sha1entry <Key-Return> gotocommit
1848 bind $sha1entry <<PasteSelection>> clearsha1
1849 bind $cflist <1> {sel_flist %W %x %y; break}
1850 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1851 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1852 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1854 set maincursor [. cget -cursor]
1855 set textcursor [$ctext cget -cursor]
1856 set curtextcursor $textcursor
1858 set rowctxmenu .rowctxmenu
1859 menu $rowctxmenu -tearoff 0
1860 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1861 -command {diffvssel 0}
1862 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1863 -command {diffvssel 1}
1864 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1865 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1866 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1867 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1868 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1869 -command cherrypick
1870 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1871 -command resethead
1873 set fakerowmenu .fakerowmenu
1874 menu $fakerowmenu -tearoff 0
1875 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1876 -command {diffvssel 0}
1877 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1878 -command {diffvssel 1}
1879 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1880 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1881 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1882 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1884 set headctxmenu .headctxmenu
1885 menu $headctxmenu -tearoff 0
1886 $headctxmenu add command -label [mc "Check out this branch"] \
1887 -command cobranch
1888 $headctxmenu add command -label [mc "Remove this branch"] \
1889 -command rmbranch
1891 global flist_menu
1892 set flist_menu .flistctxmenu
1893 menu $flist_menu -tearoff 0
1894 $flist_menu add command -label [mc "Highlight this too"] \
1895 -command {flist_hl 0}
1896 $flist_menu add command -label [mc "Highlight this only"] \
1897 -command {flist_hl 1}
1900 # Windows sends all mouse wheel events to the current focused window, not
1901 # the one where the mouse hovers, so bind those events here and redirect
1902 # to the correct window
1903 proc windows_mousewheel_redirector {W X Y D} {
1904 global canv canv2 canv3
1905 set w [winfo containing -displayof $W $X $Y]
1906 if {$w ne ""} {
1907 set u [expr {$D < 0 ? 5 : -5}]
1908 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1909 allcanvs yview scroll $u units
1910 } else {
1911 catch {
1912 $w yview scroll $u units
1918 # mouse-2 makes all windows scan vertically, but only the one
1919 # the cursor is in scans horizontally
1920 proc canvscan {op w x y} {
1921 global canv canv2 canv3
1922 foreach c [list $canv $canv2 $canv3] {
1923 if {$c == $w} {
1924 $c scan $op $x $y
1925 } else {
1926 $c scan $op 0 $y
1931 proc scrollcanv {cscroll f0 f1} {
1932 $cscroll set $f0 $f1
1933 drawvisible
1934 flushhighlights
1937 # when we make a key binding for the toplevel, make sure
1938 # it doesn't get triggered when that key is pressed in the
1939 # find string entry widget.
1940 proc bindkey {ev script} {
1941 global entries
1942 bind . $ev $script
1943 set escript [bind Entry $ev]
1944 if {$escript == {}} {
1945 set escript [bind Entry <Key>]
1947 foreach e $entries {
1948 bind $e $ev "$escript; break"
1952 # set the focus back to the toplevel for any click outside
1953 # the entry widgets
1954 proc click {w} {
1955 global ctext entries
1956 foreach e [concat $entries $ctext] {
1957 if {$w == $e} return
1959 focus .
1962 # Adjust the progress bar for a change in requested extent or canvas size
1963 proc adjustprogress {} {
1964 global progresscanv progressitem progresscoords
1965 global fprogitem fprogcoord lastprogupdate progupdatepending
1966 global rprogitem rprogcoord
1968 set w [expr {[winfo width $progresscanv] - 4}]
1969 set x0 [expr {$w * [lindex $progresscoords 0]}]
1970 set x1 [expr {$w * [lindex $progresscoords 1]}]
1971 set h [winfo height $progresscanv]
1972 $progresscanv coords $progressitem $x0 0 $x1 $h
1973 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1974 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1975 set now [clock clicks -milliseconds]
1976 if {$now >= $lastprogupdate + 100} {
1977 set progupdatepending 0
1978 update
1979 } elseif {!$progupdatepending} {
1980 set progupdatepending 1
1981 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1985 proc doprogupdate {} {
1986 global lastprogupdate progupdatepending
1988 if {$progupdatepending} {
1989 set progupdatepending 0
1990 set lastprogupdate [clock clicks -milliseconds]
1991 update
1995 proc savestuff {w} {
1996 global canv canv2 canv3 mainfont textfont uifont tabstop
1997 global stuffsaved findmergefiles maxgraphpct
1998 global maxwidth showneartags showlocalchanges
1999 global viewname viewfiles viewargs viewperm nextviewnum
2000 global cmitmode wrapcomment datetimeformat limitdiffs
2001 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2003 if {$stuffsaved} return
2004 if {![winfo viewable .]} return
2005 catch {
2006 set f [open "~/.gitk-new" w]
2007 puts $f [list set mainfont $mainfont]
2008 puts $f [list set textfont $textfont]
2009 puts $f [list set uifont $uifont]
2010 puts $f [list set tabstop $tabstop]
2011 puts $f [list set findmergefiles $findmergefiles]
2012 puts $f [list set maxgraphpct $maxgraphpct]
2013 puts $f [list set maxwidth $maxwidth]
2014 puts $f [list set cmitmode $cmitmode]
2015 puts $f [list set wrapcomment $wrapcomment]
2016 puts $f [list set showneartags $showneartags]
2017 puts $f [list set showlocalchanges $showlocalchanges]
2018 puts $f [list set datetimeformat $datetimeformat]
2019 puts $f [list set limitdiffs $limitdiffs]
2020 puts $f [list set bgcolor $bgcolor]
2021 puts $f [list set fgcolor $fgcolor]
2022 puts $f [list set colors $colors]
2023 puts $f [list set diffcolors $diffcolors]
2024 puts $f [list set diffcontext $diffcontext]
2025 puts $f [list set selectbgcolor $selectbgcolor]
2027 puts $f "set geometry(main) [wm geometry .]"
2028 puts $f "set geometry(topwidth) [winfo width .tf]"
2029 puts $f "set geometry(topheight) [winfo height .tf]"
2030 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2031 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2032 puts $f "set geometry(botwidth) [winfo width .bleft]"
2033 puts $f "set geometry(botheight) [winfo height .bleft]"
2035 puts -nonewline $f "set permviews {"
2036 for {set v 0} {$v < $nextviewnum} {incr v} {
2037 if {$viewperm($v)} {
2038 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
2041 puts $f "}"
2042 close $f
2043 file rename -force "~/.gitk-new" "~/.gitk"
2045 set stuffsaved 1
2048 proc resizeclistpanes {win w} {
2049 global oldwidth
2050 if {[info exists oldwidth($win)]} {
2051 set s0 [$win sash coord 0]
2052 set s1 [$win sash coord 1]
2053 if {$w < 60} {
2054 set sash0 [expr {int($w/2 - 2)}]
2055 set sash1 [expr {int($w*5/6 - 2)}]
2056 } else {
2057 set factor [expr {1.0 * $w / $oldwidth($win)}]
2058 set sash0 [expr {int($factor * [lindex $s0 0])}]
2059 set sash1 [expr {int($factor * [lindex $s1 0])}]
2060 if {$sash0 < 30} {
2061 set sash0 30
2063 if {$sash1 < $sash0 + 20} {
2064 set sash1 [expr {$sash0 + 20}]
2066 if {$sash1 > $w - 10} {
2067 set sash1 [expr {$w - 10}]
2068 if {$sash0 > $sash1 - 20} {
2069 set sash0 [expr {$sash1 - 20}]
2073 $win sash place 0 $sash0 [lindex $s0 1]
2074 $win sash place 1 $sash1 [lindex $s1 1]
2076 set oldwidth($win) $w
2079 proc resizecdetpanes {win w} {
2080 global oldwidth
2081 if {[info exists oldwidth($win)]} {
2082 set s0 [$win sash coord 0]
2083 if {$w < 60} {
2084 set sash0 [expr {int($w*3/4 - 2)}]
2085 } else {
2086 set factor [expr {1.0 * $w / $oldwidth($win)}]
2087 set sash0 [expr {int($factor * [lindex $s0 0])}]
2088 if {$sash0 < 45} {
2089 set sash0 45
2091 if {$sash0 > $w - 15} {
2092 set sash0 [expr {$w - 15}]
2095 $win sash place 0 $sash0 [lindex $s0 1]
2097 set oldwidth($win) $w
2100 proc allcanvs args {
2101 global canv canv2 canv3
2102 eval $canv $args
2103 eval $canv2 $args
2104 eval $canv3 $args
2107 proc bindall {event action} {
2108 global canv canv2 canv3
2109 bind $canv $event $action
2110 bind $canv2 $event $action
2111 bind $canv3 $event $action
2114 proc about {} {
2115 global uifont
2116 set w .about
2117 if {[winfo exists $w]} {
2118 raise $w
2119 return
2121 toplevel $w
2122 wm title $w [mc "About gitk"]
2123 message $w.m -text [mc "
2124 Gitk - a commit viewer for git
2126 Copyright © 2005-2006 Paul Mackerras
2128 Use and redistribute under the terms of the GNU General Public License"] \
2129 -justify center -aspect 400 -border 2 -bg white -relief groove
2130 pack $w.m -side top -fill x -padx 2 -pady 2
2131 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2132 pack $w.ok -side bottom
2133 bind $w <Visibility> "focus $w.ok"
2134 bind $w <Key-Escape> "destroy $w"
2135 bind $w <Key-Return> "destroy $w"
2138 proc keys {} {
2139 set w .keys
2140 if {[winfo exists $w]} {
2141 raise $w
2142 return
2144 if {[tk windowingsystem] eq {aqua}} {
2145 set M1T Cmd
2146 } else {
2147 set M1T Ctrl
2149 toplevel $w
2150 wm title $w [mc "Gitk key bindings"]
2151 message $w.m -text "
2152 [mc "Gitk key bindings:"]
2154 [mc "<%s-Q> Quit" $M1T]
2155 [mc "<Home> Move to first commit"]
2156 [mc "<End> Move to last commit"]
2157 [mc "<Up>, p, i Move up one commit"]
2158 [mc "<Down>, n, k Move down one commit"]
2159 [mc "<Left>, z, j Go back in history list"]
2160 [mc "<Right>, x, l Go forward in history list"]
2161 [mc "<PageUp> Move up one page in commit list"]
2162 [mc "<PageDown> Move down one page in commit list"]
2163 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2164 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2165 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2166 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2167 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2168 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2169 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2170 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2171 [mc "<Delete>, b Scroll diff view up one page"]
2172 [mc "<Backspace> Scroll diff view up one page"]
2173 [mc "<Space> Scroll diff view down one page"]
2174 [mc "u Scroll diff view up 18 lines"]
2175 [mc "d Scroll diff view down 18 lines"]
2176 [mc "<%s-F> Find" $M1T]
2177 [mc "<%s-G> Move to next find hit" $M1T]
2178 [mc "<Return> Move to next find hit"]
2179 [mc "/ Move to next find hit, or redo find"]
2180 [mc "? Move to previous find hit"]
2181 [mc "f Scroll diff view to next file"]
2182 [mc "<%s-S> Search for next hit in diff view" $M1T]
2183 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2184 [mc "<%s-KP+> Increase font size" $M1T]
2185 [mc "<%s-plus> Increase font size" $M1T]
2186 [mc "<%s-KP-> Decrease font size" $M1T]
2187 [mc "<%s-minus> Decrease font size" $M1T]
2188 [mc "<F5> Update"]
2190 -justify left -bg white -border 2 -relief groove
2191 pack $w.m -side top -fill both -padx 2 -pady 2
2192 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2193 pack $w.ok -side bottom
2194 bind $w <Visibility> "focus $w.ok"
2195 bind $w <Key-Escape> "destroy $w"
2196 bind $w <Key-Return> "destroy $w"
2199 # Procedures for manipulating the file list window at the
2200 # bottom right of the overall window.
2202 proc treeview {w l openlevs} {
2203 global treecontents treediropen treeheight treeparent treeindex
2205 set ix 0
2206 set treeindex() 0
2207 set lev 0
2208 set prefix {}
2209 set prefixend -1
2210 set prefendstack {}
2211 set htstack {}
2212 set ht 0
2213 set treecontents() {}
2214 $w conf -state normal
2215 foreach f $l {
2216 while {[string range $f 0 $prefixend] ne $prefix} {
2217 if {$lev <= $openlevs} {
2218 $w mark set e:$treeindex($prefix) "end -1c"
2219 $w mark gravity e:$treeindex($prefix) left
2221 set treeheight($prefix) $ht
2222 incr ht [lindex $htstack end]
2223 set htstack [lreplace $htstack end end]
2224 set prefixend [lindex $prefendstack end]
2225 set prefendstack [lreplace $prefendstack end end]
2226 set prefix [string range $prefix 0 $prefixend]
2227 incr lev -1
2229 set tail [string range $f [expr {$prefixend+1}] end]
2230 while {[set slash [string first "/" $tail]] >= 0} {
2231 lappend htstack $ht
2232 set ht 0
2233 lappend prefendstack $prefixend
2234 incr prefixend [expr {$slash + 1}]
2235 set d [string range $tail 0 $slash]
2236 lappend treecontents($prefix) $d
2237 set oldprefix $prefix
2238 append prefix $d
2239 set treecontents($prefix) {}
2240 set treeindex($prefix) [incr ix]
2241 set treeparent($prefix) $oldprefix
2242 set tail [string range $tail [expr {$slash+1}] end]
2243 if {$lev <= $openlevs} {
2244 set ht 1
2245 set treediropen($prefix) [expr {$lev < $openlevs}]
2246 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2247 $w mark set d:$ix "end -1c"
2248 $w mark gravity d:$ix left
2249 set str "\n"
2250 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2251 $w insert end $str
2252 $w image create end -align center -image $bm -padx 1 \
2253 -name a:$ix
2254 $w insert end $d [highlight_tag $prefix]
2255 $w mark set s:$ix "end -1c"
2256 $w mark gravity s:$ix left
2258 incr lev
2260 if {$tail ne {}} {
2261 if {$lev <= $openlevs} {
2262 incr ht
2263 set str "\n"
2264 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2265 $w insert end $str
2266 $w insert end $tail [highlight_tag $f]
2268 lappend treecontents($prefix) $tail
2271 while {$htstack ne {}} {
2272 set treeheight($prefix) $ht
2273 incr ht [lindex $htstack end]
2274 set htstack [lreplace $htstack end end]
2275 set prefixend [lindex $prefendstack end]
2276 set prefendstack [lreplace $prefendstack end end]
2277 set prefix [string range $prefix 0 $prefixend]
2279 $w conf -state disabled
2282 proc linetoelt {l} {
2283 global treeheight treecontents
2285 set y 2
2286 set prefix {}
2287 while {1} {
2288 foreach e $treecontents($prefix) {
2289 if {$y == $l} {
2290 return "$prefix$e"
2292 set n 1
2293 if {[string index $e end] eq "/"} {
2294 set n $treeheight($prefix$e)
2295 if {$y + $n > $l} {
2296 append prefix $e
2297 incr y
2298 break
2301 incr y $n
2306 proc highlight_tree {y prefix} {
2307 global treeheight treecontents cflist
2309 foreach e $treecontents($prefix) {
2310 set path $prefix$e
2311 if {[highlight_tag $path] ne {}} {
2312 $cflist tag add bold $y.0 "$y.0 lineend"
2314 incr y
2315 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2316 set y [highlight_tree $y $path]
2319 return $y
2322 proc treeclosedir {w dir} {
2323 global treediropen treeheight treeparent treeindex
2325 set ix $treeindex($dir)
2326 $w conf -state normal
2327 $w delete s:$ix e:$ix
2328 set treediropen($dir) 0
2329 $w image configure a:$ix -image tri-rt
2330 $w conf -state disabled
2331 set n [expr {1 - $treeheight($dir)}]
2332 while {$dir ne {}} {
2333 incr treeheight($dir) $n
2334 set dir $treeparent($dir)
2338 proc treeopendir {w dir} {
2339 global treediropen treeheight treeparent treecontents treeindex
2341 set ix $treeindex($dir)
2342 $w conf -state normal
2343 $w image configure a:$ix -image tri-dn
2344 $w mark set e:$ix s:$ix
2345 $w mark gravity e:$ix right
2346 set lev 0
2347 set str "\n"
2348 set n [llength $treecontents($dir)]
2349 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2350 incr lev
2351 append str "\t"
2352 incr treeheight($x) $n
2354 foreach e $treecontents($dir) {
2355 set de $dir$e
2356 if {[string index $e end] eq "/"} {
2357 set iy $treeindex($de)
2358 $w mark set d:$iy e:$ix
2359 $w mark gravity d:$iy left
2360 $w insert e:$ix $str
2361 set treediropen($de) 0
2362 $w image create e:$ix -align center -image tri-rt -padx 1 \
2363 -name a:$iy
2364 $w insert e:$ix $e [highlight_tag $de]
2365 $w mark set s:$iy e:$ix
2366 $w mark gravity s:$iy left
2367 set treeheight($de) 1
2368 } else {
2369 $w insert e:$ix $str
2370 $w insert e:$ix $e [highlight_tag $de]
2373 $w mark gravity e:$ix left
2374 $w conf -state disabled
2375 set treediropen($dir) 1
2376 set top [lindex [split [$w index @0,0] .] 0]
2377 set ht [$w cget -height]
2378 set l [lindex [split [$w index s:$ix] .] 0]
2379 if {$l < $top} {
2380 $w yview $l.0
2381 } elseif {$l + $n + 1 > $top + $ht} {
2382 set top [expr {$l + $n + 2 - $ht}]
2383 if {$l < $top} {
2384 set top $l
2386 $w yview $top.0
2390 proc treeclick {w x y} {
2391 global treediropen cmitmode ctext cflist cflist_top
2393 if {$cmitmode ne "tree"} return
2394 if {![info exists cflist_top]} return
2395 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2396 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2397 $cflist tag add highlight $l.0 "$l.0 lineend"
2398 set cflist_top $l
2399 if {$l == 1} {
2400 $ctext yview 1.0
2401 return
2403 set e [linetoelt $l]
2404 if {[string index $e end] ne "/"} {
2405 showfile $e
2406 } elseif {$treediropen($e)} {
2407 treeclosedir $w $e
2408 } else {
2409 treeopendir $w $e
2413 proc setfilelist {id} {
2414 global treefilelist cflist
2416 treeview $cflist $treefilelist($id) 0
2419 image create bitmap tri-rt -background black -foreground blue -data {
2420 #define tri-rt_width 13
2421 #define tri-rt_height 13
2422 static unsigned char tri-rt_bits[] = {
2423 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2424 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2425 0x00, 0x00};
2426 } -maskdata {
2427 #define tri-rt-mask_width 13
2428 #define tri-rt-mask_height 13
2429 static unsigned char tri-rt-mask_bits[] = {
2430 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2431 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2432 0x08, 0x00};
2434 image create bitmap tri-dn -background black -foreground blue -data {
2435 #define tri-dn_width 13
2436 #define tri-dn_height 13
2437 static unsigned char tri-dn_bits[] = {
2438 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2439 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2440 0x00, 0x00};
2441 } -maskdata {
2442 #define tri-dn-mask_width 13
2443 #define tri-dn-mask_height 13
2444 static unsigned char tri-dn-mask_bits[] = {
2445 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2446 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2447 0x00, 0x00};
2450 image create bitmap reficon-T -background black -foreground yellow -data {
2451 #define tagicon_width 13
2452 #define tagicon_height 9
2453 static unsigned char tagicon_bits[] = {
2454 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2455 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2456 } -maskdata {
2457 #define tagicon-mask_width 13
2458 #define tagicon-mask_height 9
2459 static unsigned char tagicon-mask_bits[] = {
2460 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2461 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2463 set rectdata {
2464 #define headicon_width 13
2465 #define headicon_height 9
2466 static unsigned char headicon_bits[] = {
2467 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2468 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2470 set rectmask {
2471 #define headicon-mask_width 13
2472 #define headicon-mask_height 9
2473 static unsigned char headicon-mask_bits[] = {
2474 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2475 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2477 image create bitmap reficon-H -background black -foreground green \
2478 -data $rectdata -maskdata $rectmask
2479 image create bitmap reficon-o -background black -foreground "#ddddff" \
2480 -data $rectdata -maskdata $rectmask
2482 proc init_flist {first} {
2483 global cflist cflist_top difffilestart
2485 $cflist conf -state normal
2486 $cflist delete 0.0 end
2487 if {$first ne {}} {
2488 $cflist insert end $first
2489 set cflist_top 1
2490 $cflist tag add highlight 1.0 "1.0 lineend"
2491 } else {
2492 catch {unset cflist_top}
2494 $cflist conf -state disabled
2495 set difffilestart {}
2498 proc highlight_tag {f} {
2499 global highlight_paths
2501 foreach p $highlight_paths {
2502 if {[string match $p $f]} {
2503 return "bold"
2506 return {}
2509 proc highlight_filelist {} {
2510 global cmitmode cflist
2512 $cflist conf -state normal
2513 if {$cmitmode ne "tree"} {
2514 set end [lindex [split [$cflist index end] .] 0]
2515 for {set l 2} {$l < $end} {incr l} {
2516 set line [$cflist get $l.0 "$l.0 lineend"]
2517 if {[highlight_tag $line] ne {}} {
2518 $cflist tag add bold $l.0 "$l.0 lineend"
2521 } else {
2522 highlight_tree 2 {}
2524 $cflist conf -state disabled
2527 proc unhighlight_filelist {} {
2528 global cflist
2530 $cflist conf -state normal
2531 $cflist tag remove bold 1.0 end
2532 $cflist conf -state disabled
2535 proc add_flist {fl} {
2536 global cflist
2538 $cflist conf -state normal
2539 foreach f $fl {
2540 $cflist insert end "\n"
2541 $cflist insert end $f [highlight_tag $f]
2543 $cflist conf -state disabled
2546 proc sel_flist {w x y} {
2547 global ctext difffilestart cflist cflist_top cmitmode
2549 if {$cmitmode eq "tree"} return
2550 if {![info exists cflist_top]} return
2551 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2552 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2553 $cflist tag add highlight $l.0 "$l.0 lineend"
2554 set cflist_top $l
2555 if {$l == 1} {
2556 $ctext yview 1.0
2557 } else {
2558 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2562 proc pop_flist_menu {w X Y x y} {
2563 global ctext cflist cmitmode flist_menu flist_menu_file
2564 global treediffs diffids
2566 stopfinding
2567 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2568 if {$l <= 1} return
2569 if {$cmitmode eq "tree"} {
2570 set e [linetoelt $l]
2571 if {[string index $e end] eq "/"} return
2572 } else {
2573 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2575 set flist_menu_file $e
2576 tk_popup $flist_menu $X $Y
2579 proc flist_hl {only} {
2580 global flist_menu_file findstring gdttype
2582 set x [shellquote $flist_menu_file]
2583 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2584 set findstring $x
2585 } else {
2586 append findstring " " $x
2588 set gdttype [mc "touching paths:"]
2591 # Functions for adding and removing shell-type quoting
2593 proc shellquote {str} {
2594 if {![string match "*\['\"\\ \t]*" $str]} {
2595 return $str
2597 if {![string match "*\['\"\\]*" $str]} {
2598 return "\"$str\""
2600 if {![string match "*'*" $str]} {
2601 return "'$str'"
2603 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2606 proc shellarglist {l} {
2607 set str {}
2608 foreach a $l {
2609 if {$str ne {}} {
2610 append str " "
2612 append str [shellquote $a]
2614 return $str
2617 proc shelldequote {str} {
2618 set ret {}
2619 set used -1
2620 while {1} {
2621 incr used
2622 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2623 append ret [string range $str $used end]
2624 set used [string length $str]
2625 break
2627 set first [lindex $first 0]
2628 set ch [string index $str $first]
2629 if {$first > $used} {
2630 append ret [string range $str $used [expr {$first - 1}]]
2631 set used $first
2633 if {$ch eq " " || $ch eq "\t"} break
2634 incr used
2635 if {$ch eq "'"} {
2636 set first [string first "'" $str $used]
2637 if {$first < 0} {
2638 error "unmatched single-quote"
2640 append ret [string range $str $used [expr {$first - 1}]]
2641 set used $first
2642 continue
2644 if {$ch eq "\\"} {
2645 if {$used >= [string length $str]} {
2646 error "trailing backslash"
2648 append ret [string index $str $used]
2649 continue
2651 # here ch == "\""
2652 while {1} {
2653 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2654 error "unmatched double-quote"
2656 set first [lindex $first 0]
2657 set ch [string index $str $first]
2658 if {$first > $used} {
2659 append ret [string range $str $used [expr {$first - 1}]]
2660 set used $first
2662 if {$ch eq "\""} break
2663 incr used
2664 append ret [string index $str $used]
2665 incr used
2668 return [list $used $ret]
2671 proc shellsplit {str} {
2672 set l {}
2673 while {1} {
2674 set str [string trimleft $str]
2675 if {$str eq {}} break
2676 set dq [shelldequote $str]
2677 set n [lindex $dq 0]
2678 set word [lindex $dq 1]
2679 set str [string range $str $n end]
2680 lappend l $word
2682 return $l
2685 # Code to implement multiple views
2687 proc newview {ishighlight} {
2688 global nextviewnum newviewname newviewperm newishighlight
2689 global newviewargs revtreeargs
2691 set newishighlight $ishighlight
2692 set top .gitkview
2693 if {[winfo exists $top]} {
2694 raise $top
2695 return
2697 set newviewname($nextviewnum) "View $nextviewnum"
2698 set newviewperm($nextviewnum) 0
2699 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2700 vieweditor $top $nextviewnum [mc "Gitk view definition"]
2703 proc editview {} {
2704 global curview
2705 global viewname viewperm newviewname newviewperm
2706 global viewargs newviewargs
2708 set top .gitkvedit-$curview
2709 if {[winfo exists $top]} {
2710 raise $top
2711 return
2713 set newviewname($curview) $viewname($curview)
2714 set newviewperm($curview) $viewperm($curview)
2715 set newviewargs($curview) [shellarglist $viewargs($curview)]
2716 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2719 proc vieweditor {top n title} {
2720 global newviewname newviewperm viewfiles bgcolor
2722 toplevel $top
2723 wm title $top $title
2724 label $top.nl -text [mc "Name"]
2725 entry $top.name -width 20 -textvariable newviewname($n)
2726 grid $top.nl $top.name -sticky w -pady 5
2727 checkbutton $top.perm -text [mc "Remember this view"] \
2728 -variable newviewperm($n)
2729 grid $top.perm - -pady 5 -sticky w
2730 message $top.al -aspect 1000 \
2731 -text [mc "Commits to include (arguments to git rev-list):"]
2732 grid $top.al - -sticky w -pady 5
2733 entry $top.args -width 50 -textvariable newviewargs($n) \
2734 -background $bgcolor
2735 grid $top.args - -sticky ew -padx 5
2736 message $top.l -aspect 1000 \
2737 -text [mc "Enter files and directories to include, one per line:"]
2738 grid $top.l - -sticky w
2739 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
2740 if {[info exists viewfiles($n)]} {
2741 foreach f $viewfiles($n) {
2742 $top.t insert end $f
2743 $top.t insert end "\n"
2745 $top.t delete {end - 1c} end
2746 $top.t mark set insert 0.0
2748 grid $top.t - -sticky ew -padx 5
2749 frame $top.buts
2750 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
2751 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
2752 grid $top.buts.ok $top.buts.can
2753 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2754 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2755 grid $top.buts - -pady 10 -sticky ew
2756 focus $top.t
2759 proc doviewmenu {m first cmd op argv} {
2760 set nmenu [$m index end]
2761 for {set i $first} {$i <= $nmenu} {incr i} {
2762 if {[$m entrycget $i -command] eq $cmd} {
2763 eval $m $op $i $argv
2764 break
2769 proc allviewmenus {n op args} {
2770 # global viewhlmenu
2772 doviewmenu .bar.view 5 [list showview $n] $op $args
2773 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2776 proc newviewok {top n} {
2777 global nextviewnum newviewperm newviewname newishighlight
2778 global viewname viewfiles viewperm selectedview curview
2779 global viewargs newviewargs viewhlmenu
2781 if {[catch {
2782 set newargs [shellsplit $newviewargs($n)]
2783 } err]} {
2784 error_popup "[mc "Error in commit selection arguments:"] $err"
2785 wm raise $top
2786 focus $top
2787 return
2789 set files {}
2790 foreach f [split [$top.t get 0.0 end] "\n"] {
2791 set ft [string trim $f]
2792 if {$ft ne {}} {
2793 lappend files $ft
2796 if {![info exists viewfiles($n)]} {
2797 # creating a new view
2798 incr nextviewnum
2799 set viewname($n) $newviewname($n)
2800 set viewperm($n) $newviewperm($n)
2801 set viewfiles($n) $files
2802 set viewargs($n) $newargs
2803 addviewmenu $n
2804 if {!$newishighlight} {
2805 run showview $n
2806 } else {
2807 run addvhighlight $n
2809 } else {
2810 # editing an existing view
2811 set viewperm($n) $newviewperm($n)
2812 if {$newviewname($n) ne $viewname($n)} {
2813 set viewname($n) $newviewname($n)
2814 doviewmenu .bar.view 5 [list showview $n] \
2815 entryconf [list -label $viewname($n)]
2816 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2817 # entryconf [list -label $viewname($n) -value $viewname($n)]
2819 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2820 set viewfiles($n) $files
2821 set viewargs($n) $newargs
2822 if {$curview == $n} {
2823 run reloadcommits
2827 catch {destroy $top}
2830 proc delview {} {
2831 global curview viewperm hlview selectedhlview
2833 if {$curview == 0} return
2834 if {[info exists hlview] && $hlview == $curview} {
2835 set selectedhlview [mc "None"]
2836 unset hlview
2838 allviewmenus $curview delete
2839 set viewperm($curview) 0
2840 showview 0
2843 proc addviewmenu {n} {
2844 global viewname viewhlmenu
2846 .bar.view add radiobutton -label $viewname($n) \
2847 -command [list showview $n] -variable selectedview -value $n
2848 #$viewhlmenu add radiobutton -label $viewname($n) \
2849 # -command [list addvhighlight $n] -variable selectedhlview
2852 proc showview {n} {
2853 global curview viewfiles cached_commitrow ordertok
2854 global displayorder parentlist rowidlist rowisopt rowfinal
2855 global colormap rowtextx nextcolor canvxmax
2856 global numcommits viewcomplete
2857 global selectedline currentid canv canvy0
2858 global treediffs
2859 global pending_select mainheadid
2860 global commitidx
2861 global selectedview
2862 global hlview selectedhlview commitinterest
2864 if {$n == $curview} return
2865 set selid {}
2866 set ymax [lindex [$canv cget -scrollregion] 3]
2867 set span [$canv yview]
2868 set ytop [expr {[lindex $span 0] * $ymax}]
2869 set ybot [expr {[lindex $span 1] * $ymax}]
2870 set yscreen [expr {($ybot - $ytop) / 2}]
2871 if {[info exists selectedline]} {
2872 set selid $currentid
2873 set y [yc $selectedline]
2874 if {$ytop < $y && $y < $ybot} {
2875 set yscreen [expr {$y - $ytop}]
2877 } elseif {[info exists pending_select]} {
2878 set selid $pending_select
2879 unset pending_select
2881 unselectline
2882 normalline
2883 catch {unset treediffs}
2884 clear_display
2885 if {[info exists hlview] && $hlview == $n} {
2886 unset hlview
2887 set selectedhlview [mc "None"]
2889 catch {unset commitinterest}
2890 catch {unset cached_commitrow}
2891 catch {unset ordertok}
2893 set curview $n
2894 set selectedview $n
2895 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
2896 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
2898 run refill_reflist
2899 if {![info exists viewcomplete($n)]} {
2900 if {$selid ne {}} {
2901 set pending_select $selid
2903 getcommits
2904 return
2907 set displayorder {}
2908 set parentlist {}
2909 set rowidlist {}
2910 set rowisopt {}
2911 set rowfinal {}
2912 set numcommits $commitidx($n)
2914 catch {unset colormap}
2915 catch {unset rowtextx}
2916 set nextcolor 0
2917 set canvxmax [$canv cget -width]
2918 set curview $n
2919 set row 0
2920 setcanvscroll
2921 set yf 0
2922 set row {}
2923 if {$selid ne {} && [commitinview $selid $n]} {
2924 set row [rowofcommit $selid]
2925 # try to get the selected row in the same position on the screen
2926 set ymax [lindex [$canv cget -scrollregion] 3]
2927 set ytop [expr {[yc $row] - $yscreen}]
2928 if {$ytop < 0} {
2929 set ytop 0
2931 set yf [expr {$ytop * 1.0 / $ymax}]
2933 allcanvs yview moveto $yf
2934 drawvisible
2935 if {$row ne {}} {
2936 selectline $row 0
2937 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
2938 selectline [rowofcommit $mainheadid] 1
2939 } elseif {!$viewcomplete($n)} {
2940 if {$selid ne {}} {
2941 set pending_select $selid
2942 } else {
2943 set pending_select $mainheadid
2945 } else {
2946 set row [first_real_row]
2947 if {$row < $numcommits} {
2948 selectline $row 0
2951 if {!$viewcomplete($n)} {
2952 if {$numcommits == 0} {
2953 show_status [mc "Reading commits..."]
2955 } elseif {$numcommits == 0} {
2956 show_status [mc "No commits selected"]
2960 # Stuff relating to the highlighting facility
2962 proc ishighlighted {id} {
2963 global vhighlights fhighlights nhighlights rhighlights
2965 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
2966 return $nhighlights($id)
2968 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
2969 return $vhighlights($id)
2971 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
2972 return $fhighlights($id)
2974 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
2975 return $rhighlights($id)
2977 return 0
2980 proc bolden {row font} {
2981 global canv linehtag selectedline boldrows
2983 lappend boldrows $row
2984 $canv itemconf $linehtag($row) -font $font
2985 if {[info exists selectedline] && $row == $selectedline} {
2986 $canv delete secsel
2987 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2988 -outline {{}} -tags secsel \
2989 -fill [$canv cget -selectbackground]]
2990 $canv lower $t
2994 proc bolden_name {row font} {
2995 global canv2 linentag selectedline boldnamerows
2997 lappend boldnamerows $row
2998 $canv2 itemconf $linentag($row) -font $font
2999 if {[info exists selectedline] && $row == $selectedline} {
3000 $canv2 delete secsel
3001 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3002 -outline {{}} -tags secsel \
3003 -fill [$canv2 cget -selectbackground]]
3004 $canv2 lower $t
3008 proc unbolden {} {
3009 global boldrows
3011 set stillbold {}
3012 foreach row $boldrows {
3013 if {![ishighlighted [commitonrow $row]]} {
3014 bolden $row mainfont
3015 } else {
3016 lappend stillbold $row
3019 set boldrows $stillbold
3022 proc addvhighlight {n} {
3023 global hlview viewcomplete curview vhl_done commitidx
3025 if {[info exists hlview]} {
3026 delvhighlight
3028 set hlview $n
3029 if {$n != $curview && ![info exists viewcomplete($n)]} {
3030 start_rev_list $n
3032 set vhl_done $commitidx($hlview)
3033 if {$vhl_done > 0} {
3034 drawvisible
3038 proc delvhighlight {} {
3039 global hlview vhighlights
3041 if {![info exists hlview]} return
3042 unset hlview
3043 catch {unset vhighlights}
3044 unbolden
3047 proc vhighlightmore {} {
3048 global hlview vhl_done commitidx vhighlights curview
3050 set max $commitidx($hlview)
3051 set vr [visiblerows]
3052 set r0 [lindex $vr 0]
3053 set r1 [lindex $vr 1]
3054 for {set i $vhl_done} {$i < $max} {incr i} {
3055 set id [commitonrow $i $hlview]
3056 if {[commitinview $id $curview]} {
3057 set row [rowofcommit $id]
3058 if {$r0 <= $row && $row <= $r1} {
3059 if {![highlighted $row]} {
3060 bolden $row mainfontbold
3062 set vhighlights($id) 1
3066 set vhl_done $max
3069 proc askvhighlight {row id} {
3070 global hlview vhighlights iddrawn
3072 if {[commitinview $id $hlview]} {
3073 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3074 bolden $row mainfontbold
3076 set vhighlights($id) 1
3077 } else {
3078 set vhighlights($id) 0
3082 proc hfiles_change {} {
3083 global highlight_files filehighlight fhighlights fh_serial
3084 global highlight_paths gdttype
3086 if {[info exists filehighlight]} {
3087 # delete previous highlights
3088 catch {close $filehighlight}
3089 unset filehighlight
3090 catch {unset fhighlights}
3091 unbolden
3092 unhighlight_filelist
3094 set highlight_paths {}
3095 after cancel do_file_hl $fh_serial
3096 incr fh_serial
3097 if {$highlight_files ne {}} {
3098 after 300 do_file_hl $fh_serial
3102 proc gdttype_change {name ix op} {
3103 global gdttype highlight_files findstring findpattern
3105 stopfinding
3106 if {$findstring ne {}} {
3107 if {$gdttype eq [mc "containing:"]} {
3108 if {$highlight_files ne {}} {
3109 set highlight_files {}
3110 hfiles_change
3112 findcom_change
3113 } else {
3114 if {$findpattern ne {}} {
3115 set findpattern {}
3116 findcom_change
3118 set highlight_files $findstring
3119 hfiles_change
3121 drawvisible
3123 # enable/disable findtype/findloc menus too
3126 proc find_change {name ix op} {
3127 global gdttype findstring highlight_files
3129 stopfinding
3130 if {$gdttype eq [mc "containing:"]} {
3131 findcom_change
3132 } else {
3133 if {$highlight_files ne $findstring} {
3134 set highlight_files $findstring
3135 hfiles_change
3138 drawvisible
3141 proc findcom_change args {
3142 global nhighlights boldnamerows
3143 global findpattern findtype findstring gdttype
3145 stopfinding
3146 # delete previous highlights, if any
3147 foreach row $boldnamerows {
3148 bolden_name $row mainfont
3150 set boldnamerows {}
3151 catch {unset nhighlights}
3152 unbolden
3153 unmarkmatches
3154 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3155 set findpattern {}
3156 } elseif {$findtype eq [mc "Regexp"]} {
3157 set findpattern $findstring
3158 } else {
3159 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3160 $findstring]
3161 set findpattern "*$e*"
3165 proc makepatterns {l} {
3166 set ret {}
3167 foreach e $l {
3168 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3169 if {[string index $ee end] eq "/"} {
3170 lappend ret "$ee*"
3171 } else {
3172 lappend ret $ee
3173 lappend ret "$ee/*"
3176 return $ret
3179 proc do_file_hl {serial} {
3180 global highlight_files filehighlight highlight_paths gdttype fhl_list
3182 if {$gdttype eq [mc "touching paths:"]} {
3183 if {[catch {set paths [shellsplit $highlight_files]}]} return
3184 set highlight_paths [makepatterns $paths]
3185 highlight_filelist
3186 set gdtargs [concat -- $paths]
3187 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3188 set gdtargs [list "-S$highlight_files"]
3189 } else {
3190 # must be "containing:", i.e. we're searching commit info
3191 return
3193 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3194 set filehighlight [open $cmd r+]
3195 fconfigure $filehighlight -blocking 0
3196 filerun $filehighlight readfhighlight
3197 set fhl_list {}
3198 drawvisible
3199 flushhighlights
3202 proc flushhighlights {} {
3203 global filehighlight fhl_list
3205 if {[info exists filehighlight]} {
3206 lappend fhl_list {}
3207 puts $filehighlight ""
3208 flush $filehighlight
3212 proc askfilehighlight {row id} {
3213 global filehighlight fhighlights fhl_list
3215 lappend fhl_list $id
3216 set fhighlights($id) -1
3217 puts $filehighlight $id
3220 proc readfhighlight {} {
3221 global filehighlight fhighlights curview iddrawn
3222 global fhl_list find_dirn
3224 if {![info exists filehighlight]} {
3225 return 0
3227 set nr 0
3228 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3229 set line [string trim $line]
3230 set i [lsearch -exact $fhl_list $line]
3231 if {$i < 0} continue
3232 for {set j 0} {$j < $i} {incr j} {
3233 set id [lindex $fhl_list $j]
3234 set fhighlights($id) 0
3236 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3237 if {$line eq {}} continue
3238 if {![commitinview $line $curview]} continue
3239 set row [rowofcommit $line]
3240 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3241 bolden $row mainfontbold
3243 set fhighlights($line) 1
3245 if {[eof $filehighlight]} {
3246 # strange...
3247 puts "oops, git diff-tree died"
3248 catch {close $filehighlight}
3249 unset filehighlight
3250 return 0
3252 if {[info exists find_dirn]} {
3253 run findmore
3255 return 1
3258 proc doesmatch {f} {
3259 global findtype findpattern
3261 if {$findtype eq [mc "Regexp"]} {
3262 return [regexp $findpattern $f]
3263 } elseif {$findtype eq [mc "IgnCase"]} {
3264 return [string match -nocase $findpattern $f]
3265 } else {
3266 return [string match $findpattern $f]
3270 proc askfindhighlight {row id} {
3271 global nhighlights commitinfo iddrawn
3272 global findloc
3273 global markingmatches
3275 if {![info exists commitinfo($id)]} {
3276 getcommit $id
3278 set info $commitinfo($id)
3279 set isbold 0
3280 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3281 foreach f $info ty $fldtypes {
3282 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3283 [doesmatch $f]} {
3284 if {$ty eq [mc "Author"]} {
3285 set isbold 2
3286 break
3288 set isbold 1
3291 if {$isbold && [info exists iddrawn($id)]} {
3292 if {![ishighlighted $id]} {
3293 bolden $row mainfontbold
3294 if {$isbold > 1} {
3295 bolden_name $row mainfontbold
3298 if {$markingmatches} {
3299 markrowmatches $row $id
3302 set nhighlights($id) $isbold
3305 proc markrowmatches {row id} {
3306 global canv canv2 linehtag linentag commitinfo findloc
3308 set headline [lindex $commitinfo($id) 0]
3309 set author [lindex $commitinfo($id) 1]
3310 $canv delete match$row
3311 $canv2 delete match$row
3312 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3313 set m [findmatches $headline]
3314 if {$m ne {}} {
3315 markmatches $canv $row $headline $linehtag($row) $m \
3316 [$canv itemcget $linehtag($row) -font] $row
3319 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3320 set m [findmatches $author]
3321 if {$m ne {}} {
3322 markmatches $canv2 $row $author $linentag($row) $m \
3323 [$canv2 itemcget $linentag($row) -font] $row
3328 proc vrel_change {name ix op} {
3329 global highlight_related
3331 rhighlight_none
3332 if {$highlight_related ne [mc "None"]} {
3333 run drawvisible
3337 # prepare for testing whether commits are descendents or ancestors of a
3338 proc rhighlight_sel {a} {
3339 global descendent desc_todo ancestor anc_todo
3340 global highlight_related
3342 catch {unset descendent}
3343 set desc_todo [list $a]
3344 catch {unset ancestor}
3345 set anc_todo [list $a]
3346 if {$highlight_related ne [mc "None"]} {
3347 rhighlight_none
3348 run drawvisible
3352 proc rhighlight_none {} {
3353 global rhighlights
3355 catch {unset rhighlights}
3356 unbolden
3359 proc is_descendent {a} {
3360 global curview children descendent desc_todo
3362 set v $curview
3363 set la [rowofcommit $a]
3364 set todo $desc_todo
3365 set leftover {}
3366 set done 0
3367 for {set i 0} {$i < [llength $todo]} {incr i} {
3368 set do [lindex $todo $i]
3369 if {[rowofcommit $do] < $la} {
3370 lappend leftover $do
3371 continue
3373 foreach nk $children($v,$do) {
3374 if {![info exists descendent($nk)]} {
3375 set descendent($nk) 1
3376 lappend todo $nk
3377 if {$nk eq $a} {
3378 set done 1
3382 if {$done} {
3383 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3384 return
3387 set descendent($a) 0
3388 set desc_todo $leftover
3391 proc is_ancestor {a} {
3392 global curview parents ancestor anc_todo
3394 set v $curview
3395 set la [rowofcommit $a]
3396 set todo $anc_todo
3397 set leftover {}
3398 set done 0
3399 for {set i 0} {$i < [llength $todo]} {incr i} {
3400 set do [lindex $todo $i]
3401 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3402 lappend leftover $do
3403 continue
3405 foreach np $parents($v,$do) {
3406 if {![info exists ancestor($np)]} {
3407 set ancestor($np) 1
3408 lappend todo $np
3409 if {$np eq $a} {
3410 set done 1
3414 if {$done} {
3415 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3416 return
3419 set ancestor($a) 0
3420 set anc_todo $leftover
3423 proc askrelhighlight {row id} {
3424 global descendent highlight_related iddrawn rhighlights
3425 global selectedline ancestor
3427 if {![info exists selectedline]} return
3428 set isbold 0
3429 if {$highlight_related eq [mc "Descendant"] ||
3430 $highlight_related eq [mc "Not descendant"]} {
3431 if {![info exists descendent($id)]} {
3432 is_descendent $id
3434 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3435 set isbold 1
3437 } elseif {$highlight_related eq [mc "Ancestor"] ||
3438 $highlight_related eq [mc "Not ancestor"]} {
3439 if {![info exists ancestor($id)]} {
3440 is_ancestor $id
3442 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3443 set isbold 1
3446 if {[info exists iddrawn($id)]} {
3447 if {$isbold && ![ishighlighted $id]} {
3448 bolden $row mainfontbold
3451 set rhighlights($id) $isbold
3454 # Graph layout functions
3456 proc shortids {ids} {
3457 set res {}
3458 foreach id $ids {
3459 if {[llength $id] > 1} {
3460 lappend res [shortids $id]
3461 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3462 lappend res [string range $id 0 7]
3463 } else {
3464 lappend res $id
3467 return $res
3470 proc ntimes {n o} {
3471 set ret {}
3472 set o [list $o]
3473 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3474 if {($n & $mask) != 0} {
3475 set ret [concat $ret $o]
3477 set o [concat $o $o]
3479 return $ret
3482 proc ordertoken {id} {
3483 global ordertok curview varcid varcstart varctok curview parents children
3484 global nullid nullid2
3486 if {[info exists ordertok($id)]} {
3487 return $ordertok($id)
3489 set origid $id
3490 set todo {}
3491 while {1} {
3492 if {[info exists varcid($curview,$id)]} {
3493 set a $varcid($curview,$id)
3494 set p [lindex $varcstart($curview) $a]
3495 } else {
3496 set p [lindex $children($curview,$id) 0]
3498 if {[info exists ordertok($p)]} {
3499 set tok $ordertok($p)
3500 break
3502 set id [first_real_child $curview,$p]
3503 if {$id eq {}} {
3504 # it's a root
3505 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3506 break
3508 if {[llength $parents($curview,$id)] == 1} {
3509 lappend todo [list $p {}]
3510 } else {
3511 set j [lsearch -exact $parents($curview,$id) $p]
3512 if {$j < 0} {
3513 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3515 lappend todo [list $p [strrep $j]]
3518 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3519 set p [lindex $todo $i 0]
3520 append tok [lindex $todo $i 1]
3521 set ordertok($p) $tok
3523 set ordertok($origid) $tok
3524 return $tok
3527 # Work out where id should go in idlist so that order-token
3528 # values increase from left to right
3529 proc idcol {idlist id {i 0}} {
3530 set t [ordertoken $id]
3531 if {$i < 0} {
3532 set i 0
3534 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3535 if {$i > [llength $idlist]} {
3536 set i [llength $idlist]
3538 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3539 incr i
3540 } else {
3541 if {$t > [ordertoken [lindex $idlist $i]]} {
3542 while {[incr i] < [llength $idlist] &&
3543 $t >= [ordertoken [lindex $idlist $i]]} {}
3546 return $i
3549 proc initlayout {} {
3550 global rowidlist rowisopt rowfinal displayorder parentlist
3551 global numcommits canvxmax canv
3552 global nextcolor
3553 global colormap rowtextx
3555 set numcommits 0
3556 set displayorder {}
3557 set parentlist {}
3558 set nextcolor 0
3559 set rowidlist {}
3560 set rowisopt {}
3561 set rowfinal {}
3562 set canvxmax [$canv cget -width]
3563 catch {unset colormap}
3564 catch {unset rowtextx}
3567 proc setcanvscroll {} {
3568 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3570 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3571 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3572 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3573 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3576 proc visiblerows {} {
3577 global canv numcommits linespc
3579 set ymax [lindex [$canv cget -scrollregion] 3]
3580 if {$ymax eq {} || $ymax == 0} return
3581 set f [$canv yview]
3582 set y0 [expr {int([lindex $f 0] * $ymax)}]
3583 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3584 if {$r0 < 0} {
3585 set r0 0
3587 set y1 [expr {int([lindex $f 1] * $ymax)}]
3588 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3589 if {$r1 >= $numcommits} {
3590 set r1 [expr {$numcommits - 1}]
3592 return [list $r0 $r1]
3595 proc layoutmore {} {
3596 global commitidx viewcomplete curview
3597 global numcommits pending_select selectedline curview
3598 global lastscrollset commitinterest
3600 set canshow $commitidx($curview)
3601 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3602 if {$numcommits == 0} {
3603 allcanvs delete all
3605 set r0 $numcommits
3606 set prev $numcommits
3607 set numcommits $canshow
3608 set t [clock clicks -milliseconds]
3609 if {$prev < 100 || $viewcomplete($curview) || $t - $lastscrollset > 500} {
3610 set lastscrollset $t
3611 setcanvscroll
3613 set rows [visiblerows]
3614 set r1 [lindex $rows 1]
3615 if {$r1 >= $canshow} {
3616 set r1 [expr {$canshow - 1}]
3618 if {$r0 <= $r1} {
3619 drawcommits $r0 $r1
3621 if {[info exists pending_select] &&
3622 [commitinview $pending_select $curview]} {
3623 selectline [rowofcommit $pending_select] 1
3627 proc doshowlocalchanges {} {
3628 global curview mainheadid
3630 if {[commitinview $mainheadid $curview]} {
3631 dodiffindex
3632 } else {
3633 lappend commitinterest($mainheadid) {dodiffindex}
3637 proc dohidelocalchanges {} {
3638 global nullid nullid2 lserial curview
3640 if {[commitinview $nullid $curview]} {
3641 removefakerow $nullid
3643 if {[commitinview $nullid2 $curview]} {
3644 removefakerow $nullid2
3646 incr lserial
3649 # spawn off a process to do git diff-index --cached HEAD
3650 proc dodiffindex {} {
3651 global lserial showlocalchanges
3653 if {!$showlocalchanges} return
3654 incr lserial
3655 set fd [open "|git diff-index --cached HEAD" r]
3656 fconfigure $fd -blocking 0
3657 filerun $fd [list readdiffindex $fd $lserial]
3660 proc readdiffindex {fd serial} {
3661 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3663 set isdiff 1
3664 if {[gets $fd line] < 0} {
3665 if {![eof $fd]} {
3666 return 1
3668 set isdiff 0
3670 # we only need to see one line and we don't really care what it says...
3671 close $fd
3673 if {$serial != $lserial} {
3674 return 0
3677 # now see if there are any local changes not checked in to the index
3678 set fd [open "|git diff-files" r]
3679 fconfigure $fd -blocking 0
3680 filerun $fd [list readdifffiles $fd $serial]
3682 if {$isdiff && ![commitinview $nullid2 $curview]} {
3683 # add the line for the changes in the index to the graph
3684 set hl [mc "Local changes checked in to index but not committed"]
3685 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3686 set commitdata($nullid2) "\n $hl\n"
3687 if {[commitinview $nullid $curview]} {
3688 removefakerow $nullid
3690 insertfakerow $nullid2 $mainheadid
3691 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
3692 removefakerow $nullid2
3694 return 0
3697 proc readdifffiles {fd serial} {
3698 global mainheadid nullid nullid2 curview
3699 global commitinfo commitdata lserial
3701 set isdiff 1
3702 if {[gets $fd line] < 0} {
3703 if {![eof $fd]} {
3704 return 1
3706 set isdiff 0
3708 # we only need to see one line and we don't really care what it says...
3709 close $fd
3711 if {$serial != $lserial} {
3712 return 0
3715 if {$isdiff && ![commitinview $nullid $curview]} {
3716 # add the line for the local diff to the graph
3717 set hl [mc "Local uncommitted changes, not checked in to index"]
3718 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3719 set commitdata($nullid) "\n $hl\n"
3720 if {[commitinview $nullid2 $curview]} {
3721 set p $nullid2
3722 } else {
3723 set p $mainheadid
3725 insertfakerow $nullid $p
3726 } elseif {!$isdiff && [commitinview $nullid $curview]} {
3727 removefakerow $nullid
3729 return 0
3732 proc nextuse {id row} {
3733 global curview children
3735 if {[info exists children($curview,$id)]} {
3736 foreach kid $children($curview,$id) {
3737 if {![commitinview $kid $curview]} {
3738 return -1
3740 if {[rowofcommit $kid] > $row} {
3741 return [rowofcommit $kid]
3745 if {[commitinview $id $curview]} {
3746 return [rowofcommit $id]
3748 return -1
3751 proc prevuse {id row} {
3752 global curview children
3754 set ret -1
3755 if {[info exists children($curview,$id)]} {
3756 foreach kid $children($curview,$id) {
3757 if {![commitinview $kid $curview]} break
3758 if {[rowofcommit $kid] < $row} {
3759 set ret [rowofcommit $kid]
3763 return $ret
3766 proc make_idlist {row} {
3767 global displayorder parentlist uparrowlen downarrowlen mingaplen
3768 global commitidx curview children
3770 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3771 if {$r < 0} {
3772 set r 0
3774 set ra [expr {$row - $downarrowlen}]
3775 if {$ra < 0} {
3776 set ra 0
3778 set rb [expr {$row + $uparrowlen}]
3779 if {$rb > $commitidx($curview)} {
3780 set rb $commitidx($curview)
3782 make_disporder $r [expr {$rb + 1}]
3783 set ids {}
3784 for {} {$r < $ra} {incr r} {
3785 set nextid [lindex $displayorder [expr {$r + 1}]]
3786 foreach p [lindex $parentlist $r] {
3787 if {$p eq $nextid} continue
3788 set rn [nextuse $p $r]
3789 if {$rn >= $row &&
3790 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3791 lappend ids [list [ordertoken $p] $p]
3795 for {} {$r < $row} {incr r} {
3796 set nextid [lindex $displayorder [expr {$r + 1}]]
3797 foreach p [lindex $parentlist $r] {
3798 if {$p eq $nextid} continue
3799 set rn [nextuse $p $r]
3800 if {$rn < 0 || $rn >= $row} {
3801 lappend ids [list [ordertoken $p] $p]
3805 set id [lindex $displayorder $row]
3806 lappend ids [list [ordertoken $id] $id]
3807 while {$r < $rb} {
3808 foreach p [lindex $parentlist $r] {
3809 set firstkid [lindex $children($curview,$p) 0]
3810 if {[rowofcommit $firstkid] < $row} {
3811 lappend ids [list [ordertoken $p] $p]
3814 incr r
3815 set id [lindex $displayorder $r]
3816 if {$id ne {}} {
3817 set firstkid [lindex $children($curview,$id) 0]
3818 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3819 lappend ids [list [ordertoken $id] $id]
3823 set idlist {}
3824 foreach idx [lsort -unique $ids] {
3825 lappend idlist [lindex $idx 1]
3827 return $idlist
3830 proc rowsequal {a b} {
3831 while {[set i [lsearch -exact $a {}]] >= 0} {
3832 set a [lreplace $a $i $i]
3834 while {[set i [lsearch -exact $b {}]] >= 0} {
3835 set b [lreplace $b $i $i]
3837 return [expr {$a eq $b}]
3840 proc makeupline {id row rend col} {
3841 global rowidlist uparrowlen downarrowlen mingaplen
3843 for {set r $rend} {1} {set r $rstart} {
3844 set rstart [prevuse $id $r]
3845 if {$rstart < 0} return
3846 if {$rstart < $row} break
3848 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3849 set rstart [expr {$rend - $uparrowlen - 1}]
3851 for {set r $rstart} {[incr r] <= $row} {} {
3852 set idlist [lindex $rowidlist $r]
3853 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3854 set col [idcol $idlist $id $col]
3855 lset rowidlist $r [linsert $idlist $col $id]
3856 changedrow $r
3861 proc layoutrows {row endrow} {
3862 global rowidlist rowisopt rowfinal displayorder
3863 global uparrowlen downarrowlen maxwidth mingaplen
3864 global children parentlist
3865 global commitidx viewcomplete curview
3867 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3868 set idlist {}
3869 if {$row > 0} {
3870 set rm1 [expr {$row - 1}]
3871 foreach id [lindex $rowidlist $rm1] {
3872 if {$id ne {}} {
3873 lappend idlist $id
3876 set final [lindex $rowfinal $rm1]
3878 for {} {$row < $endrow} {incr row} {
3879 set rm1 [expr {$row - 1}]
3880 if {$rm1 < 0 || $idlist eq {}} {
3881 set idlist [make_idlist $row]
3882 set final 1
3883 } else {
3884 set id [lindex $displayorder $rm1]
3885 set col [lsearch -exact $idlist $id]
3886 set idlist [lreplace $idlist $col $col]
3887 foreach p [lindex $parentlist $rm1] {
3888 if {[lsearch -exact $idlist $p] < 0} {
3889 set col [idcol $idlist $p $col]
3890 set idlist [linsert $idlist $col $p]
3891 # if not the first child, we have to insert a line going up
3892 if {$id ne [lindex $children($curview,$p) 0]} {
3893 makeupline $p $rm1 $row $col
3897 set id [lindex $displayorder $row]
3898 if {$row > $downarrowlen} {
3899 set termrow [expr {$row - $downarrowlen - 1}]
3900 foreach p [lindex $parentlist $termrow] {
3901 set i [lsearch -exact $idlist $p]
3902 if {$i < 0} continue
3903 set nr [nextuse $p $termrow]
3904 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3905 set idlist [lreplace $idlist $i $i]
3909 set col [lsearch -exact $idlist $id]
3910 if {$col < 0} {
3911 set col [idcol $idlist $id]
3912 set idlist [linsert $idlist $col $id]
3913 if {$children($curview,$id) ne {}} {
3914 makeupline $id $rm1 $row $col
3917 set r [expr {$row + $uparrowlen - 1}]
3918 if {$r < $commitidx($curview)} {
3919 set x $col
3920 foreach p [lindex $parentlist $r] {
3921 if {[lsearch -exact $idlist $p] >= 0} continue
3922 set fk [lindex $children($curview,$p) 0]
3923 if {[rowofcommit $fk] < $row} {
3924 set x [idcol $idlist $p $x]
3925 set idlist [linsert $idlist $x $p]
3928 if {[incr r] < $commitidx($curview)} {
3929 set p [lindex $displayorder $r]
3930 if {[lsearch -exact $idlist $p] < 0} {
3931 set fk [lindex $children($curview,$p) 0]
3932 if {$fk ne {} && [rowofcommit $fk] < $row} {
3933 set x [idcol $idlist $p $x]
3934 set idlist [linsert $idlist $x $p]
3940 if {$final && !$viewcomplete($curview) &&
3941 $row + $uparrowlen + $mingaplen + $downarrowlen
3942 >= $commitidx($curview)} {
3943 set final 0
3945 set l [llength $rowidlist]
3946 if {$row == $l} {
3947 lappend rowidlist $idlist
3948 lappend rowisopt 0
3949 lappend rowfinal $final
3950 } elseif {$row < $l} {
3951 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3952 lset rowidlist $row $idlist
3953 changedrow $row
3955 lset rowfinal $row $final
3956 } else {
3957 set pad [ntimes [expr {$row - $l}] {}]
3958 set rowidlist [concat $rowidlist $pad]
3959 lappend rowidlist $idlist
3960 set rowfinal [concat $rowfinal $pad]
3961 lappend rowfinal $final
3962 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3965 return $row
3968 proc changedrow {row} {
3969 global displayorder iddrawn rowisopt need_redisplay
3971 set l [llength $rowisopt]
3972 if {$row < $l} {
3973 lset rowisopt $row 0
3974 if {$row + 1 < $l} {
3975 lset rowisopt [expr {$row + 1}] 0
3976 if {$row + 2 < $l} {
3977 lset rowisopt [expr {$row + 2}] 0
3981 set id [lindex $displayorder $row]
3982 if {[info exists iddrawn($id)]} {
3983 set need_redisplay 1
3987 proc insert_pad {row col npad} {
3988 global rowidlist
3990 set pad [ntimes $npad {}]
3991 set idlist [lindex $rowidlist $row]
3992 set bef [lrange $idlist 0 [expr {$col - 1}]]
3993 set aft [lrange $idlist $col end]
3994 set i [lsearch -exact $aft {}]
3995 if {$i > 0} {
3996 set aft [lreplace $aft $i $i]
3998 lset rowidlist $row [concat $bef $pad $aft]
3999 changedrow $row
4002 proc optimize_rows {row col endrow} {
4003 global rowidlist rowisopt displayorder curview children
4005 if {$row < 1} {
4006 set row 1
4008 for {} {$row < $endrow} {incr row; set col 0} {
4009 if {[lindex $rowisopt $row]} continue
4010 set haspad 0
4011 set y0 [expr {$row - 1}]
4012 set ym [expr {$row - 2}]
4013 set idlist [lindex $rowidlist $row]
4014 set previdlist [lindex $rowidlist $y0]
4015 if {$idlist eq {} || $previdlist eq {}} continue
4016 if {$ym >= 0} {
4017 set pprevidlist [lindex $rowidlist $ym]
4018 if {$pprevidlist eq {}} continue
4019 } else {
4020 set pprevidlist {}
4022 set x0 -1
4023 set xm -1
4024 for {} {$col < [llength $idlist]} {incr col} {
4025 set id [lindex $idlist $col]
4026 if {[lindex $previdlist $col] eq $id} continue
4027 if {$id eq {}} {
4028 set haspad 1
4029 continue
4031 set x0 [lsearch -exact $previdlist $id]
4032 if {$x0 < 0} continue
4033 set z [expr {$x0 - $col}]
4034 set isarrow 0
4035 set z0 {}
4036 if {$ym >= 0} {
4037 set xm [lsearch -exact $pprevidlist $id]
4038 if {$xm >= 0} {
4039 set z0 [expr {$xm - $x0}]
4042 if {$z0 eq {}} {
4043 # if row y0 is the first child of $id then it's not an arrow
4044 if {[lindex $children($curview,$id) 0] ne
4045 [lindex $displayorder $y0]} {
4046 set isarrow 1
4049 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4050 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4051 set isarrow 1
4053 # Looking at lines from this row to the previous row,
4054 # make them go straight up if they end in an arrow on
4055 # the previous row; otherwise make them go straight up
4056 # or at 45 degrees.
4057 if {$z < -1 || ($z < 0 && $isarrow)} {
4058 # Line currently goes left too much;
4059 # insert pads in the previous row, then optimize it
4060 set npad [expr {-1 - $z + $isarrow}]
4061 insert_pad $y0 $x0 $npad
4062 if {$y0 > 0} {
4063 optimize_rows $y0 $x0 $row
4065 set previdlist [lindex $rowidlist $y0]
4066 set x0 [lsearch -exact $previdlist $id]
4067 set z [expr {$x0 - $col}]
4068 if {$z0 ne {}} {
4069 set pprevidlist [lindex $rowidlist $ym]
4070 set xm [lsearch -exact $pprevidlist $id]
4071 set z0 [expr {$xm - $x0}]
4073 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4074 # Line currently goes right too much;
4075 # insert pads in this line
4076 set npad [expr {$z - 1 + $isarrow}]
4077 insert_pad $row $col $npad
4078 set idlist [lindex $rowidlist $row]
4079 incr col $npad
4080 set z [expr {$x0 - $col}]
4081 set haspad 1
4083 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4084 # this line links to its first child on row $row-2
4085 set id [lindex $displayorder $ym]
4086 set xc [lsearch -exact $pprevidlist $id]
4087 if {$xc >= 0} {
4088 set z0 [expr {$xc - $x0}]
4091 # avoid lines jigging left then immediately right
4092 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4093 insert_pad $y0 $x0 1
4094 incr x0
4095 optimize_rows $y0 $x0 $row
4096 set previdlist [lindex $rowidlist $y0]
4099 if {!$haspad} {
4100 # Find the first column that doesn't have a line going right
4101 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4102 set id [lindex $idlist $col]
4103 if {$id eq {}} break
4104 set x0 [lsearch -exact $previdlist $id]
4105 if {$x0 < 0} {
4106 # check if this is the link to the first child
4107 set kid [lindex $displayorder $y0]
4108 if {[lindex $children($curview,$id) 0] eq $kid} {
4109 # it is, work out offset to child
4110 set x0 [lsearch -exact $previdlist $kid]
4113 if {$x0 <= $col} break
4115 # Insert a pad at that column as long as it has a line and
4116 # isn't the last column
4117 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4118 set idlist [linsert $idlist $col {}]
4119 lset rowidlist $row $idlist
4120 changedrow $row
4126 proc xc {row col} {
4127 global canvx0 linespc
4128 return [expr {$canvx0 + $col * $linespc}]
4131 proc yc {row} {
4132 global canvy0 linespc
4133 return [expr {$canvy0 + $row * $linespc}]
4136 proc linewidth {id} {
4137 global thickerline lthickness
4139 set wid $lthickness
4140 if {[info exists thickerline] && $id eq $thickerline} {
4141 set wid [expr {2 * $lthickness}]
4143 return $wid
4146 proc rowranges {id} {
4147 global curview children uparrowlen downarrowlen
4148 global rowidlist
4150 set kids $children($curview,$id)
4151 if {$kids eq {}} {
4152 return {}
4154 set ret {}
4155 lappend kids $id
4156 foreach child $kids {
4157 if {![commitinview $child $curview]} break
4158 set row [rowofcommit $child]
4159 if {![info exists prev]} {
4160 lappend ret [expr {$row + 1}]
4161 } else {
4162 if {$row <= $prevrow} {
4163 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4165 # see if the line extends the whole way from prevrow to row
4166 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4167 [lsearch -exact [lindex $rowidlist \
4168 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4169 # it doesn't, see where it ends
4170 set r [expr {$prevrow + $downarrowlen}]
4171 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4172 while {[incr r -1] > $prevrow &&
4173 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4174 } else {
4175 while {[incr r] <= $row &&
4176 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4177 incr r -1
4179 lappend ret $r
4180 # see where it starts up again
4181 set r [expr {$row - $uparrowlen}]
4182 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4183 while {[incr r] < $row &&
4184 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4185 } else {
4186 while {[incr r -1] >= $prevrow &&
4187 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4188 incr r
4190 lappend ret $r
4193 if {$child eq $id} {
4194 lappend ret $row
4196 set prev $child
4197 set prevrow $row
4199 return $ret
4202 proc drawlineseg {id row endrow arrowlow} {
4203 global rowidlist displayorder iddrawn linesegs
4204 global canv colormap linespc curview maxlinelen parentlist
4206 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4207 set le [expr {$row + 1}]
4208 set arrowhigh 1
4209 while {1} {
4210 set c [lsearch -exact [lindex $rowidlist $le] $id]
4211 if {$c < 0} {
4212 incr le -1
4213 break
4215 lappend cols $c
4216 set x [lindex $displayorder $le]
4217 if {$x eq $id} {
4218 set arrowhigh 0
4219 break
4221 if {[info exists iddrawn($x)] || $le == $endrow} {
4222 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4223 if {$c >= 0} {
4224 lappend cols $c
4225 set arrowhigh 0
4227 break
4229 incr le
4231 if {$le <= $row} {
4232 return $row
4235 set lines {}
4236 set i 0
4237 set joinhigh 0
4238 if {[info exists linesegs($id)]} {
4239 set lines $linesegs($id)
4240 foreach li $lines {
4241 set r0 [lindex $li 0]
4242 if {$r0 > $row} {
4243 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4244 set joinhigh 1
4246 break
4248 incr i
4251 set joinlow 0
4252 if {$i > 0} {
4253 set li [lindex $lines [expr {$i-1}]]
4254 set r1 [lindex $li 1]
4255 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4256 set joinlow 1
4260 set x [lindex $cols [expr {$le - $row}]]
4261 set xp [lindex $cols [expr {$le - 1 - $row}]]
4262 set dir [expr {$xp - $x}]
4263 if {$joinhigh} {
4264 set ith [lindex $lines $i 2]
4265 set coords [$canv coords $ith]
4266 set ah [$canv itemcget $ith -arrow]
4267 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4268 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4269 if {$x2 ne {} && $x - $x2 == $dir} {
4270 set coords [lrange $coords 0 end-2]
4272 } else {
4273 set coords [list [xc $le $x] [yc $le]]
4275 if {$joinlow} {
4276 set itl [lindex $lines [expr {$i-1}] 2]
4277 set al [$canv itemcget $itl -arrow]
4278 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4279 } elseif {$arrowlow} {
4280 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4281 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4282 set arrowlow 0
4285 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4286 for {set y $le} {[incr y -1] > $row} {} {
4287 set x $xp
4288 set xp [lindex $cols [expr {$y - 1 - $row}]]
4289 set ndir [expr {$xp - $x}]
4290 if {$dir != $ndir || $xp < 0} {
4291 lappend coords [xc $y $x] [yc $y]
4293 set dir $ndir
4295 if {!$joinlow} {
4296 if {$xp < 0} {
4297 # join parent line to first child
4298 set ch [lindex $displayorder $row]
4299 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4300 if {$xc < 0} {
4301 puts "oops: drawlineseg: child $ch not on row $row"
4302 } elseif {$xc != $x} {
4303 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4304 set d [expr {int(0.5 * $linespc)}]
4305 set x1 [xc $row $x]
4306 if {$xc < $x} {
4307 set x2 [expr {$x1 - $d}]
4308 } else {
4309 set x2 [expr {$x1 + $d}]
4311 set y2 [yc $row]
4312 set y1 [expr {$y2 + $d}]
4313 lappend coords $x1 $y1 $x2 $y2
4314 } elseif {$xc < $x - 1} {
4315 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4316 } elseif {$xc > $x + 1} {
4317 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4319 set x $xc
4321 lappend coords [xc $row $x] [yc $row]
4322 } else {
4323 set xn [xc $row $xp]
4324 set yn [yc $row]
4325 lappend coords $xn $yn
4327 if {!$joinhigh} {
4328 assigncolor $id
4329 set t [$canv create line $coords -width [linewidth $id] \
4330 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4331 $canv lower $t
4332 bindline $t $id
4333 set lines [linsert $lines $i [list $row $le $t]]
4334 } else {
4335 $canv coords $ith $coords
4336 if {$arrow ne $ah} {
4337 $canv itemconf $ith -arrow $arrow
4339 lset lines $i 0 $row
4341 } else {
4342 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4343 set ndir [expr {$xo - $xp}]
4344 set clow [$canv coords $itl]
4345 if {$dir == $ndir} {
4346 set clow [lrange $clow 2 end]
4348 set coords [concat $coords $clow]
4349 if {!$joinhigh} {
4350 lset lines [expr {$i-1}] 1 $le
4351 } else {
4352 # coalesce two pieces
4353 $canv delete $ith
4354 set b [lindex $lines [expr {$i-1}] 0]
4355 set e [lindex $lines $i 1]
4356 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4358 $canv coords $itl $coords
4359 if {$arrow ne $al} {
4360 $canv itemconf $itl -arrow $arrow
4364 set linesegs($id) $lines
4365 return $le
4368 proc drawparentlinks {id row} {
4369 global rowidlist canv colormap curview parentlist
4370 global idpos linespc
4372 set rowids [lindex $rowidlist $row]
4373 set col [lsearch -exact $rowids $id]
4374 if {$col < 0} return
4375 set olds [lindex $parentlist $row]
4376 set row2 [expr {$row + 1}]
4377 set x [xc $row $col]
4378 set y [yc $row]
4379 set y2 [yc $row2]
4380 set d [expr {int(0.5 * $linespc)}]
4381 set ymid [expr {$y + $d}]
4382 set ids [lindex $rowidlist $row2]
4383 # rmx = right-most X coord used
4384 set rmx 0
4385 foreach p $olds {
4386 set i [lsearch -exact $ids $p]
4387 if {$i < 0} {
4388 puts "oops, parent $p of $id not in list"
4389 continue
4391 set x2 [xc $row2 $i]
4392 if {$x2 > $rmx} {
4393 set rmx $x2
4395 set j [lsearch -exact $rowids $p]
4396 if {$j < 0} {
4397 # drawlineseg will do this one for us
4398 continue
4400 assigncolor $p
4401 # should handle duplicated parents here...
4402 set coords [list $x $y]
4403 if {$i != $col} {
4404 # if attaching to a vertical segment, draw a smaller
4405 # slant for visual distinctness
4406 if {$i == $j} {
4407 if {$i < $col} {
4408 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4409 } else {
4410 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4412 } elseif {$i < $col && $i < $j} {
4413 # segment slants towards us already
4414 lappend coords [xc $row $j] $y
4415 } else {
4416 if {$i < $col - 1} {
4417 lappend coords [expr {$x2 + $linespc}] $y
4418 } elseif {$i > $col + 1} {
4419 lappend coords [expr {$x2 - $linespc}] $y
4421 lappend coords $x2 $y2
4423 } else {
4424 lappend coords $x2 $y2
4426 set t [$canv create line $coords -width [linewidth $p] \
4427 -fill $colormap($p) -tags lines.$p]
4428 $canv lower $t
4429 bindline $t $p
4431 if {$rmx > [lindex $idpos($id) 1]} {
4432 lset idpos($id) 1 $rmx
4433 redrawtags $id
4437 proc drawlines {id} {
4438 global canv
4440 $canv itemconf lines.$id -width [linewidth $id]
4443 proc drawcmittext {id row col} {
4444 global linespc canv canv2 canv3 fgcolor curview
4445 global cmitlisted commitinfo rowidlist parentlist
4446 global rowtextx idpos idtags idheads idotherrefs
4447 global linehtag linentag linedtag selectedline
4448 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4450 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4451 set listed $cmitlisted($curview,$id)
4452 if {$id eq $nullid} {
4453 set ofill red
4454 } elseif {$id eq $nullid2} {
4455 set ofill green
4456 } else {
4457 set ofill [expr {$listed != 0 ? $listed == 2 ? "gray" : "blue" : "white"}]
4459 set x [xc $row $col]
4460 set y [yc $row]
4461 set orad [expr {$linespc / 3}]
4462 if {$listed <= 2} {
4463 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4464 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4465 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4466 } elseif {$listed == 3} {
4467 # triangle pointing left for left-side commits
4468 set t [$canv create polygon \
4469 [expr {$x - $orad}] $y \
4470 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4471 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4472 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4473 } else {
4474 # triangle pointing right for right-side commits
4475 set t [$canv create polygon \
4476 [expr {$x + $orad - 1}] $y \
4477 [expr {$x - $orad}] [expr {$y - $orad}] \
4478 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4479 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4481 $canv raise $t
4482 $canv bind $t <1> {selcanvline {} %x %y}
4483 set rmx [llength [lindex $rowidlist $row]]
4484 set olds [lindex $parentlist $row]
4485 if {$olds ne {}} {
4486 set nextids [lindex $rowidlist [expr {$row + 1}]]
4487 foreach p $olds {
4488 set i [lsearch -exact $nextids $p]
4489 if {$i > $rmx} {
4490 set rmx $i
4494 set xt [xc $row $rmx]
4495 set rowtextx($row) $xt
4496 set idpos($id) [list $x $xt $y]
4497 if {[info exists idtags($id)] || [info exists idheads($id)]
4498 || [info exists idotherrefs($id)]} {
4499 set xt [drawtags $id $x $xt $y]
4501 set headline [lindex $commitinfo($id) 0]
4502 set name [lindex $commitinfo($id) 1]
4503 set date [lindex $commitinfo($id) 2]
4504 set date [formatdate $date]
4505 set font mainfont
4506 set nfont mainfont
4507 set isbold [ishighlighted $id]
4508 if {$isbold > 0} {
4509 lappend boldrows $row
4510 set font mainfontbold
4511 if {$isbold > 1} {
4512 lappend boldnamerows $row
4513 set nfont mainfontbold
4516 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4517 -text $headline -font $font -tags text]
4518 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4519 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4520 -text $name -font $nfont -tags text]
4521 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4522 -text $date -font mainfont -tags text]
4523 if {[info exists selectedline] && $selectedline == $row} {
4524 make_secsel $row
4526 set xr [expr {$xt + [font measure $font $headline]}]
4527 if {$xr > $canvxmax} {
4528 set canvxmax $xr
4529 setcanvscroll
4533 proc drawcmitrow {row} {
4534 global displayorder rowidlist nrows_drawn
4535 global iddrawn markingmatches
4536 global commitinfo numcommits
4537 global filehighlight fhighlights findpattern nhighlights
4538 global hlview vhighlights
4539 global highlight_related rhighlights
4541 if {$row >= $numcommits} return
4543 set id [lindex $displayorder $row]
4544 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4545 askvhighlight $row $id
4547 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4548 askfilehighlight $row $id
4550 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4551 askfindhighlight $row $id
4553 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4554 askrelhighlight $row $id
4556 if {![info exists iddrawn($id)]} {
4557 set col [lsearch -exact [lindex $rowidlist $row] $id]
4558 if {$col < 0} {
4559 puts "oops, row $row id $id not in list"
4560 return
4562 if {![info exists commitinfo($id)]} {
4563 getcommit $id
4565 assigncolor $id
4566 drawcmittext $id $row $col
4567 set iddrawn($id) 1
4568 incr nrows_drawn
4570 if {$markingmatches} {
4571 markrowmatches $row $id
4575 proc drawcommits {row {endrow {}}} {
4576 global numcommits iddrawn displayorder curview need_redisplay
4577 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4579 if {$row < 0} {
4580 set row 0
4582 if {$endrow eq {}} {
4583 set endrow $row
4585 if {$endrow >= $numcommits} {
4586 set endrow [expr {$numcommits - 1}]
4589 set rl1 [expr {$row - $downarrowlen - 3}]
4590 if {$rl1 < 0} {
4591 set rl1 0
4593 set ro1 [expr {$row - 3}]
4594 if {$ro1 < 0} {
4595 set ro1 0
4597 set r2 [expr {$endrow + $uparrowlen + 3}]
4598 if {$r2 > $numcommits} {
4599 set r2 $numcommits
4601 for {set r $rl1} {$r < $r2} {incr r} {
4602 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4603 if {$rl1 < $r} {
4604 layoutrows $rl1 $r
4606 set rl1 [expr {$r + 1}]
4609 if {$rl1 < $r} {
4610 layoutrows $rl1 $r
4612 optimize_rows $ro1 0 $r2
4613 if {$need_redisplay || $nrows_drawn > 2000} {
4614 clear_display
4615 drawvisible
4618 # make the lines join to already-drawn rows either side
4619 set r [expr {$row - 1}]
4620 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4621 set r $row
4623 set er [expr {$endrow + 1}]
4624 if {$er >= $numcommits ||
4625 ![info exists iddrawn([lindex $displayorder $er])]} {
4626 set er $endrow
4628 for {} {$r <= $er} {incr r} {
4629 set id [lindex $displayorder $r]
4630 set wasdrawn [info exists iddrawn($id)]
4631 drawcmitrow $r
4632 if {$r == $er} break
4633 set nextid [lindex $displayorder [expr {$r + 1}]]
4634 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4635 drawparentlinks $id $r
4637 set rowids [lindex $rowidlist $r]
4638 foreach lid $rowids {
4639 if {$lid eq {}} continue
4640 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4641 if {$lid eq $id} {
4642 # see if this is the first child of any of its parents
4643 foreach p [lindex $parentlist $r] {
4644 if {[lsearch -exact $rowids $p] < 0} {
4645 # make this line extend up to the child
4646 set lineend($p) [drawlineseg $p $r $er 0]
4649 } else {
4650 set lineend($lid) [drawlineseg $lid $r $er 1]
4656 proc undolayout {row} {
4657 global uparrowlen mingaplen downarrowlen
4658 global rowidlist rowisopt rowfinal need_redisplay
4660 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4661 if {$r < 0} {
4662 set r 0
4664 if {[llength $rowidlist] > $r} {
4665 incr r -1
4666 set rowidlist [lrange $rowidlist 0 $r]
4667 set rowfinal [lrange $rowfinal 0 $r]
4668 set rowisopt [lrange $rowisopt 0 $r]
4669 set need_redisplay 1
4670 run drawvisible
4674 proc drawvisible {} {
4675 global canv linespc curview vrowmod selectedline targetrow targetid
4676 global need_redisplay cscroll numcommits
4678 set fs [$canv yview]
4679 set ymax [lindex [$canv cget -scrollregion] 3]
4680 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
4681 set f0 [lindex $fs 0]
4682 set f1 [lindex $fs 1]
4683 set y0 [expr {int($f0 * $ymax)}]
4684 set y1 [expr {int($f1 * $ymax)}]
4686 if {[info exists targetid]} {
4687 if {[commitinview $targetid $curview]} {
4688 set r [rowofcommit $targetid]
4689 if {$r != $targetrow} {
4690 # Fix up the scrollregion and change the scrolling position
4691 # now that our target row has moved.
4692 set diff [expr {($r - $targetrow) * $linespc}]
4693 set targetrow $r
4694 setcanvscroll
4695 set ymax [lindex [$canv cget -scrollregion] 3]
4696 incr y0 $diff
4697 incr y1 $diff
4698 set f0 [expr {$y0 / $ymax}]
4699 set f1 [expr {$y1 / $ymax}]
4700 allcanvs yview moveto $f0
4701 $cscroll set $f0 $f1
4702 set need_redisplay 1
4704 } else {
4705 unset targetid
4709 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4710 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4711 if {$endrow >= $vrowmod($curview)} {
4712 update_arcrows $curview
4714 if {[info exists selectedline] &&
4715 $row <= $selectedline && $selectedline <= $endrow} {
4716 set targetrow $selectedline
4717 } else {
4718 set targetrow [expr {int(($row + $endrow) / 2)}]
4720 if {$targetrow >= $numcommits} {
4721 set targetrow [expr {$numcommits - 1}]
4723 set targetid [commitonrow $targetrow]
4724 drawcommits $row $endrow
4727 proc clear_display {} {
4728 global iddrawn linesegs need_redisplay nrows_drawn
4729 global vhighlights fhighlights nhighlights rhighlights
4731 allcanvs delete all
4732 catch {unset iddrawn}
4733 catch {unset linesegs}
4734 catch {unset vhighlights}
4735 catch {unset fhighlights}
4736 catch {unset nhighlights}
4737 catch {unset rhighlights}
4738 set need_redisplay 0
4739 set nrows_drawn 0
4742 proc findcrossings {id} {
4743 global rowidlist parentlist numcommits displayorder
4745 set cross {}
4746 set ccross {}
4747 foreach {s e} [rowranges $id] {
4748 if {$e >= $numcommits} {
4749 set e [expr {$numcommits - 1}]
4751 if {$e <= $s} continue
4752 for {set row $e} {[incr row -1] >= $s} {} {
4753 set x [lsearch -exact [lindex $rowidlist $row] $id]
4754 if {$x < 0} break
4755 set olds [lindex $parentlist $row]
4756 set kid [lindex $displayorder $row]
4757 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4758 if {$kidx < 0} continue
4759 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4760 foreach p $olds {
4761 set px [lsearch -exact $nextrow $p]
4762 if {$px < 0} continue
4763 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4764 if {[lsearch -exact $ccross $p] >= 0} continue
4765 if {$x == $px + ($kidx < $px? -1: 1)} {
4766 lappend ccross $p
4767 } elseif {[lsearch -exact $cross $p] < 0} {
4768 lappend cross $p
4774 return [concat $ccross {{}} $cross]
4777 proc assigncolor {id} {
4778 global colormap colors nextcolor
4779 global parents children children curview
4781 if {[info exists colormap($id)]} return
4782 set ncolors [llength $colors]
4783 if {[info exists children($curview,$id)]} {
4784 set kids $children($curview,$id)
4785 } else {
4786 set kids {}
4788 if {[llength $kids] == 1} {
4789 set child [lindex $kids 0]
4790 if {[info exists colormap($child)]
4791 && [llength $parents($curview,$child)] == 1} {
4792 set colormap($id) $colormap($child)
4793 return
4796 set badcolors {}
4797 set origbad {}
4798 foreach x [findcrossings $id] {
4799 if {$x eq {}} {
4800 # delimiter between corner crossings and other crossings
4801 if {[llength $badcolors] >= $ncolors - 1} break
4802 set origbad $badcolors
4804 if {[info exists colormap($x)]
4805 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4806 lappend badcolors $colormap($x)
4809 if {[llength $badcolors] >= $ncolors} {
4810 set badcolors $origbad
4812 set origbad $badcolors
4813 if {[llength $badcolors] < $ncolors - 1} {
4814 foreach child $kids {
4815 if {[info exists colormap($child)]
4816 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4817 lappend badcolors $colormap($child)
4819 foreach p $parents($curview,$child) {
4820 if {[info exists colormap($p)]
4821 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4822 lappend badcolors $colormap($p)
4826 if {[llength $badcolors] >= $ncolors} {
4827 set badcolors $origbad
4830 for {set i 0} {$i <= $ncolors} {incr i} {
4831 set c [lindex $colors $nextcolor]
4832 if {[incr nextcolor] >= $ncolors} {
4833 set nextcolor 0
4835 if {[lsearch -exact $badcolors $c]} break
4837 set colormap($id) $c
4840 proc bindline {t id} {
4841 global canv
4843 $canv bind $t <Enter> "lineenter %x %y $id"
4844 $canv bind $t <Motion> "linemotion %x %y $id"
4845 $canv bind $t <Leave> "lineleave $id"
4846 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4849 proc drawtags {id x xt y1} {
4850 global idtags idheads idotherrefs mainhead
4851 global linespc lthickness
4852 global canv rowtextx curview fgcolor bgcolor
4854 set marks {}
4855 set ntags 0
4856 set nheads 0
4857 if {[info exists idtags($id)]} {
4858 set marks $idtags($id)
4859 set ntags [llength $marks]
4861 if {[info exists idheads($id)]} {
4862 set marks [concat $marks $idheads($id)]
4863 set nheads [llength $idheads($id)]
4865 if {[info exists idotherrefs($id)]} {
4866 set marks [concat $marks $idotherrefs($id)]
4868 if {$marks eq {}} {
4869 return $xt
4872 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4873 set yt [expr {$y1 - 0.5 * $linespc}]
4874 set yb [expr {$yt + $linespc - 1}]
4875 set xvals {}
4876 set wvals {}
4877 set i -1
4878 foreach tag $marks {
4879 incr i
4880 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4881 set wid [font measure mainfontbold $tag]
4882 } else {
4883 set wid [font measure mainfont $tag]
4885 lappend xvals $xt
4886 lappend wvals $wid
4887 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4889 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4890 -width $lthickness -fill black -tags tag.$id]
4891 $canv lower $t
4892 foreach tag $marks x $xvals wid $wvals {
4893 set xl [expr {$x + $delta}]
4894 set xr [expr {$x + $delta + $wid + $lthickness}]
4895 set font mainfont
4896 if {[incr ntags -1] >= 0} {
4897 # draw a tag
4898 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4899 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4900 -width 1 -outline black -fill yellow -tags tag.$id]
4901 $canv bind $t <1> [list showtag $tag 1]
4902 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4903 } else {
4904 # draw a head or other ref
4905 if {[incr nheads -1] >= 0} {
4906 set col green
4907 if {$tag eq $mainhead} {
4908 set font mainfontbold
4910 } else {
4911 set col "#ddddff"
4913 set xl [expr {$xl - $delta/2}]
4914 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4915 -width 1 -outline black -fill $col -tags tag.$id
4916 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4917 set rwid [font measure mainfont $remoteprefix]
4918 set xi [expr {$x + 1}]
4919 set yti [expr {$yt + 1}]
4920 set xri [expr {$x + $rwid}]
4921 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4922 -width 0 -fill "#ffddaa" -tags tag.$id
4925 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4926 -font $font -tags [list tag.$id text]]
4927 if {$ntags >= 0} {
4928 $canv bind $t <1> [list showtag $tag 1]
4929 } elseif {$nheads >= 0} {
4930 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4933 return $xt
4936 proc xcoord {i level ln} {
4937 global canvx0 xspc1 xspc2
4939 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4940 if {$i > 0 && $i == $level} {
4941 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4942 } elseif {$i > $level} {
4943 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4945 return $x
4948 proc show_status {msg} {
4949 global canv fgcolor
4951 clear_display
4952 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4953 -tags text -fill $fgcolor
4956 # Don't change the text pane cursor if it is currently the hand cursor,
4957 # showing that we are over a sha1 ID link.
4958 proc settextcursor {c} {
4959 global ctext curtextcursor
4961 if {[$ctext cget -cursor] == $curtextcursor} {
4962 $ctext config -cursor $c
4964 set curtextcursor $c
4967 proc nowbusy {what {name {}}} {
4968 global isbusy busyname statusw
4970 if {[array names isbusy] eq {}} {
4971 . config -cursor watch
4972 settextcursor watch
4974 set isbusy($what) 1
4975 set busyname($what) $name
4976 if {$name ne {}} {
4977 $statusw conf -text $name
4981 proc notbusy {what} {
4982 global isbusy maincursor textcursor busyname statusw
4984 catch {
4985 unset isbusy($what)
4986 if {$busyname($what) ne {} &&
4987 [$statusw cget -text] eq $busyname($what)} {
4988 $statusw conf -text {}
4991 if {[array names isbusy] eq {}} {
4992 . config -cursor $maincursor
4993 settextcursor $textcursor
4997 proc findmatches {f} {
4998 global findtype findstring
4999 if {$findtype == [mc "Regexp"]} {
5000 set matches [regexp -indices -all -inline $findstring $f]
5001 } else {
5002 set fs $findstring
5003 if {$findtype == [mc "IgnCase"]} {
5004 set f [string tolower $f]
5005 set fs [string tolower $fs]
5007 set matches {}
5008 set i 0
5009 set l [string length $fs]
5010 while {[set j [string first $fs $f $i]] >= 0} {
5011 lappend matches [list $j [expr {$j+$l-1}]]
5012 set i [expr {$j + $l}]
5015 return $matches
5018 proc dofind {{dirn 1} {wrap 1}} {
5019 global findstring findstartline findcurline selectedline numcommits
5020 global gdttype filehighlight fh_serial find_dirn findallowwrap
5022 if {[info exists find_dirn]} {
5023 if {$find_dirn == $dirn} return
5024 stopfinding
5026 focus .
5027 if {$findstring eq {} || $numcommits == 0} return
5028 if {![info exists selectedline]} {
5029 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5030 } else {
5031 set findstartline $selectedline
5033 set findcurline $findstartline
5034 nowbusy finding [mc "Searching"]
5035 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5036 after cancel do_file_hl $fh_serial
5037 do_file_hl $fh_serial
5039 set find_dirn $dirn
5040 set findallowwrap $wrap
5041 run findmore
5044 proc stopfinding {} {
5045 global find_dirn findcurline fprogcoord
5047 if {[info exists find_dirn]} {
5048 unset find_dirn
5049 unset findcurline
5050 notbusy finding
5051 set fprogcoord 0
5052 adjustprogress
5056 proc findmore {} {
5057 global commitdata commitinfo numcommits findpattern findloc
5058 global findstartline findcurline findallowwrap
5059 global find_dirn gdttype fhighlights fprogcoord
5060 global curview varcorder vrownum varccommits vrowmod
5062 if {![info exists find_dirn]} {
5063 return 0
5065 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5066 set l $findcurline
5067 set moretodo 0
5068 if {$find_dirn > 0} {
5069 incr l
5070 if {$l >= $numcommits} {
5071 set l 0
5073 if {$l <= $findstartline} {
5074 set lim [expr {$findstartline + 1}]
5075 } else {
5076 set lim $numcommits
5077 set moretodo $findallowwrap
5079 } else {
5080 if {$l == 0} {
5081 set l $numcommits
5083 incr l -1
5084 if {$l >= $findstartline} {
5085 set lim [expr {$findstartline - 1}]
5086 } else {
5087 set lim -1
5088 set moretodo $findallowwrap
5091 set n [expr {($lim - $l) * $find_dirn}]
5092 if {$n > 500} {
5093 set n 500
5094 set moretodo 1
5096 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5097 update_arcrows $curview
5099 set found 0
5100 set domore 1
5101 set ai [bsearch $vrownum($curview) $l]
5102 set a [lindex $varcorder($curview) $ai]
5103 set arow [lindex $vrownum($curview) $ai]
5104 set ids [lindex $varccommits($curview,$a)]
5105 set arowend [expr {$arow + [llength $ids]}]
5106 if {$gdttype eq [mc "containing:"]} {
5107 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5108 if {$l < $arow || $l >= $arowend} {
5109 incr ai $find_dirn
5110 set a [lindex $varcorder($curview) $ai]
5111 set arow [lindex $vrownum($curview) $ai]
5112 set ids [lindex $varccommits($curview,$a)]
5113 set arowend [expr {$arow + [llength $ids]}]
5115 set id [lindex $ids [expr {$l - $arow}]]
5116 # shouldn't happen unless git log doesn't give all the commits...
5117 if {![info exists commitdata($id)] ||
5118 ![doesmatch $commitdata($id)]} {
5119 continue
5121 if {![info exists commitinfo($id)]} {
5122 getcommit $id
5124 set info $commitinfo($id)
5125 foreach f $info ty $fldtypes {
5126 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5127 [doesmatch $f]} {
5128 set found 1
5129 break
5132 if {$found} break
5134 } else {
5135 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5136 if {$l < $arow || $l >= $arowend} {
5137 incr ai $find_dirn
5138 set a [lindex $varcorder($curview) $ai]
5139 set arow [lindex $vrownum($curview) $ai]
5140 set ids [lindex $varccommits($curview,$a)]
5141 set arowend [expr {$arow + [llength $ids]}]
5143 set id [lindex $ids [expr {$l - $arow}]]
5144 if {![info exists fhighlights($id)]} {
5145 # this sets fhighlights($id) to -1
5146 askfilehighlight $l $id
5148 if {$fhighlights($id) > 0} {
5149 set found $domore
5150 break
5152 if {$fhighlights($id) < 0} {
5153 if {$domore} {
5154 set domore 0
5155 set findcurline [expr {$l - $find_dirn}]
5160 if {$found || ($domore && !$moretodo)} {
5161 unset findcurline
5162 unset find_dirn
5163 notbusy finding
5164 set fprogcoord 0
5165 adjustprogress
5166 if {$found} {
5167 findselectline $l
5168 } else {
5169 bell
5171 return 0
5173 if {!$domore} {
5174 flushhighlights
5175 } else {
5176 set findcurline [expr {$l - $find_dirn}]
5178 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5179 if {$n < 0} {
5180 incr n $numcommits
5182 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5183 adjustprogress
5184 return $domore
5187 proc findselectline {l} {
5188 global findloc commentend ctext findcurline markingmatches gdttype
5190 set markingmatches 1
5191 set findcurline $l
5192 selectline $l 1
5193 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5194 # highlight the matches in the comments
5195 set f [$ctext get 1.0 $commentend]
5196 set matches [findmatches $f]
5197 foreach match $matches {
5198 set start [lindex $match 0]
5199 set end [expr {[lindex $match 1] + 1}]
5200 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5203 drawvisible
5206 # mark the bits of a headline or author that match a find string
5207 proc markmatches {canv l str tag matches font row} {
5208 global selectedline
5210 set bbox [$canv bbox $tag]
5211 set x0 [lindex $bbox 0]
5212 set y0 [lindex $bbox 1]
5213 set y1 [lindex $bbox 3]
5214 foreach match $matches {
5215 set start [lindex $match 0]
5216 set end [lindex $match 1]
5217 if {$start > $end} continue
5218 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5219 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5220 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5221 [expr {$x0+$xlen+2}] $y1 \
5222 -outline {} -tags [list match$l matches] -fill yellow]
5223 $canv lower $t
5224 if {[info exists selectedline] && $row == $selectedline} {
5225 $canv raise $t secsel
5230 proc unmarkmatches {} {
5231 global markingmatches
5233 allcanvs delete matches
5234 set markingmatches 0
5235 stopfinding
5238 proc selcanvline {w x y} {
5239 global canv canvy0 ctext linespc
5240 global rowtextx
5241 set ymax [lindex [$canv cget -scrollregion] 3]
5242 if {$ymax == {}} return
5243 set yfrac [lindex [$canv yview] 0]
5244 set y [expr {$y + $yfrac * $ymax}]
5245 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5246 if {$l < 0} {
5247 set l 0
5249 if {$w eq $canv} {
5250 set xmax [lindex [$canv cget -scrollregion] 2]
5251 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5252 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5254 unmarkmatches
5255 selectline $l 1
5258 proc commit_descriptor {p} {
5259 global commitinfo
5260 if {![info exists commitinfo($p)]} {
5261 getcommit $p
5263 set l "..."
5264 if {[llength $commitinfo($p)] > 1} {
5265 set l [lindex $commitinfo($p) 0]
5267 return "$p ($l)\n"
5270 # append some text to the ctext widget, and make any SHA1 ID
5271 # that we know about be a clickable link.
5272 proc appendwithlinks {text tags} {
5273 global ctext linknum curview pendinglinks
5275 set start [$ctext index "end - 1c"]
5276 $ctext insert end $text $tags
5277 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5278 foreach l $links {
5279 set s [lindex $l 0]
5280 set e [lindex $l 1]
5281 set linkid [string range $text $s $e]
5282 incr e
5283 $ctext tag delete link$linknum
5284 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5285 setlink $linkid link$linknum
5286 incr linknum
5290 proc setlink {id lk} {
5291 global curview ctext pendinglinks commitinterest
5293 if {[commitinview $id $curview]} {
5294 $ctext tag conf $lk -foreground blue -underline 1
5295 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5296 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5297 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5298 } else {
5299 lappend pendinglinks($id) $lk
5300 lappend commitinterest($id) {makelink %I}
5304 proc makelink {id} {
5305 global pendinglinks
5307 if {![info exists pendinglinks($id)]} return
5308 foreach lk $pendinglinks($id) {
5309 setlink $id $lk
5311 unset pendinglinks($id)
5314 proc linkcursor {w inc} {
5315 global linkentercount curtextcursor
5317 if {[incr linkentercount $inc] > 0} {
5318 $w configure -cursor hand2
5319 } else {
5320 $w configure -cursor $curtextcursor
5321 if {$linkentercount < 0} {
5322 set linkentercount 0
5327 proc viewnextline {dir} {
5328 global canv linespc
5330 $canv delete hover
5331 set ymax [lindex [$canv cget -scrollregion] 3]
5332 set wnow [$canv yview]
5333 set wtop [expr {[lindex $wnow 0] * $ymax}]
5334 set newtop [expr {$wtop + $dir * $linespc}]
5335 if {$newtop < 0} {
5336 set newtop 0
5337 } elseif {$newtop > $ymax} {
5338 set newtop $ymax
5340 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5343 # add a list of tag or branch names at position pos
5344 # returns the number of names inserted
5345 proc appendrefs {pos ids var} {
5346 global ctext linknum curview $var maxrefs
5348 if {[catch {$ctext index $pos}]} {
5349 return 0
5351 $ctext conf -state normal
5352 $ctext delete $pos "$pos lineend"
5353 set tags {}
5354 foreach id $ids {
5355 foreach tag [set $var\($id\)] {
5356 lappend tags [list $tag $id]
5359 if {[llength $tags] > $maxrefs} {
5360 $ctext insert $pos "many ([llength $tags])"
5361 } else {
5362 set tags [lsort -index 0 -decreasing $tags]
5363 set sep {}
5364 foreach ti $tags {
5365 set id [lindex $ti 1]
5366 set lk link$linknum
5367 incr linknum
5368 $ctext tag delete $lk
5369 $ctext insert $pos $sep
5370 $ctext insert $pos [lindex $ti 0] $lk
5371 setlink $id $lk
5372 set sep ", "
5375 $ctext conf -state disabled
5376 return [llength $tags]
5379 # called when we have finished computing the nearby tags
5380 proc dispneartags {delay} {
5381 global selectedline currentid showneartags tagphase
5383 if {![info exists selectedline] || !$showneartags} return
5384 after cancel dispnexttag
5385 if {$delay} {
5386 after 200 dispnexttag
5387 set tagphase -1
5388 } else {
5389 after idle dispnexttag
5390 set tagphase 0
5394 proc dispnexttag {} {
5395 global selectedline currentid showneartags tagphase ctext
5397 if {![info exists selectedline] || !$showneartags} return
5398 switch -- $tagphase {
5400 set dtags [desctags $currentid]
5401 if {$dtags ne {}} {
5402 appendrefs precedes $dtags idtags
5406 set atags [anctags $currentid]
5407 if {$atags ne {}} {
5408 appendrefs follows $atags idtags
5412 set dheads [descheads $currentid]
5413 if {$dheads ne {}} {
5414 if {[appendrefs branch $dheads idheads] > 1
5415 && [$ctext get "branch -3c"] eq "h"} {
5416 # turn "Branch" into "Branches"
5417 $ctext conf -state normal
5418 $ctext insert "branch -2c" "es"
5419 $ctext conf -state disabled
5424 if {[incr tagphase] <= 2} {
5425 after idle dispnexttag
5429 proc make_secsel {l} {
5430 global linehtag linentag linedtag canv canv2 canv3
5432 if {![info exists linehtag($l)]} return
5433 $canv delete secsel
5434 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5435 -tags secsel -fill [$canv cget -selectbackground]]
5436 $canv lower $t
5437 $canv2 delete secsel
5438 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5439 -tags secsel -fill [$canv2 cget -selectbackground]]
5440 $canv2 lower $t
5441 $canv3 delete secsel
5442 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5443 -tags secsel -fill [$canv3 cget -selectbackground]]
5444 $canv3 lower $t
5447 proc selectline {l isnew} {
5448 global canv ctext commitinfo selectedline
5449 global canvy0 linespc parents children curview
5450 global currentid sha1entry
5451 global commentend idtags linknum
5452 global mergemax numcommits pending_select
5453 global cmitmode showneartags allcommits
5454 global targetrow targetid
5456 catch {unset pending_select}
5457 $canv delete hover
5458 normalline
5459 unsel_reflist
5460 stopfinding
5461 if {$l < 0 || $l >= $numcommits} return
5462 set y [expr {$canvy0 + $l * $linespc}]
5463 set ymax [lindex [$canv cget -scrollregion] 3]
5464 set ytop [expr {$y - $linespc - 1}]
5465 set ybot [expr {$y + $linespc + 1}]
5466 set wnow [$canv yview]
5467 set wtop [expr {[lindex $wnow 0] * $ymax}]
5468 set wbot [expr {[lindex $wnow 1] * $ymax}]
5469 set wh [expr {$wbot - $wtop}]
5470 set newtop $wtop
5471 if {$ytop < $wtop} {
5472 if {$ybot < $wtop} {
5473 set newtop [expr {$y - $wh / 2.0}]
5474 } else {
5475 set newtop $ytop
5476 if {$newtop > $wtop - $linespc} {
5477 set newtop [expr {$wtop - $linespc}]
5480 } elseif {$ybot > $wbot} {
5481 if {$ytop > $wbot} {
5482 set newtop [expr {$y - $wh / 2.0}]
5483 } else {
5484 set newtop [expr {$ybot - $wh}]
5485 if {$newtop < $wtop + $linespc} {
5486 set newtop [expr {$wtop + $linespc}]
5490 if {$newtop != $wtop} {
5491 if {$newtop < 0} {
5492 set newtop 0
5494 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5495 drawvisible
5498 make_secsel $l
5500 set id [commitonrow $l]
5501 if {$isnew} {
5502 addtohistory [list selbyid $id]
5505 set selectedline $l
5506 set currentid $id
5507 set targetid $id
5508 set targetrow $l
5509 $sha1entry delete 0 end
5510 $sha1entry insert 0 $id
5511 $sha1entry selection from 0
5512 $sha1entry selection to end
5513 rhighlight_sel $id
5515 $ctext conf -state normal
5516 clear_ctext
5517 set linknum 0
5518 set info $commitinfo($id)
5519 set date [formatdate [lindex $info 2]]
5520 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5521 set date [formatdate [lindex $info 4]]
5522 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5523 if {[info exists idtags($id)]} {
5524 $ctext insert end [mc "Tags:"]
5525 foreach tag $idtags($id) {
5526 $ctext insert end " $tag"
5528 $ctext insert end "\n"
5531 set headers {}
5532 set olds $parents($curview,$id)
5533 if {[llength $olds] > 1} {
5534 set np 0
5535 foreach p $olds {
5536 if {$np >= $mergemax} {
5537 set tag mmax
5538 } else {
5539 set tag m$np
5541 $ctext insert end "[mc "Parent"]: " $tag
5542 appendwithlinks [commit_descriptor $p] {}
5543 incr np
5545 } else {
5546 foreach p $olds {
5547 append headers "[mc "Parent"]: [commit_descriptor $p]"
5551 foreach c $children($curview,$id) {
5552 append headers "[mc "Child"]: [commit_descriptor $c]"
5555 # make anything that looks like a SHA1 ID be a clickable link
5556 appendwithlinks $headers {}
5557 if {$showneartags} {
5558 if {![info exists allcommits]} {
5559 getallcommits
5561 $ctext insert end "[mc "Branch"]: "
5562 $ctext mark set branch "end -1c"
5563 $ctext mark gravity branch left
5564 $ctext insert end "\n[mc "Follows"]: "
5565 $ctext mark set follows "end -1c"
5566 $ctext mark gravity follows left
5567 $ctext insert end "\n[mc "Precedes"]: "
5568 $ctext mark set precedes "end -1c"
5569 $ctext mark gravity precedes left
5570 $ctext insert end "\n"
5571 dispneartags 1
5573 $ctext insert end "\n"
5574 set comment [lindex $info 5]
5575 if {[string first "\r" $comment] >= 0} {
5576 set comment [string map {"\r" "\n "} $comment]
5578 appendwithlinks $comment {comment}
5580 $ctext tag remove found 1.0 end
5581 $ctext conf -state disabled
5582 set commentend [$ctext index "end - 1c"]
5584 init_flist [mc "Comments"]
5585 if {$cmitmode eq "tree"} {
5586 gettree $id
5587 } elseif {[llength $olds] <= 1} {
5588 startdiff $id
5589 } else {
5590 mergediff $id
5594 proc selfirstline {} {
5595 unmarkmatches
5596 selectline 0 1
5599 proc sellastline {} {
5600 global numcommits
5601 unmarkmatches
5602 set l [expr {$numcommits - 1}]
5603 selectline $l 1
5606 proc selnextline {dir} {
5607 global selectedline
5608 focus .
5609 if {![info exists selectedline]} return
5610 set l [expr {$selectedline + $dir}]
5611 unmarkmatches
5612 selectline $l 1
5615 proc selnextpage {dir} {
5616 global canv linespc selectedline numcommits
5618 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5619 if {$lpp < 1} {
5620 set lpp 1
5622 allcanvs yview scroll [expr {$dir * $lpp}] units
5623 drawvisible
5624 if {![info exists selectedline]} return
5625 set l [expr {$selectedline + $dir * $lpp}]
5626 if {$l < 0} {
5627 set l 0
5628 } elseif {$l >= $numcommits} {
5629 set l [expr $numcommits - 1]
5631 unmarkmatches
5632 selectline $l 1
5635 proc unselectline {} {
5636 global selectedline currentid
5638 catch {unset selectedline}
5639 catch {unset currentid}
5640 allcanvs delete secsel
5641 rhighlight_none
5644 proc reselectline {} {
5645 global selectedline
5647 if {[info exists selectedline]} {
5648 selectline $selectedline 0
5652 proc addtohistory {cmd} {
5653 global history historyindex curview
5655 set elt [list $curview $cmd]
5656 if {$historyindex > 0
5657 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5658 return
5661 if {$historyindex < [llength $history]} {
5662 set history [lreplace $history $historyindex end $elt]
5663 } else {
5664 lappend history $elt
5666 incr historyindex
5667 if {$historyindex > 1} {
5668 .tf.bar.leftbut conf -state normal
5669 } else {
5670 .tf.bar.leftbut conf -state disabled
5672 .tf.bar.rightbut conf -state disabled
5675 proc godo {elt} {
5676 global curview
5678 set view [lindex $elt 0]
5679 set cmd [lindex $elt 1]
5680 if {$curview != $view} {
5681 showview $view
5683 eval $cmd
5686 proc goback {} {
5687 global history historyindex
5688 focus .
5690 if {$historyindex > 1} {
5691 incr historyindex -1
5692 godo [lindex $history [expr {$historyindex - 1}]]
5693 .tf.bar.rightbut conf -state normal
5695 if {$historyindex <= 1} {
5696 .tf.bar.leftbut conf -state disabled
5700 proc goforw {} {
5701 global history historyindex
5702 focus .
5704 if {$historyindex < [llength $history]} {
5705 set cmd [lindex $history $historyindex]
5706 incr historyindex
5707 godo $cmd
5708 .tf.bar.leftbut conf -state normal
5710 if {$historyindex >= [llength $history]} {
5711 .tf.bar.rightbut conf -state disabled
5715 proc gettree {id} {
5716 global treefilelist treeidlist diffids diffmergeid treepending
5717 global nullid nullid2
5719 set diffids $id
5720 catch {unset diffmergeid}
5721 if {![info exists treefilelist($id)]} {
5722 if {![info exists treepending]} {
5723 if {$id eq $nullid} {
5724 set cmd [list | git ls-files]
5725 } elseif {$id eq $nullid2} {
5726 set cmd [list | git ls-files --stage -t]
5727 } else {
5728 set cmd [list | git ls-tree -r $id]
5730 if {[catch {set gtf [open $cmd r]}]} {
5731 return
5733 set treepending $id
5734 set treefilelist($id) {}
5735 set treeidlist($id) {}
5736 fconfigure $gtf -blocking 0
5737 filerun $gtf [list gettreeline $gtf $id]
5739 } else {
5740 setfilelist $id
5744 proc gettreeline {gtf id} {
5745 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5747 set nl 0
5748 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5749 if {$diffids eq $nullid} {
5750 set fname $line
5751 } else {
5752 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5753 set i [string first "\t" $line]
5754 if {$i < 0} continue
5755 set sha1 [lindex $line 2]
5756 set fname [string range $line [expr {$i+1}] end]
5757 if {[string index $fname 0] eq "\""} {
5758 set fname [lindex $fname 0]
5760 lappend treeidlist($id) $sha1
5762 lappend treefilelist($id) $fname
5764 if {![eof $gtf]} {
5765 return [expr {$nl >= 1000? 2: 1}]
5767 close $gtf
5768 unset treepending
5769 if {$cmitmode ne "tree"} {
5770 if {![info exists diffmergeid]} {
5771 gettreediffs $diffids
5773 } elseif {$id ne $diffids} {
5774 gettree $diffids
5775 } else {
5776 setfilelist $id
5778 return 0
5781 proc showfile {f} {
5782 global treefilelist treeidlist diffids nullid nullid2
5783 global ctext commentend
5785 set i [lsearch -exact $treefilelist($diffids) $f]
5786 if {$i < 0} {
5787 puts "oops, $f not in list for id $diffids"
5788 return
5790 if {$diffids eq $nullid} {
5791 if {[catch {set bf [open $f r]} err]} {
5792 puts "oops, can't read $f: $err"
5793 return
5795 } else {
5796 set blob [lindex $treeidlist($diffids) $i]
5797 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5798 puts "oops, error reading blob $blob: $err"
5799 return
5802 fconfigure $bf -blocking 0
5803 filerun $bf [list getblobline $bf $diffids]
5804 $ctext config -state normal
5805 clear_ctext $commentend
5806 $ctext insert end "\n"
5807 $ctext insert end "$f\n" filesep
5808 $ctext config -state disabled
5809 $ctext yview $commentend
5810 settabs 0
5813 proc getblobline {bf id} {
5814 global diffids cmitmode ctext
5816 if {$id ne $diffids || $cmitmode ne "tree"} {
5817 catch {close $bf}
5818 return 0
5820 $ctext config -state normal
5821 set nl 0
5822 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5823 $ctext insert end "$line\n"
5825 if {[eof $bf]} {
5826 # delete last newline
5827 $ctext delete "end - 2c" "end - 1c"
5828 close $bf
5829 return 0
5831 $ctext config -state disabled
5832 return [expr {$nl >= 1000? 2: 1}]
5835 proc mergediff {id} {
5836 global diffmergeid mdifffd
5837 global diffids
5838 global parents
5839 global diffcontext
5840 global limitdiffs viewfiles curview
5842 set diffmergeid $id
5843 set diffids $id
5844 # this doesn't seem to actually affect anything...
5845 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
5846 if {$limitdiffs && $viewfiles($curview) ne {}} {
5847 set cmd [concat $cmd -- $viewfiles($curview)]
5849 if {[catch {set mdf [open $cmd r]} err]} {
5850 error_popup "[mc "Error getting merge diffs:"] $err"
5851 return
5853 fconfigure $mdf -blocking 0
5854 set mdifffd($id) $mdf
5855 set np [llength $parents($curview,$id)]
5856 settabs $np
5857 filerun $mdf [list getmergediffline $mdf $id $np]
5860 proc getmergediffline {mdf id np} {
5861 global diffmergeid ctext cflist mergemax
5862 global difffilestart mdifffd
5864 $ctext conf -state normal
5865 set nr 0
5866 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5867 if {![info exists diffmergeid] || $id != $diffmergeid
5868 || $mdf != $mdifffd($id)} {
5869 close $mdf
5870 return 0
5872 if {[regexp {^diff --cc (.*)} $line match fname]} {
5873 # start of a new file
5874 $ctext insert end "\n"
5875 set here [$ctext index "end - 1c"]
5876 lappend difffilestart $here
5877 add_flist [list $fname]
5878 set l [expr {(78 - [string length $fname]) / 2}]
5879 set pad [string range "----------------------------------------" 1 $l]
5880 $ctext insert end "$pad $fname $pad\n" filesep
5881 } elseif {[regexp {^@@} $line]} {
5882 $ctext insert end "$line\n" hunksep
5883 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5884 # do nothing
5885 } else {
5886 # parse the prefix - one ' ', '-' or '+' for each parent
5887 set spaces {}
5888 set minuses {}
5889 set pluses {}
5890 set isbad 0
5891 for {set j 0} {$j < $np} {incr j} {
5892 set c [string range $line $j $j]
5893 if {$c == " "} {
5894 lappend spaces $j
5895 } elseif {$c == "-"} {
5896 lappend minuses $j
5897 } elseif {$c == "+"} {
5898 lappend pluses $j
5899 } else {
5900 set isbad 1
5901 break
5904 set tags {}
5905 set num {}
5906 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5907 # line doesn't appear in result, parents in $minuses have the line
5908 set num [lindex $minuses 0]
5909 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5910 # line appears in result, parents in $pluses don't have the line
5911 lappend tags mresult
5912 set num [lindex $spaces 0]
5914 if {$num ne {}} {
5915 if {$num >= $mergemax} {
5916 set num "max"
5918 lappend tags m$num
5920 $ctext insert end "$line\n" $tags
5923 $ctext conf -state disabled
5924 if {[eof $mdf]} {
5925 close $mdf
5926 return 0
5928 return [expr {$nr >= 1000? 2: 1}]
5931 proc startdiff {ids} {
5932 global treediffs diffids treepending diffmergeid nullid nullid2
5934 settabs 1
5935 set diffids $ids
5936 catch {unset diffmergeid}
5937 if {![info exists treediffs($ids)] ||
5938 [lsearch -exact $ids $nullid] >= 0 ||
5939 [lsearch -exact $ids $nullid2] >= 0} {
5940 if {![info exists treepending]} {
5941 gettreediffs $ids
5943 } else {
5944 addtocflist $ids
5948 proc path_filter {filter name} {
5949 foreach p $filter {
5950 set l [string length $p]
5951 if {[string index $p end] eq "/"} {
5952 if {[string compare -length $l $p $name] == 0} {
5953 return 1
5955 } else {
5956 if {[string compare -length $l $p $name] == 0 &&
5957 ([string length $name] == $l ||
5958 [string index $name $l] eq "/")} {
5959 return 1
5963 return 0
5966 proc addtocflist {ids} {
5967 global treediffs
5969 add_flist $treediffs($ids)
5970 getblobdiffs $ids
5973 proc diffcmd {ids flags} {
5974 global nullid nullid2
5976 set i [lsearch -exact $ids $nullid]
5977 set j [lsearch -exact $ids $nullid2]
5978 if {$i >= 0} {
5979 if {[llength $ids] > 1 && $j < 0} {
5980 # comparing working directory with some specific revision
5981 set cmd [concat | git diff-index $flags]
5982 if {$i == 0} {
5983 lappend cmd -R [lindex $ids 1]
5984 } else {
5985 lappend cmd [lindex $ids 0]
5987 } else {
5988 # comparing working directory with index
5989 set cmd [concat | git diff-files $flags]
5990 if {$j == 1} {
5991 lappend cmd -R
5994 } elseif {$j >= 0} {
5995 set cmd [concat | git diff-index --cached $flags]
5996 if {[llength $ids] > 1} {
5997 # comparing index with specific revision
5998 if {$i == 0} {
5999 lappend cmd -R [lindex $ids 1]
6000 } else {
6001 lappend cmd [lindex $ids 0]
6003 } else {
6004 # comparing index with HEAD
6005 lappend cmd HEAD
6007 } else {
6008 set cmd [concat | git diff-tree -r $flags $ids]
6010 return $cmd
6013 proc gettreediffs {ids} {
6014 global treediff treepending
6016 set treepending $ids
6017 set treediff {}
6018 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6019 fconfigure $gdtf -blocking 0
6020 filerun $gdtf [list gettreediffline $gdtf $ids]
6023 proc gettreediffline {gdtf ids} {
6024 global treediff treediffs treepending diffids diffmergeid
6025 global cmitmode viewfiles curview limitdiffs
6027 set nr 0
6028 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6029 set i [string first "\t" $line]
6030 if {$i >= 0} {
6031 set file [string range $line [expr {$i+1}] end]
6032 if {[string index $file 0] eq "\""} {
6033 set file [lindex $file 0]
6035 lappend treediff $file
6038 if {![eof $gdtf]} {
6039 return [expr {$nr >= 1000? 2: 1}]
6041 close $gdtf
6042 if {$limitdiffs && $viewfiles($curview) ne {}} {
6043 set flist {}
6044 foreach f $treediff {
6045 if {[path_filter $viewfiles($curview) $f]} {
6046 lappend flist $f
6049 set treediffs($ids) $flist
6050 } else {
6051 set treediffs($ids) $treediff
6053 unset treepending
6054 if {$cmitmode eq "tree"} {
6055 gettree $diffids
6056 } elseif {$ids != $diffids} {
6057 if {![info exists diffmergeid]} {
6058 gettreediffs $diffids
6060 } else {
6061 addtocflist $ids
6063 return 0
6066 # empty string or positive integer
6067 proc diffcontextvalidate {v} {
6068 return [regexp {^(|[1-9][0-9]*)$} $v]
6071 proc diffcontextchange {n1 n2 op} {
6072 global diffcontextstring diffcontext
6074 if {[string is integer -strict $diffcontextstring]} {
6075 if {$diffcontextstring > 0} {
6076 set diffcontext $diffcontextstring
6077 reselectline
6082 proc changeignorespace {} {
6083 reselectline
6086 proc getblobdiffs {ids} {
6087 global blobdifffd diffids env
6088 global diffinhdr treediffs
6089 global diffcontext
6090 global ignorespace
6091 global limitdiffs viewfiles curview
6093 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6094 if {$ignorespace} {
6095 append cmd " -w"
6097 if {$limitdiffs && $viewfiles($curview) ne {}} {
6098 set cmd [concat $cmd -- $viewfiles($curview)]
6100 if {[catch {set bdf [open $cmd r]} err]} {
6101 puts "error getting diffs: $err"
6102 return
6104 set diffinhdr 0
6105 fconfigure $bdf -blocking 0
6106 set blobdifffd($ids) $bdf
6107 filerun $bdf [list getblobdiffline $bdf $diffids]
6110 proc setinlist {var i val} {
6111 global $var
6113 while {[llength [set $var]] < $i} {
6114 lappend $var {}
6116 if {[llength [set $var]] == $i} {
6117 lappend $var $val
6118 } else {
6119 lset $var $i $val
6123 proc makediffhdr {fname ids} {
6124 global ctext curdiffstart treediffs
6126 set i [lsearch -exact $treediffs($ids) $fname]
6127 if {$i >= 0} {
6128 setinlist difffilestart $i $curdiffstart
6130 set l [expr {(78 - [string length $fname]) / 2}]
6131 set pad [string range "----------------------------------------" 1 $l]
6132 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6135 proc getblobdiffline {bdf ids} {
6136 global diffids blobdifffd ctext curdiffstart
6137 global diffnexthead diffnextnote difffilestart
6138 global diffinhdr treediffs
6140 set nr 0
6141 $ctext conf -state normal
6142 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6143 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6144 close $bdf
6145 return 0
6147 if {![string compare -length 11 "diff --git " $line]} {
6148 # trim off "diff --git "
6149 set line [string range $line 11 end]
6150 set diffinhdr 1
6151 # start of a new file
6152 $ctext insert end "\n"
6153 set curdiffstart [$ctext index "end - 1c"]
6154 $ctext insert end "\n" filesep
6155 # If the name hasn't changed the length will be odd,
6156 # the middle char will be a space, and the two bits either
6157 # side will be a/name and b/name, or "a/name" and "b/name".
6158 # If the name has changed we'll get "rename from" and
6159 # "rename to" or "copy from" and "copy to" lines following this,
6160 # and we'll use them to get the filenames.
6161 # This complexity is necessary because spaces in the filename(s)
6162 # don't get escaped.
6163 set l [string length $line]
6164 set i [expr {$l / 2}]
6165 if {!(($l & 1) && [string index $line $i] eq " " &&
6166 [string range $line 2 [expr {$i - 1}]] eq \
6167 [string range $line [expr {$i + 3}] end])} {
6168 continue
6170 # unescape if quoted and chop off the a/ from the front
6171 if {[string index $line 0] eq "\""} {
6172 set fname [string range [lindex $line 0] 2 end]
6173 } else {
6174 set fname [string range $line 2 [expr {$i - 1}]]
6176 makediffhdr $fname $ids
6178 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6179 $line match f1l f1c f2l f2c rest]} {
6180 $ctext insert end "$line\n" hunksep
6181 set diffinhdr 0
6183 } elseif {$diffinhdr} {
6184 if {![string compare -length 12 "rename from " $line]} {
6185 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6186 if {[string index $fname 0] eq "\""} {
6187 set fname [lindex $fname 0]
6189 set i [lsearch -exact $treediffs($ids) $fname]
6190 if {$i >= 0} {
6191 setinlist difffilestart $i $curdiffstart
6193 } elseif {![string compare -length 10 $line "rename to "] ||
6194 ![string compare -length 8 $line "copy to "]} {
6195 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6196 if {[string index $fname 0] eq "\""} {
6197 set fname [lindex $fname 0]
6199 makediffhdr $fname $ids
6200 } elseif {[string compare -length 3 $line "---"] == 0} {
6201 # do nothing
6202 continue
6203 } elseif {[string compare -length 3 $line "+++"] == 0} {
6204 set diffinhdr 0
6205 continue
6207 $ctext insert end "$line\n" filesep
6209 } else {
6210 set x [string range $line 0 0]
6211 if {$x == "-" || $x == "+"} {
6212 set tag [expr {$x == "+"}]
6213 $ctext insert end "$line\n" d$tag
6214 } elseif {$x == " "} {
6215 $ctext insert end "$line\n"
6216 } else {
6217 # "\ No newline at end of file",
6218 # or something else we don't recognize
6219 $ctext insert end "$line\n" hunksep
6223 $ctext conf -state disabled
6224 if {[eof $bdf]} {
6225 close $bdf
6226 return 0
6228 return [expr {$nr >= 1000? 2: 1}]
6231 proc changediffdisp {} {
6232 global ctext diffelide
6234 $ctext tag conf d0 -elide [lindex $diffelide 0]
6235 $ctext tag conf d1 -elide [lindex $diffelide 1]
6238 proc prevfile {} {
6239 global difffilestart ctext
6240 set prev [lindex $difffilestart 0]
6241 set here [$ctext index @0,0]
6242 foreach loc $difffilestart {
6243 if {[$ctext compare $loc >= $here]} {
6244 $ctext yview $prev
6245 return
6247 set prev $loc
6249 $ctext yview $prev
6252 proc nextfile {} {
6253 global difffilestart ctext
6254 set here [$ctext index @0,0]
6255 foreach loc $difffilestart {
6256 if {[$ctext compare $loc > $here]} {
6257 $ctext yview $loc
6258 return
6263 proc clear_ctext {{first 1.0}} {
6264 global ctext smarktop smarkbot
6265 global pendinglinks
6267 set l [lindex [split $first .] 0]
6268 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6269 set smarktop $l
6271 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6272 set smarkbot $l
6274 $ctext delete $first end
6275 if {$first eq "1.0"} {
6276 catch {unset pendinglinks}
6280 proc settabs {{firstab {}}} {
6281 global firsttabstop tabstop ctext have_tk85
6283 if {$firstab ne {} && $have_tk85} {
6284 set firsttabstop $firstab
6286 set w [font measure textfont "0"]
6287 if {$firsttabstop != 0} {
6288 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6289 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6290 } elseif {$have_tk85 || $tabstop != 8} {
6291 $ctext conf -tabs [expr {$tabstop * $w}]
6292 } else {
6293 $ctext conf -tabs {}
6297 proc incrsearch {name ix op} {
6298 global ctext searchstring searchdirn
6300 $ctext tag remove found 1.0 end
6301 if {[catch {$ctext index anchor}]} {
6302 # no anchor set, use start of selection, or of visible area
6303 set sel [$ctext tag ranges sel]
6304 if {$sel ne {}} {
6305 $ctext mark set anchor [lindex $sel 0]
6306 } elseif {$searchdirn eq "-forwards"} {
6307 $ctext mark set anchor @0,0
6308 } else {
6309 $ctext mark set anchor @0,[winfo height $ctext]
6312 if {$searchstring ne {}} {
6313 set here [$ctext search $searchdirn -- $searchstring anchor]
6314 if {$here ne {}} {
6315 $ctext see $here
6317 searchmarkvisible 1
6321 proc dosearch {} {
6322 global sstring ctext searchstring searchdirn
6324 focus $sstring
6325 $sstring icursor end
6326 set searchdirn -forwards
6327 if {$searchstring ne {}} {
6328 set sel [$ctext tag ranges sel]
6329 if {$sel ne {}} {
6330 set start "[lindex $sel 0] + 1c"
6331 } elseif {[catch {set start [$ctext index anchor]}]} {
6332 set start "@0,0"
6334 set match [$ctext search -count mlen -- $searchstring $start]
6335 $ctext tag remove sel 1.0 end
6336 if {$match eq {}} {
6337 bell
6338 return
6340 $ctext see $match
6341 set mend "$match + $mlen c"
6342 $ctext tag add sel $match $mend
6343 $ctext mark unset anchor
6347 proc dosearchback {} {
6348 global sstring ctext searchstring searchdirn
6350 focus $sstring
6351 $sstring icursor end
6352 set searchdirn -backwards
6353 if {$searchstring ne {}} {
6354 set sel [$ctext tag ranges sel]
6355 if {$sel ne {}} {
6356 set start [lindex $sel 0]
6357 } elseif {[catch {set start [$ctext index anchor]}]} {
6358 set start @0,[winfo height $ctext]
6360 set match [$ctext search -backwards -count ml -- $searchstring $start]
6361 $ctext tag remove sel 1.0 end
6362 if {$match eq {}} {
6363 bell
6364 return
6366 $ctext see $match
6367 set mend "$match + $ml c"
6368 $ctext tag add sel $match $mend
6369 $ctext mark unset anchor
6373 proc searchmark {first last} {
6374 global ctext searchstring
6376 set mend $first.0
6377 while {1} {
6378 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6379 if {$match eq {}} break
6380 set mend "$match + $mlen c"
6381 $ctext tag add found $match $mend
6385 proc searchmarkvisible {doall} {
6386 global ctext smarktop smarkbot
6388 set topline [lindex [split [$ctext index @0,0] .] 0]
6389 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6390 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6391 # no overlap with previous
6392 searchmark $topline $botline
6393 set smarktop $topline
6394 set smarkbot $botline
6395 } else {
6396 if {$topline < $smarktop} {
6397 searchmark $topline [expr {$smarktop-1}]
6398 set smarktop $topline
6400 if {$botline > $smarkbot} {
6401 searchmark [expr {$smarkbot+1}] $botline
6402 set smarkbot $botline
6407 proc scrolltext {f0 f1} {
6408 global searchstring
6410 .bleft.sb set $f0 $f1
6411 if {$searchstring ne {}} {
6412 searchmarkvisible 0
6416 proc setcoords {} {
6417 global linespc charspc canvx0 canvy0
6418 global xspc1 xspc2 lthickness
6420 set linespc [font metrics mainfont -linespace]
6421 set charspc [font measure mainfont "m"]
6422 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6423 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6424 set lthickness [expr {int($linespc / 9) + 1}]
6425 set xspc1(0) $linespc
6426 set xspc2 $linespc
6429 proc redisplay {} {
6430 global canv
6431 global selectedline
6433 set ymax [lindex [$canv cget -scrollregion] 3]
6434 if {$ymax eq {} || $ymax == 0} return
6435 set span [$canv yview]
6436 clear_display
6437 setcanvscroll
6438 allcanvs yview moveto [lindex $span 0]
6439 drawvisible
6440 if {[info exists selectedline]} {
6441 selectline $selectedline 0
6442 allcanvs yview moveto [lindex $span 0]
6446 proc parsefont {f n} {
6447 global fontattr
6449 set fontattr($f,family) [lindex $n 0]
6450 set s [lindex $n 1]
6451 if {$s eq {} || $s == 0} {
6452 set s 10
6453 } elseif {$s < 0} {
6454 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6456 set fontattr($f,size) $s
6457 set fontattr($f,weight) normal
6458 set fontattr($f,slant) roman
6459 foreach style [lrange $n 2 end] {
6460 switch -- $style {
6461 "normal" -
6462 "bold" {set fontattr($f,weight) $style}
6463 "roman" -
6464 "italic" {set fontattr($f,slant) $style}
6469 proc fontflags {f {isbold 0}} {
6470 global fontattr
6472 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6473 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6474 -slant $fontattr($f,slant)]
6477 proc fontname {f} {
6478 global fontattr
6480 set n [list $fontattr($f,family) $fontattr($f,size)]
6481 if {$fontattr($f,weight) eq "bold"} {
6482 lappend n "bold"
6484 if {$fontattr($f,slant) eq "italic"} {
6485 lappend n "italic"
6487 return $n
6490 proc incrfont {inc} {
6491 global mainfont textfont ctext canv cflist showrefstop
6492 global stopped entries fontattr
6494 unmarkmatches
6495 set s $fontattr(mainfont,size)
6496 incr s $inc
6497 if {$s < 1} {
6498 set s 1
6500 set fontattr(mainfont,size) $s
6501 font config mainfont -size $s
6502 font config mainfontbold -size $s
6503 set mainfont [fontname mainfont]
6504 set s $fontattr(textfont,size)
6505 incr s $inc
6506 if {$s < 1} {
6507 set s 1
6509 set fontattr(textfont,size) $s
6510 font config textfont -size $s
6511 font config textfontbold -size $s
6512 set textfont [fontname textfont]
6513 setcoords
6514 settabs
6515 redisplay
6518 proc clearsha1 {} {
6519 global sha1entry sha1string
6520 if {[string length $sha1string] == 40} {
6521 $sha1entry delete 0 end
6525 proc sha1change {n1 n2 op} {
6526 global sha1string currentid sha1but
6527 if {$sha1string == {}
6528 || ([info exists currentid] && $sha1string == $currentid)} {
6529 set state disabled
6530 } else {
6531 set state normal
6533 if {[$sha1but cget -state] == $state} return
6534 if {$state == "normal"} {
6535 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6536 } else {
6537 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6541 proc gotocommit {} {
6542 global sha1string tagids headids curview varcid
6544 if {$sha1string == {}
6545 || ([info exists currentid] && $sha1string == $currentid)} return
6546 if {[info exists tagids($sha1string)]} {
6547 set id $tagids($sha1string)
6548 } elseif {[info exists headids($sha1string)]} {
6549 set id $headids($sha1string)
6550 } else {
6551 set id [string tolower $sha1string]
6552 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6553 set matches [array names varcid "$curview,$id*"]
6554 if {$matches ne {}} {
6555 if {[llength $matches] > 1} {
6556 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6557 return
6559 set id [lindex [split [lindex $matches 0] ","] 1]
6563 if {[commitinview $id $curview]} {
6564 selectline [rowofcommit $id] 1
6565 return
6567 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6568 set msg [mc "SHA1 id %s is not known" $sha1string]
6569 } else {
6570 set msg [mc "Tag/Head %s is not known" $sha1string]
6572 error_popup $msg
6575 proc lineenter {x y id} {
6576 global hoverx hovery hoverid hovertimer
6577 global commitinfo canv
6579 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6580 set hoverx $x
6581 set hovery $y
6582 set hoverid $id
6583 if {[info exists hovertimer]} {
6584 after cancel $hovertimer
6586 set hovertimer [after 500 linehover]
6587 $canv delete hover
6590 proc linemotion {x y id} {
6591 global hoverx hovery hoverid hovertimer
6593 if {[info exists hoverid] && $id == $hoverid} {
6594 set hoverx $x
6595 set hovery $y
6596 if {[info exists hovertimer]} {
6597 after cancel $hovertimer
6599 set hovertimer [after 500 linehover]
6603 proc lineleave {id} {
6604 global hoverid hovertimer canv
6606 if {[info exists hoverid] && $id == $hoverid} {
6607 $canv delete hover
6608 if {[info exists hovertimer]} {
6609 after cancel $hovertimer
6610 unset hovertimer
6612 unset hoverid
6616 proc linehover {} {
6617 global hoverx hovery hoverid hovertimer
6618 global canv linespc lthickness
6619 global commitinfo
6621 set text [lindex $commitinfo($hoverid) 0]
6622 set ymax [lindex [$canv cget -scrollregion] 3]
6623 if {$ymax == {}} return
6624 set yfrac [lindex [$canv yview] 0]
6625 set x [expr {$hoverx + 2 * $linespc}]
6626 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6627 set x0 [expr {$x - 2 * $lthickness}]
6628 set y0 [expr {$y - 2 * $lthickness}]
6629 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6630 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6631 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6632 -fill \#ffff80 -outline black -width 1 -tags hover]
6633 $canv raise $t
6634 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6635 -font mainfont]
6636 $canv raise $t
6639 proc clickisonarrow {id y} {
6640 global lthickness
6642 set ranges [rowranges $id]
6643 set thresh [expr {2 * $lthickness + 6}]
6644 set n [expr {[llength $ranges] - 1}]
6645 for {set i 1} {$i < $n} {incr i} {
6646 set row [lindex $ranges $i]
6647 if {abs([yc $row] - $y) < $thresh} {
6648 return $i
6651 return {}
6654 proc arrowjump {id n y} {
6655 global canv
6657 # 1 <-> 2, 3 <-> 4, etc...
6658 set n [expr {(($n - 1) ^ 1) + 1}]
6659 set row [lindex [rowranges $id] $n]
6660 set yt [yc $row]
6661 set ymax [lindex [$canv cget -scrollregion] 3]
6662 if {$ymax eq {} || $ymax <= 0} return
6663 set view [$canv yview]
6664 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6665 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6666 if {$yfrac < 0} {
6667 set yfrac 0
6669 allcanvs yview moveto $yfrac
6672 proc lineclick {x y id isnew} {
6673 global ctext commitinfo children canv thickerline curview
6675 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6676 unmarkmatches
6677 unselectline
6678 normalline
6679 $canv delete hover
6680 # draw this line thicker than normal
6681 set thickerline $id
6682 drawlines $id
6683 if {$isnew} {
6684 set ymax [lindex [$canv cget -scrollregion] 3]
6685 if {$ymax eq {}} return
6686 set yfrac [lindex [$canv yview] 0]
6687 set y [expr {$y + $yfrac * $ymax}]
6689 set dirn [clickisonarrow $id $y]
6690 if {$dirn ne {}} {
6691 arrowjump $id $dirn $y
6692 return
6695 if {$isnew} {
6696 addtohistory [list lineclick $x $y $id 0]
6698 # fill the details pane with info about this line
6699 $ctext conf -state normal
6700 clear_ctext
6701 settabs 0
6702 $ctext insert end "[mc "Parent"]:\t"
6703 $ctext insert end $id link0
6704 setlink $id link0
6705 set info $commitinfo($id)
6706 $ctext insert end "\n\t[lindex $info 0]\n"
6707 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
6708 set date [formatdate [lindex $info 2]]
6709 $ctext insert end "\t[mc "Date"]:\t$date\n"
6710 set kids $children($curview,$id)
6711 if {$kids ne {}} {
6712 $ctext insert end "\n[mc "Children"]:"
6713 set i 0
6714 foreach child $kids {
6715 incr i
6716 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6717 set info $commitinfo($child)
6718 $ctext insert end "\n\t"
6719 $ctext insert end $child link$i
6720 setlink $child link$i
6721 $ctext insert end "\n\t[lindex $info 0]"
6722 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
6723 set date [formatdate [lindex $info 2]]
6724 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
6727 $ctext conf -state disabled
6728 init_flist {}
6731 proc normalline {} {
6732 global thickerline
6733 if {[info exists thickerline]} {
6734 set id $thickerline
6735 unset thickerline
6736 drawlines $id
6740 proc selbyid {id} {
6741 global curview
6742 if {[commitinview $id $curview]} {
6743 selectline [rowofcommit $id] 1
6747 proc mstime {} {
6748 global startmstime
6749 if {![info exists startmstime]} {
6750 set startmstime [clock clicks -milliseconds]
6752 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6755 proc rowmenu {x y id} {
6756 global rowctxmenu selectedline rowmenuid curview
6757 global nullid nullid2 fakerowmenu mainhead
6759 stopfinding
6760 set rowmenuid $id
6761 if {![info exists selectedline]
6762 || [rowofcommit $id] eq $selectedline} {
6763 set state disabled
6764 } else {
6765 set state normal
6767 if {$id ne $nullid && $id ne $nullid2} {
6768 set menu $rowctxmenu
6769 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6770 } else {
6771 set menu $fakerowmenu
6773 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6774 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6775 $menu entryconfigure [mc "Make patch"] -state $state
6776 tk_popup $menu $x $y
6779 proc diffvssel {dirn} {
6780 global rowmenuid selectedline
6782 if {![info exists selectedline]} return
6783 if {$dirn} {
6784 set oldid [commitonrow $selectedline]
6785 set newid $rowmenuid
6786 } else {
6787 set oldid $rowmenuid
6788 set newid [commitonrow $selectedline]
6790 addtohistory [list doseldiff $oldid $newid]
6791 doseldiff $oldid $newid
6794 proc doseldiff {oldid newid} {
6795 global ctext
6796 global commitinfo
6798 $ctext conf -state normal
6799 clear_ctext
6800 init_flist [mc "Top"]
6801 $ctext insert end "[mc "From"] "
6802 $ctext insert end $oldid link0
6803 setlink $oldid link0
6804 $ctext insert end "\n "
6805 $ctext insert end [lindex $commitinfo($oldid) 0]
6806 $ctext insert end "\n\n[mc "To"] "
6807 $ctext insert end $newid link1
6808 setlink $newid link1
6809 $ctext insert end "\n "
6810 $ctext insert end [lindex $commitinfo($newid) 0]
6811 $ctext insert end "\n"
6812 $ctext conf -state disabled
6813 $ctext tag remove found 1.0 end
6814 startdiff [list $oldid $newid]
6817 proc mkpatch {} {
6818 global rowmenuid currentid commitinfo patchtop patchnum
6820 if {![info exists currentid]} return
6821 set oldid $currentid
6822 set oldhead [lindex $commitinfo($oldid) 0]
6823 set newid $rowmenuid
6824 set newhead [lindex $commitinfo($newid) 0]
6825 set top .patch
6826 set patchtop $top
6827 catch {destroy $top}
6828 toplevel $top
6829 label $top.title -text [mc "Generate patch"]
6830 grid $top.title - -pady 10
6831 label $top.from -text [mc "From:"]
6832 entry $top.fromsha1 -width 40 -relief flat
6833 $top.fromsha1 insert 0 $oldid
6834 $top.fromsha1 conf -state readonly
6835 grid $top.from $top.fromsha1 -sticky w
6836 entry $top.fromhead -width 60 -relief flat
6837 $top.fromhead insert 0 $oldhead
6838 $top.fromhead conf -state readonly
6839 grid x $top.fromhead -sticky w
6840 label $top.to -text [mc "To:"]
6841 entry $top.tosha1 -width 40 -relief flat
6842 $top.tosha1 insert 0 $newid
6843 $top.tosha1 conf -state readonly
6844 grid $top.to $top.tosha1 -sticky w
6845 entry $top.tohead -width 60 -relief flat
6846 $top.tohead insert 0 $newhead
6847 $top.tohead conf -state readonly
6848 grid x $top.tohead -sticky w
6849 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6850 grid $top.rev x -pady 10
6851 label $top.flab -text [mc "Output file:"]
6852 entry $top.fname -width 60
6853 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6854 incr patchnum
6855 grid $top.flab $top.fname -sticky w
6856 frame $top.buts
6857 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6858 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6859 grid $top.buts.gen $top.buts.can
6860 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6861 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6862 grid $top.buts - -pady 10 -sticky ew
6863 focus $top.fname
6866 proc mkpatchrev {} {
6867 global patchtop
6869 set oldid [$patchtop.fromsha1 get]
6870 set oldhead [$patchtop.fromhead get]
6871 set newid [$patchtop.tosha1 get]
6872 set newhead [$patchtop.tohead get]
6873 foreach e [list fromsha1 fromhead tosha1 tohead] \
6874 v [list $newid $newhead $oldid $oldhead] {
6875 $patchtop.$e conf -state normal
6876 $patchtop.$e delete 0 end
6877 $patchtop.$e insert 0 $v
6878 $patchtop.$e conf -state readonly
6882 proc mkpatchgo {} {
6883 global patchtop nullid nullid2
6885 set oldid [$patchtop.fromsha1 get]
6886 set newid [$patchtop.tosha1 get]
6887 set fname [$patchtop.fname get]
6888 set cmd [diffcmd [list $oldid $newid] -p]
6889 # trim off the initial "|"
6890 set cmd [lrange $cmd 1 end]
6891 lappend cmd >$fname &
6892 if {[catch {eval exec $cmd} err]} {
6893 error_popup "[mc "Error creating patch:"] $err"
6895 catch {destroy $patchtop}
6896 unset patchtop
6899 proc mkpatchcan {} {
6900 global patchtop
6902 catch {destroy $patchtop}
6903 unset patchtop
6906 proc mktag {} {
6907 global rowmenuid mktagtop commitinfo
6909 set top .maketag
6910 set mktagtop $top
6911 catch {destroy $top}
6912 toplevel $top
6913 label $top.title -text [mc "Create tag"]
6914 grid $top.title - -pady 10
6915 label $top.id -text [mc "ID:"]
6916 entry $top.sha1 -width 40 -relief flat
6917 $top.sha1 insert 0 $rowmenuid
6918 $top.sha1 conf -state readonly
6919 grid $top.id $top.sha1 -sticky w
6920 entry $top.head -width 60 -relief flat
6921 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6922 $top.head conf -state readonly
6923 grid x $top.head -sticky w
6924 label $top.tlab -text [mc "Tag name:"]
6925 entry $top.tag -width 60
6926 grid $top.tlab $top.tag -sticky w
6927 frame $top.buts
6928 button $top.buts.gen -text [mc "Create"] -command mktaggo
6929 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6930 grid $top.buts.gen $top.buts.can
6931 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6932 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6933 grid $top.buts - -pady 10 -sticky ew
6934 focus $top.tag
6937 proc domktag {} {
6938 global mktagtop env tagids idtags
6940 set id [$mktagtop.sha1 get]
6941 set tag [$mktagtop.tag get]
6942 if {$tag == {}} {
6943 error_popup [mc "No tag name specified"]
6944 return
6946 if {[info exists tagids($tag)]} {
6947 error_popup [mc "Tag \"%s\" already exists" $tag]
6948 return
6950 if {[catch {
6951 exec git tag $tag $id
6952 } err]} {
6953 error_popup "[mc "Error creating tag:"] $err"
6954 return
6957 set tagids($tag) $id
6958 lappend idtags($id) $tag
6959 redrawtags $id
6960 addedtag $id
6961 dispneartags 0
6962 run refill_reflist
6965 proc redrawtags {id} {
6966 global canv linehtag idpos currentid curview
6967 global canvxmax iddrawn
6969 if {![commitinview $id $curview]} return
6970 if {![info exists iddrawn($id)]} return
6971 set row [rowofcommit $id]
6972 $canv delete tag.$id
6973 set xt [eval drawtags $id $idpos($id)]
6974 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
6975 set text [$canv itemcget $linehtag($row) -text]
6976 set font [$canv itemcget $linehtag($row) -font]
6977 set xr [expr {$xt + [font measure $font $text]}]
6978 if {$xr > $canvxmax} {
6979 set canvxmax $xr
6980 setcanvscroll
6982 if {[info exists currentid] && $currentid == $id} {
6983 make_secsel $row
6987 proc mktagcan {} {
6988 global mktagtop
6990 catch {destroy $mktagtop}
6991 unset mktagtop
6994 proc mktaggo {} {
6995 domktag
6996 mktagcan
6999 proc writecommit {} {
7000 global rowmenuid wrcomtop commitinfo wrcomcmd
7002 set top .writecommit
7003 set wrcomtop $top
7004 catch {destroy $top}
7005 toplevel $top
7006 label $top.title -text [mc "Write commit to file"]
7007 grid $top.title - -pady 10
7008 label $top.id -text [mc "ID:"]
7009 entry $top.sha1 -width 40 -relief flat
7010 $top.sha1 insert 0 $rowmenuid
7011 $top.sha1 conf -state readonly
7012 grid $top.id $top.sha1 -sticky w
7013 entry $top.head -width 60 -relief flat
7014 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7015 $top.head conf -state readonly
7016 grid x $top.head -sticky w
7017 label $top.clab -text [mc "Command:"]
7018 entry $top.cmd -width 60 -textvariable wrcomcmd
7019 grid $top.clab $top.cmd -sticky w -pady 10
7020 label $top.flab -text [mc "Output file:"]
7021 entry $top.fname -width 60
7022 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7023 grid $top.flab $top.fname -sticky w
7024 frame $top.buts
7025 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7026 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7027 grid $top.buts.gen $top.buts.can
7028 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7029 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7030 grid $top.buts - -pady 10 -sticky ew
7031 focus $top.fname
7034 proc wrcomgo {} {
7035 global wrcomtop
7037 set id [$wrcomtop.sha1 get]
7038 set cmd "echo $id | [$wrcomtop.cmd get]"
7039 set fname [$wrcomtop.fname get]
7040 if {[catch {exec sh -c $cmd >$fname &} err]} {
7041 error_popup "[mc "Error writing commit:"] $err"
7043 catch {destroy $wrcomtop}
7044 unset wrcomtop
7047 proc wrcomcan {} {
7048 global wrcomtop
7050 catch {destroy $wrcomtop}
7051 unset wrcomtop
7054 proc mkbranch {} {
7055 global rowmenuid mkbrtop
7057 set top .makebranch
7058 catch {destroy $top}
7059 toplevel $top
7060 label $top.title -text [mc "Create new branch"]
7061 grid $top.title - -pady 10
7062 label $top.id -text [mc "ID:"]
7063 entry $top.sha1 -width 40 -relief flat
7064 $top.sha1 insert 0 $rowmenuid
7065 $top.sha1 conf -state readonly
7066 grid $top.id $top.sha1 -sticky w
7067 label $top.nlab -text [mc "Name:"]
7068 entry $top.name -width 40
7069 grid $top.nlab $top.name -sticky w
7070 frame $top.buts
7071 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7072 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7073 grid $top.buts.go $top.buts.can
7074 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7075 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7076 grid $top.buts - -pady 10 -sticky ew
7077 focus $top.name
7080 proc mkbrgo {top} {
7081 global headids idheads
7083 set name [$top.name get]
7084 set id [$top.sha1 get]
7085 if {$name eq {}} {
7086 error_popup [mc "Please specify a name for the new branch"]
7087 return
7089 catch {destroy $top}
7090 nowbusy newbranch
7091 update
7092 if {[catch {
7093 exec git branch $name $id
7094 } err]} {
7095 notbusy newbranch
7096 error_popup $err
7097 } else {
7098 set headids($name) $id
7099 lappend idheads($id) $name
7100 addedhead $id $name
7101 notbusy newbranch
7102 redrawtags $id
7103 dispneartags 0
7104 run refill_reflist
7108 proc cherrypick {} {
7109 global rowmenuid curview viewincl
7110 global mainhead mainheadid
7112 set oldhead [exec git rev-parse HEAD]
7113 set dheads [descheads $rowmenuid]
7114 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7115 set ok [confirm_popup [mc "Commit %s is already\
7116 included in branch %s -- really re-apply it?" \
7117 [string range $rowmenuid 0 7] $mainhead]]
7118 if {!$ok} return
7120 nowbusy cherrypick [mc "Cherry-picking"]
7121 update
7122 # Unfortunately git-cherry-pick writes stuff to stderr even when
7123 # no error occurs, and exec takes that as an indication of error...
7124 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7125 notbusy cherrypick
7126 error_popup $err
7127 return
7129 set newhead [exec git rev-parse HEAD]
7130 if {$newhead eq $oldhead} {
7131 notbusy cherrypick
7132 error_popup [mc "No changes committed"]
7133 return
7135 addnewchild $newhead $oldhead
7136 if {[commitinview $oldhead $curview]} {
7137 insertrow $newhead $oldhead $curview
7138 if {$mainhead ne {}} {
7139 movehead $newhead $mainhead
7140 movedhead $newhead $mainhead
7141 set mainheadid $newhead
7143 # remove oldhead from viewincl and add newhead
7144 set i [lsearch -exact $viewincl($curview) $oldhead]
7145 if {$i >= 0} {
7146 set viewincl($curview) [lreplace $viewincl($curview) $i $i]
7148 lappend viewincl($curview) $newhead
7149 redrawtags $oldhead
7150 redrawtags $newhead
7151 selbyid $newhead
7153 notbusy cherrypick
7156 proc resethead {} {
7157 global mainhead rowmenuid confirm_ok resettype
7159 set confirm_ok 0
7160 set w ".confirmreset"
7161 toplevel $w
7162 wm transient $w .
7163 wm title $w [mc "Confirm reset"]
7164 message $w.m -text \
7165 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7166 -justify center -aspect 1000
7167 pack $w.m -side top -fill x -padx 20 -pady 20
7168 frame $w.f -relief sunken -border 2
7169 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7170 grid $w.f.rt -sticky w
7171 set resettype mixed
7172 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7173 -text [mc "Soft: Leave working tree and index untouched"]
7174 grid $w.f.soft -sticky w
7175 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7176 -text [mc "Mixed: Leave working tree untouched, reset index"]
7177 grid $w.f.mixed -sticky w
7178 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7179 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7180 grid $w.f.hard -sticky w
7181 pack $w.f -side top -fill x
7182 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7183 pack $w.ok -side left -fill x -padx 20 -pady 20
7184 button $w.cancel -text [mc Cancel] -command "destroy $w"
7185 pack $w.cancel -side right -fill x -padx 20 -pady 20
7186 bind $w <Visibility> "grab $w; focus $w"
7187 tkwait window $w
7188 if {!$confirm_ok} return
7189 if {[catch {set fd [open \
7190 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
7191 error_popup $err
7192 } else {
7193 dohidelocalchanges
7194 filerun $fd [list readresetstat $fd]
7195 nowbusy reset [mc "Resetting"]
7196 selbyid $rowmenuid
7200 proc readresetstat {fd} {
7201 global mainhead mainheadid showlocalchanges rprogcoord
7203 if {[gets $fd line] >= 0} {
7204 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7205 set rprogcoord [expr {1.0 * $m / $n}]
7206 adjustprogress
7208 return 1
7210 set rprogcoord 0
7211 adjustprogress
7212 notbusy reset
7213 if {[catch {close $fd} err]} {
7214 error_popup $err
7216 set oldhead $mainheadid
7217 set newhead [exec git rev-parse HEAD]
7218 if {$newhead ne $oldhead} {
7219 movehead $newhead $mainhead
7220 movedhead $newhead $mainhead
7221 set mainheadid $newhead
7222 redrawtags $oldhead
7223 redrawtags $newhead
7225 if {$showlocalchanges} {
7226 doshowlocalchanges
7228 return 0
7231 # context menu for a head
7232 proc headmenu {x y id head} {
7233 global headmenuid headmenuhead headctxmenu mainhead
7235 stopfinding
7236 set headmenuid $id
7237 set headmenuhead $head
7238 set state normal
7239 if {$head eq $mainhead} {
7240 set state disabled
7242 $headctxmenu entryconfigure 0 -state $state
7243 $headctxmenu entryconfigure 1 -state $state
7244 tk_popup $headctxmenu $x $y
7247 proc cobranch {} {
7248 global headmenuid headmenuhead mainhead headids
7249 global showlocalchanges mainheadid
7251 # check the tree is clean first??
7252 set oldmainhead $mainhead
7253 nowbusy checkout [mc "Checking out"]
7254 update
7255 dohidelocalchanges
7256 if {[catch {
7257 exec git checkout -q $headmenuhead
7258 } err]} {
7259 notbusy checkout
7260 error_popup $err
7261 } else {
7262 notbusy checkout
7263 set mainhead $headmenuhead
7264 set mainheadid $headmenuid
7265 if {[info exists headids($oldmainhead)]} {
7266 redrawtags $headids($oldmainhead)
7268 redrawtags $headmenuid
7269 selbyid $headmenuid
7271 if {$showlocalchanges} {
7272 dodiffindex
7276 proc rmbranch {} {
7277 global headmenuid headmenuhead mainhead
7278 global idheads
7280 set head $headmenuhead
7281 set id $headmenuid
7282 # this check shouldn't be needed any more...
7283 if {$head eq $mainhead} {
7284 error_popup [mc "Cannot delete the currently checked-out branch"]
7285 return
7287 set dheads [descheads $id]
7288 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7289 # the stuff on this branch isn't on any other branch
7290 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7291 branch.\nReally delete branch %s?" $head $head]]} return
7293 nowbusy rmbranch
7294 update
7295 if {[catch {exec git branch -D $head} err]} {
7296 notbusy rmbranch
7297 error_popup $err
7298 return
7300 removehead $id $head
7301 removedhead $id $head
7302 redrawtags $id
7303 notbusy rmbranch
7304 dispneartags 0
7305 run refill_reflist
7308 # Display a list of tags and heads
7309 proc showrefs {} {
7310 global showrefstop bgcolor fgcolor selectbgcolor
7311 global bglist fglist reflistfilter reflist maincursor
7313 set top .showrefs
7314 set showrefstop $top
7315 if {[winfo exists $top]} {
7316 raise $top
7317 refill_reflist
7318 return
7320 toplevel $top
7321 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7322 text $top.list -background $bgcolor -foreground $fgcolor \
7323 -selectbackground $selectbgcolor -font mainfont \
7324 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7325 -width 30 -height 20 -cursor $maincursor \
7326 -spacing1 1 -spacing3 1 -state disabled
7327 $top.list tag configure highlight -background $selectbgcolor
7328 lappend bglist $top.list
7329 lappend fglist $top.list
7330 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7331 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7332 grid $top.list $top.ysb -sticky nsew
7333 grid $top.xsb x -sticky ew
7334 frame $top.f
7335 label $top.f.l -text "[mc "Filter"]: "
7336 entry $top.f.e -width 20 -textvariable reflistfilter
7337 set reflistfilter "*"
7338 trace add variable reflistfilter write reflistfilter_change
7339 pack $top.f.e -side right -fill x -expand 1
7340 pack $top.f.l -side left
7341 grid $top.f - -sticky ew -pady 2
7342 button $top.close -command [list destroy $top] -text [mc "Close"]
7343 grid $top.close -
7344 grid columnconfigure $top 0 -weight 1
7345 grid rowconfigure $top 0 -weight 1
7346 bind $top.list <1> {break}
7347 bind $top.list <B1-Motion> {break}
7348 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7349 set reflist {}
7350 refill_reflist
7353 proc sel_reflist {w x y} {
7354 global showrefstop reflist headids tagids otherrefids
7356 if {![winfo exists $showrefstop]} return
7357 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7358 set ref [lindex $reflist [expr {$l-1}]]
7359 set n [lindex $ref 0]
7360 switch -- [lindex $ref 1] {
7361 "H" {selbyid $headids($n)}
7362 "T" {selbyid $tagids($n)}
7363 "o" {selbyid $otherrefids($n)}
7365 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7368 proc unsel_reflist {} {
7369 global showrefstop
7371 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7372 $showrefstop.list tag remove highlight 0.0 end
7375 proc reflistfilter_change {n1 n2 op} {
7376 global reflistfilter
7378 after cancel refill_reflist
7379 after 200 refill_reflist
7382 proc refill_reflist {} {
7383 global reflist reflistfilter showrefstop headids tagids otherrefids
7384 global curview commitinterest
7386 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7387 set refs {}
7388 foreach n [array names headids] {
7389 if {[string match $reflistfilter $n]} {
7390 if {[commitinview $headids($n) $curview]} {
7391 lappend refs [list $n H]
7392 } else {
7393 set commitinterest($headids($n)) {run refill_reflist}
7397 foreach n [array names tagids] {
7398 if {[string match $reflistfilter $n]} {
7399 if {[commitinview $tagids($n) $curview]} {
7400 lappend refs [list $n T]
7401 } else {
7402 set commitinterest($tagids($n)) {run refill_reflist}
7406 foreach n [array names otherrefids] {
7407 if {[string match $reflistfilter $n]} {
7408 if {[commitinview $otherrefids($n) $curview]} {
7409 lappend refs [list $n o]
7410 } else {
7411 set commitinterest($otherrefids($n)) {run refill_reflist}
7415 set refs [lsort -index 0 $refs]
7416 if {$refs eq $reflist} return
7418 # Update the contents of $showrefstop.list according to the
7419 # differences between $reflist (old) and $refs (new)
7420 $showrefstop.list conf -state normal
7421 $showrefstop.list insert end "\n"
7422 set i 0
7423 set j 0
7424 while {$i < [llength $reflist] || $j < [llength $refs]} {
7425 if {$i < [llength $reflist]} {
7426 if {$j < [llength $refs]} {
7427 set cmp [string compare [lindex $reflist $i 0] \
7428 [lindex $refs $j 0]]
7429 if {$cmp == 0} {
7430 set cmp [string compare [lindex $reflist $i 1] \
7431 [lindex $refs $j 1]]
7433 } else {
7434 set cmp -1
7436 } else {
7437 set cmp 1
7439 switch -- $cmp {
7440 -1 {
7441 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7442 incr i
7445 incr i
7446 incr j
7449 set l [expr {$j + 1}]
7450 $showrefstop.list image create $l.0 -align baseline \
7451 -image reficon-[lindex $refs $j 1] -padx 2
7452 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7453 incr j
7457 set reflist $refs
7458 # delete last newline
7459 $showrefstop.list delete end-2c end-1c
7460 $showrefstop.list conf -state disabled
7463 # Stuff for finding nearby tags
7464 proc getallcommits {} {
7465 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7466 global idheads idtags idotherrefs allparents tagobjid
7468 if {![info exists allcommits]} {
7469 set nextarc 0
7470 set allcommits 0
7471 set seeds {}
7472 set allcwait 0
7473 set cachedarcs 0
7474 set allccache [file join [gitdir] "gitk.cache"]
7475 if {![catch {
7476 set f [open $allccache r]
7477 set allcwait 1
7478 getcache $f
7479 }]} return
7482 if {$allcwait} {
7483 return
7485 set cmd [list | git rev-list --parents]
7486 set allcupdate [expr {$seeds ne {}}]
7487 if {!$allcupdate} {
7488 set ids "--all"
7489 } else {
7490 set refs [concat [array names idheads] [array names idtags] \
7491 [array names idotherrefs]]
7492 set ids {}
7493 set tagobjs {}
7494 foreach name [array names tagobjid] {
7495 lappend tagobjs $tagobjid($name)
7497 foreach id [lsort -unique $refs] {
7498 if {![info exists allparents($id)] &&
7499 [lsearch -exact $tagobjs $id] < 0} {
7500 lappend ids $id
7503 if {$ids ne {}} {
7504 foreach id $seeds {
7505 lappend ids "^$id"
7509 if {$ids ne {}} {
7510 set fd [open [concat $cmd $ids] r]
7511 fconfigure $fd -blocking 0
7512 incr allcommits
7513 nowbusy allcommits
7514 filerun $fd [list getallclines $fd]
7515 } else {
7516 dispneartags 0
7520 # Since most commits have 1 parent and 1 child, we group strings of
7521 # such commits into "arcs" joining branch/merge points (BMPs), which
7522 # are commits that either don't have 1 parent or don't have 1 child.
7524 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7525 # arcout(id) - outgoing arcs for BMP
7526 # arcids(a) - list of IDs on arc including end but not start
7527 # arcstart(a) - BMP ID at start of arc
7528 # arcend(a) - BMP ID at end of arc
7529 # growing(a) - arc a is still growing
7530 # arctags(a) - IDs out of arcids (excluding end) that have tags
7531 # archeads(a) - IDs out of arcids (excluding end) that have heads
7532 # The start of an arc is at the descendent end, so "incoming" means
7533 # coming from descendents, and "outgoing" means going towards ancestors.
7535 proc getallclines {fd} {
7536 global allparents allchildren idtags idheads nextarc
7537 global arcnos arcids arctags arcout arcend arcstart archeads growing
7538 global seeds allcommits cachedarcs allcupdate
7540 set nid 0
7541 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7542 set id [lindex $line 0]
7543 if {[info exists allparents($id)]} {
7544 # seen it already
7545 continue
7547 set cachedarcs 0
7548 set olds [lrange $line 1 end]
7549 set allparents($id) $olds
7550 if {![info exists allchildren($id)]} {
7551 set allchildren($id) {}
7552 set arcnos($id) {}
7553 lappend seeds $id
7554 } else {
7555 set a $arcnos($id)
7556 if {[llength $olds] == 1 && [llength $a] == 1} {
7557 lappend arcids($a) $id
7558 if {[info exists idtags($id)]} {
7559 lappend arctags($a) $id
7561 if {[info exists idheads($id)]} {
7562 lappend archeads($a) $id
7564 if {[info exists allparents($olds)]} {
7565 # seen parent already
7566 if {![info exists arcout($olds)]} {
7567 splitarc $olds
7569 lappend arcids($a) $olds
7570 set arcend($a) $olds
7571 unset growing($a)
7573 lappend allchildren($olds) $id
7574 lappend arcnos($olds) $a
7575 continue
7578 foreach a $arcnos($id) {
7579 lappend arcids($a) $id
7580 set arcend($a) $id
7581 unset growing($a)
7584 set ao {}
7585 foreach p $olds {
7586 lappend allchildren($p) $id
7587 set a [incr nextarc]
7588 set arcstart($a) $id
7589 set archeads($a) {}
7590 set arctags($a) {}
7591 set archeads($a) {}
7592 set arcids($a) {}
7593 lappend ao $a
7594 set growing($a) 1
7595 if {[info exists allparents($p)]} {
7596 # seen it already, may need to make a new branch
7597 if {![info exists arcout($p)]} {
7598 splitarc $p
7600 lappend arcids($a) $p
7601 set arcend($a) $p
7602 unset growing($a)
7604 lappend arcnos($p) $a
7606 set arcout($id) $ao
7608 if {$nid > 0} {
7609 global cached_dheads cached_dtags cached_atags
7610 catch {unset cached_dheads}
7611 catch {unset cached_dtags}
7612 catch {unset cached_atags}
7614 if {![eof $fd]} {
7615 return [expr {$nid >= 1000? 2: 1}]
7617 set cacheok 1
7618 if {[catch {
7619 fconfigure $fd -blocking 1
7620 close $fd
7621 } err]} {
7622 # got an error reading the list of commits
7623 # if we were updating, try rereading the whole thing again
7624 if {$allcupdate} {
7625 incr allcommits -1
7626 dropcache $err
7627 return
7629 error_popup "[mc "Error reading commit topology information;\
7630 branch and preceding/following tag information\
7631 will be incomplete."]\n($err)"
7632 set cacheok 0
7634 if {[incr allcommits -1] == 0} {
7635 notbusy allcommits
7636 if {$cacheok} {
7637 run savecache
7640 dispneartags 0
7641 return 0
7644 proc recalcarc {a} {
7645 global arctags archeads arcids idtags idheads
7647 set at {}
7648 set ah {}
7649 foreach id [lrange $arcids($a) 0 end-1] {
7650 if {[info exists idtags($id)]} {
7651 lappend at $id
7653 if {[info exists idheads($id)]} {
7654 lappend ah $id
7657 set arctags($a) $at
7658 set archeads($a) $ah
7661 proc splitarc {p} {
7662 global arcnos arcids nextarc arctags archeads idtags idheads
7663 global arcstart arcend arcout allparents growing
7665 set a $arcnos($p)
7666 if {[llength $a] != 1} {
7667 puts "oops splitarc called but [llength $a] arcs already"
7668 return
7670 set a [lindex $a 0]
7671 set i [lsearch -exact $arcids($a) $p]
7672 if {$i < 0} {
7673 puts "oops splitarc $p not in arc $a"
7674 return
7676 set na [incr nextarc]
7677 if {[info exists arcend($a)]} {
7678 set arcend($na) $arcend($a)
7679 } else {
7680 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7681 set j [lsearch -exact $arcnos($l) $a]
7682 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7684 set tail [lrange $arcids($a) [expr {$i+1}] end]
7685 set arcids($a) [lrange $arcids($a) 0 $i]
7686 set arcend($a) $p
7687 set arcstart($na) $p
7688 set arcout($p) $na
7689 set arcids($na) $tail
7690 if {[info exists growing($a)]} {
7691 set growing($na) 1
7692 unset growing($a)
7695 foreach id $tail {
7696 if {[llength $arcnos($id)] == 1} {
7697 set arcnos($id) $na
7698 } else {
7699 set j [lsearch -exact $arcnos($id) $a]
7700 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7704 # reconstruct tags and heads lists
7705 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7706 recalcarc $a
7707 recalcarc $na
7708 } else {
7709 set arctags($na) {}
7710 set archeads($na) {}
7714 # Update things for a new commit added that is a child of one
7715 # existing commit. Used when cherry-picking.
7716 proc addnewchild {id p} {
7717 global allparents allchildren idtags nextarc
7718 global arcnos arcids arctags arcout arcend arcstart archeads growing
7719 global seeds allcommits
7721 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7722 set allparents($id) [list $p]
7723 set allchildren($id) {}
7724 set arcnos($id) {}
7725 lappend seeds $id
7726 lappend allchildren($p) $id
7727 set a [incr nextarc]
7728 set arcstart($a) $id
7729 set archeads($a) {}
7730 set arctags($a) {}
7731 set arcids($a) [list $p]
7732 set arcend($a) $p
7733 if {![info exists arcout($p)]} {
7734 splitarc $p
7736 lappend arcnos($p) $a
7737 set arcout($id) [list $a]
7740 # This implements a cache for the topology information.
7741 # The cache saves, for each arc, the start and end of the arc,
7742 # the ids on the arc, and the outgoing arcs from the end.
7743 proc readcache {f} {
7744 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7745 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7746 global allcwait
7748 set a $nextarc
7749 set lim $cachedarcs
7750 if {$lim - $a > 500} {
7751 set lim [expr {$a + 500}]
7753 if {[catch {
7754 if {$a == $lim} {
7755 # finish reading the cache and setting up arctags, etc.
7756 set line [gets $f]
7757 if {$line ne "1"} {error "bad final version"}
7758 close $f
7759 foreach id [array names idtags] {
7760 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7761 [llength $allparents($id)] == 1} {
7762 set a [lindex $arcnos($id) 0]
7763 if {$arctags($a) eq {}} {
7764 recalcarc $a
7768 foreach id [array names idheads] {
7769 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7770 [llength $allparents($id)] == 1} {
7771 set a [lindex $arcnos($id) 0]
7772 if {$archeads($a) eq {}} {
7773 recalcarc $a
7777 foreach id [lsort -unique $possible_seeds] {
7778 if {$arcnos($id) eq {}} {
7779 lappend seeds $id
7782 set allcwait 0
7783 } else {
7784 while {[incr a] <= $lim} {
7785 set line [gets $f]
7786 if {[llength $line] != 3} {error "bad line"}
7787 set s [lindex $line 0]
7788 set arcstart($a) $s
7789 lappend arcout($s) $a
7790 if {![info exists arcnos($s)]} {
7791 lappend possible_seeds $s
7792 set arcnos($s) {}
7794 set e [lindex $line 1]
7795 if {$e eq {}} {
7796 set growing($a) 1
7797 } else {
7798 set arcend($a) $e
7799 if {![info exists arcout($e)]} {
7800 set arcout($e) {}
7803 set arcids($a) [lindex $line 2]
7804 foreach id $arcids($a) {
7805 lappend allparents($s) $id
7806 set s $id
7807 lappend arcnos($id) $a
7809 if {![info exists allparents($s)]} {
7810 set allparents($s) {}
7812 set arctags($a) {}
7813 set archeads($a) {}
7815 set nextarc [expr {$a - 1}]
7817 } err]} {
7818 dropcache $err
7819 return 0
7821 if {!$allcwait} {
7822 getallcommits
7824 return $allcwait
7827 proc getcache {f} {
7828 global nextarc cachedarcs possible_seeds
7830 if {[catch {
7831 set line [gets $f]
7832 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7833 # make sure it's an integer
7834 set cachedarcs [expr {int([lindex $line 1])}]
7835 if {$cachedarcs < 0} {error "bad number of arcs"}
7836 set nextarc 0
7837 set possible_seeds {}
7838 run readcache $f
7839 } err]} {
7840 dropcache $err
7842 return 0
7845 proc dropcache {err} {
7846 global allcwait nextarc cachedarcs seeds
7848 #puts "dropping cache ($err)"
7849 foreach v {arcnos arcout arcids arcstart arcend growing \
7850 arctags archeads allparents allchildren} {
7851 global $v
7852 catch {unset $v}
7854 set allcwait 0
7855 set nextarc 0
7856 set cachedarcs 0
7857 set seeds {}
7858 getallcommits
7861 proc writecache {f} {
7862 global cachearc cachedarcs allccache
7863 global arcstart arcend arcnos arcids arcout
7865 set a $cachearc
7866 set lim $cachedarcs
7867 if {$lim - $a > 1000} {
7868 set lim [expr {$a + 1000}]
7870 if {[catch {
7871 while {[incr a] <= $lim} {
7872 if {[info exists arcend($a)]} {
7873 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7874 } else {
7875 puts $f [list $arcstart($a) {} $arcids($a)]
7878 } err]} {
7879 catch {close $f}
7880 catch {file delete $allccache}
7881 #puts "writing cache failed ($err)"
7882 return 0
7884 set cachearc [expr {$a - 1}]
7885 if {$a > $cachedarcs} {
7886 puts $f "1"
7887 close $f
7888 return 0
7890 return 1
7893 proc savecache {} {
7894 global nextarc cachedarcs cachearc allccache
7896 if {$nextarc == $cachedarcs} return
7897 set cachearc 0
7898 set cachedarcs $nextarc
7899 catch {
7900 set f [open $allccache w]
7901 puts $f [list 1 $cachedarcs]
7902 run writecache $f
7906 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7907 # or 0 if neither is true.
7908 proc anc_or_desc {a b} {
7909 global arcout arcstart arcend arcnos cached_isanc
7911 if {$arcnos($a) eq $arcnos($b)} {
7912 # Both are on the same arc(s); either both are the same BMP,
7913 # or if one is not a BMP, the other is also not a BMP or is
7914 # the BMP at end of the arc (and it only has 1 incoming arc).
7915 # Or both can be BMPs with no incoming arcs.
7916 if {$a eq $b || $arcnos($a) eq {}} {
7917 return 0
7919 # assert {[llength $arcnos($a)] == 1}
7920 set arc [lindex $arcnos($a) 0]
7921 set i [lsearch -exact $arcids($arc) $a]
7922 set j [lsearch -exact $arcids($arc) $b]
7923 if {$i < 0 || $i > $j} {
7924 return 1
7925 } else {
7926 return -1
7930 if {![info exists arcout($a)]} {
7931 set arc [lindex $arcnos($a) 0]
7932 if {[info exists arcend($arc)]} {
7933 set aend $arcend($arc)
7934 } else {
7935 set aend {}
7937 set a $arcstart($arc)
7938 } else {
7939 set aend $a
7941 if {![info exists arcout($b)]} {
7942 set arc [lindex $arcnos($b) 0]
7943 if {[info exists arcend($arc)]} {
7944 set bend $arcend($arc)
7945 } else {
7946 set bend {}
7948 set b $arcstart($arc)
7949 } else {
7950 set bend $b
7952 if {$a eq $bend} {
7953 return 1
7955 if {$b eq $aend} {
7956 return -1
7958 if {[info exists cached_isanc($a,$bend)]} {
7959 if {$cached_isanc($a,$bend)} {
7960 return 1
7963 if {[info exists cached_isanc($b,$aend)]} {
7964 if {$cached_isanc($b,$aend)} {
7965 return -1
7967 if {[info exists cached_isanc($a,$bend)]} {
7968 return 0
7972 set todo [list $a $b]
7973 set anc($a) a
7974 set anc($b) b
7975 for {set i 0} {$i < [llength $todo]} {incr i} {
7976 set x [lindex $todo $i]
7977 if {$anc($x) eq {}} {
7978 continue
7980 foreach arc $arcnos($x) {
7981 set xd $arcstart($arc)
7982 if {$xd eq $bend} {
7983 set cached_isanc($a,$bend) 1
7984 set cached_isanc($b,$aend) 0
7985 return 1
7986 } elseif {$xd eq $aend} {
7987 set cached_isanc($b,$aend) 1
7988 set cached_isanc($a,$bend) 0
7989 return -1
7991 if {![info exists anc($xd)]} {
7992 set anc($xd) $anc($x)
7993 lappend todo $xd
7994 } elseif {$anc($xd) ne $anc($x)} {
7995 set anc($xd) {}
7999 set cached_isanc($a,$bend) 0
8000 set cached_isanc($b,$aend) 0
8001 return 0
8004 # This identifies whether $desc has an ancestor that is
8005 # a growing tip of the graph and which is not an ancestor of $anc
8006 # and returns 0 if so and 1 if not.
8007 # If we subsequently discover a tag on such a growing tip, and that
8008 # turns out to be a descendent of $anc (which it could, since we
8009 # don't necessarily see children before parents), then $desc
8010 # isn't a good choice to display as a descendent tag of
8011 # $anc (since it is the descendent of another tag which is
8012 # a descendent of $anc). Similarly, $anc isn't a good choice to
8013 # display as a ancestor tag of $desc.
8015 proc is_certain {desc anc} {
8016 global arcnos arcout arcstart arcend growing problems
8018 set certain {}
8019 if {[llength $arcnos($anc)] == 1} {
8020 # tags on the same arc are certain
8021 if {$arcnos($desc) eq $arcnos($anc)} {
8022 return 1
8024 if {![info exists arcout($anc)]} {
8025 # if $anc is partway along an arc, use the start of the arc instead
8026 set a [lindex $arcnos($anc) 0]
8027 set anc $arcstart($a)
8030 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8031 set x $desc
8032 } else {
8033 set a [lindex $arcnos($desc) 0]
8034 set x $arcend($a)
8036 if {$x == $anc} {
8037 return 1
8039 set anclist [list $x]
8040 set dl($x) 1
8041 set nnh 1
8042 set ngrowanc 0
8043 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8044 set x [lindex $anclist $i]
8045 if {$dl($x)} {
8046 incr nnh -1
8048 set done($x) 1
8049 foreach a $arcout($x) {
8050 if {[info exists growing($a)]} {
8051 if {![info exists growanc($x)] && $dl($x)} {
8052 set growanc($x) 1
8053 incr ngrowanc
8055 } else {
8056 set y $arcend($a)
8057 if {[info exists dl($y)]} {
8058 if {$dl($y)} {
8059 if {!$dl($x)} {
8060 set dl($y) 0
8061 if {![info exists done($y)]} {
8062 incr nnh -1
8064 if {[info exists growanc($x)]} {
8065 incr ngrowanc -1
8067 set xl [list $y]
8068 for {set k 0} {$k < [llength $xl]} {incr k} {
8069 set z [lindex $xl $k]
8070 foreach c $arcout($z) {
8071 if {[info exists arcend($c)]} {
8072 set v $arcend($c)
8073 if {[info exists dl($v)] && $dl($v)} {
8074 set dl($v) 0
8075 if {![info exists done($v)]} {
8076 incr nnh -1
8078 if {[info exists growanc($v)]} {
8079 incr ngrowanc -1
8081 lappend xl $v
8088 } elseif {$y eq $anc || !$dl($x)} {
8089 set dl($y) 0
8090 lappend anclist $y
8091 } else {
8092 set dl($y) 1
8093 lappend anclist $y
8094 incr nnh
8099 foreach x [array names growanc] {
8100 if {$dl($x)} {
8101 return 0
8103 return 0
8105 return 1
8108 proc validate_arctags {a} {
8109 global arctags idtags
8111 set i -1
8112 set na $arctags($a)
8113 foreach id $arctags($a) {
8114 incr i
8115 if {![info exists idtags($id)]} {
8116 set na [lreplace $na $i $i]
8117 incr i -1
8120 set arctags($a) $na
8123 proc validate_archeads {a} {
8124 global archeads idheads
8126 set i -1
8127 set na $archeads($a)
8128 foreach id $archeads($a) {
8129 incr i
8130 if {![info exists idheads($id)]} {
8131 set na [lreplace $na $i $i]
8132 incr i -1
8135 set archeads($a) $na
8138 # Return the list of IDs that have tags that are descendents of id,
8139 # ignoring IDs that are descendents of IDs already reported.
8140 proc desctags {id} {
8141 global arcnos arcstart arcids arctags idtags allparents
8142 global growing cached_dtags
8144 if {![info exists allparents($id)]} {
8145 return {}
8147 set t1 [clock clicks -milliseconds]
8148 set argid $id
8149 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8150 # part-way along an arc; check that arc first
8151 set a [lindex $arcnos($id) 0]
8152 if {$arctags($a) ne {}} {
8153 validate_arctags $a
8154 set i [lsearch -exact $arcids($a) $id]
8155 set tid {}
8156 foreach t $arctags($a) {
8157 set j [lsearch -exact $arcids($a) $t]
8158 if {$j >= $i} break
8159 set tid $t
8161 if {$tid ne {}} {
8162 return $tid
8165 set id $arcstart($a)
8166 if {[info exists idtags($id)]} {
8167 return $id
8170 if {[info exists cached_dtags($id)]} {
8171 return $cached_dtags($id)
8174 set origid $id
8175 set todo [list $id]
8176 set queued($id) 1
8177 set nc 1
8178 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8179 set id [lindex $todo $i]
8180 set done($id) 1
8181 set ta [info exists hastaggedancestor($id)]
8182 if {!$ta} {
8183 incr nc -1
8185 # ignore tags on starting node
8186 if {!$ta && $i > 0} {
8187 if {[info exists idtags($id)]} {
8188 set tagloc($id) $id
8189 set ta 1
8190 } elseif {[info exists cached_dtags($id)]} {
8191 set tagloc($id) $cached_dtags($id)
8192 set ta 1
8195 foreach a $arcnos($id) {
8196 set d $arcstart($a)
8197 if {!$ta && $arctags($a) ne {}} {
8198 validate_arctags $a
8199 if {$arctags($a) ne {}} {
8200 lappend tagloc($id) [lindex $arctags($a) end]
8203 if {$ta || $arctags($a) ne {}} {
8204 set tomark [list $d]
8205 for {set j 0} {$j < [llength $tomark]} {incr j} {
8206 set dd [lindex $tomark $j]
8207 if {![info exists hastaggedancestor($dd)]} {
8208 if {[info exists done($dd)]} {
8209 foreach b $arcnos($dd) {
8210 lappend tomark $arcstart($b)
8212 if {[info exists tagloc($dd)]} {
8213 unset tagloc($dd)
8215 } elseif {[info exists queued($dd)]} {
8216 incr nc -1
8218 set hastaggedancestor($dd) 1
8222 if {![info exists queued($d)]} {
8223 lappend todo $d
8224 set queued($d) 1
8225 if {![info exists hastaggedancestor($d)]} {
8226 incr nc
8231 set tags {}
8232 foreach id [array names tagloc] {
8233 if {![info exists hastaggedancestor($id)]} {
8234 foreach t $tagloc($id) {
8235 if {[lsearch -exact $tags $t] < 0} {
8236 lappend tags $t
8241 set t2 [clock clicks -milliseconds]
8242 set loopix $i
8244 # remove tags that are descendents of other tags
8245 for {set i 0} {$i < [llength $tags]} {incr i} {
8246 set a [lindex $tags $i]
8247 for {set j 0} {$j < $i} {incr j} {
8248 set b [lindex $tags $j]
8249 set r [anc_or_desc $a $b]
8250 if {$r == 1} {
8251 set tags [lreplace $tags $j $j]
8252 incr j -1
8253 incr i -1
8254 } elseif {$r == -1} {
8255 set tags [lreplace $tags $i $i]
8256 incr i -1
8257 break
8262 if {[array names growing] ne {}} {
8263 # graph isn't finished, need to check if any tag could get
8264 # eclipsed by another tag coming later. Simply ignore any
8265 # tags that could later get eclipsed.
8266 set ctags {}
8267 foreach t $tags {
8268 if {[is_certain $t $origid]} {
8269 lappend ctags $t
8272 if {$tags eq $ctags} {
8273 set cached_dtags($origid) $tags
8274 } else {
8275 set tags $ctags
8277 } else {
8278 set cached_dtags($origid) $tags
8280 set t3 [clock clicks -milliseconds]
8281 if {0 && $t3 - $t1 >= 100} {
8282 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8283 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8285 return $tags
8288 proc anctags {id} {
8289 global arcnos arcids arcout arcend arctags idtags allparents
8290 global growing cached_atags
8292 if {![info exists allparents($id)]} {
8293 return {}
8295 set t1 [clock clicks -milliseconds]
8296 set argid $id
8297 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8298 # part-way along an arc; check that arc first
8299 set a [lindex $arcnos($id) 0]
8300 if {$arctags($a) ne {}} {
8301 validate_arctags $a
8302 set i [lsearch -exact $arcids($a) $id]
8303 foreach t $arctags($a) {
8304 set j [lsearch -exact $arcids($a) $t]
8305 if {$j > $i} {
8306 return $t
8310 if {![info exists arcend($a)]} {
8311 return {}
8313 set id $arcend($a)
8314 if {[info exists idtags($id)]} {
8315 return $id
8318 if {[info exists cached_atags($id)]} {
8319 return $cached_atags($id)
8322 set origid $id
8323 set todo [list $id]
8324 set queued($id) 1
8325 set taglist {}
8326 set nc 1
8327 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8328 set id [lindex $todo $i]
8329 set done($id) 1
8330 set td [info exists hastaggeddescendent($id)]
8331 if {!$td} {
8332 incr nc -1
8334 # ignore tags on starting node
8335 if {!$td && $i > 0} {
8336 if {[info exists idtags($id)]} {
8337 set tagloc($id) $id
8338 set td 1
8339 } elseif {[info exists cached_atags($id)]} {
8340 set tagloc($id) $cached_atags($id)
8341 set td 1
8344 foreach a $arcout($id) {
8345 if {!$td && $arctags($a) ne {}} {
8346 validate_arctags $a
8347 if {$arctags($a) ne {}} {
8348 lappend tagloc($id) [lindex $arctags($a) 0]
8351 if {![info exists arcend($a)]} continue
8352 set d $arcend($a)
8353 if {$td || $arctags($a) ne {}} {
8354 set tomark [list $d]
8355 for {set j 0} {$j < [llength $tomark]} {incr j} {
8356 set dd [lindex $tomark $j]
8357 if {![info exists hastaggeddescendent($dd)]} {
8358 if {[info exists done($dd)]} {
8359 foreach b $arcout($dd) {
8360 if {[info exists arcend($b)]} {
8361 lappend tomark $arcend($b)
8364 if {[info exists tagloc($dd)]} {
8365 unset tagloc($dd)
8367 } elseif {[info exists queued($dd)]} {
8368 incr nc -1
8370 set hastaggeddescendent($dd) 1
8374 if {![info exists queued($d)]} {
8375 lappend todo $d
8376 set queued($d) 1
8377 if {![info exists hastaggeddescendent($d)]} {
8378 incr nc
8383 set t2 [clock clicks -milliseconds]
8384 set loopix $i
8385 set tags {}
8386 foreach id [array names tagloc] {
8387 if {![info exists hastaggeddescendent($id)]} {
8388 foreach t $tagloc($id) {
8389 if {[lsearch -exact $tags $t] < 0} {
8390 lappend tags $t
8396 # remove tags that are ancestors of other tags
8397 for {set i 0} {$i < [llength $tags]} {incr i} {
8398 set a [lindex $tags $i]
8399 for {set j 0} {$j < $i} {incr j} {
8400 set b [lindex $tags $j]
8401 set r [anc_or_desc $a $b]
8402 if {$r == -1} {
8403 set tags [lreplace $tags $j $j]
8404 incr j -1
8405 incr i -1
8406 } elseif {$r == 1} {
8407 set tags [lreplace $tags $i $i]
8408 incr i -1
8409 break
8414 if {[array names growing] ne {}} {
8415 # graph isn't finished, need to check if any tag could get
8416 # eclipsed by another tag coming later. Simply ignore any
8417 # tags that could later get eclipsed.
8418 set ctags {}
8419 foreach t $tags {
8420 if {[is_certain $origid $t]} {
8421 lappend ctags $t
8424 if {$tags eq $ctags} {
8425 set cached_atags($origid) $tags
8426 } else {
8427 set tags $ctags
8429 } else {
8430 set cached_atags($origid) $tags
8432 set t3 [clock clicks -milliseconds]
8433 if {0 && $t3 - $t1 >= 100} {
8434 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8435 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8437 return $tags
8440 # Return the list of IDs that have heads that are descendents of id,
8441 # including id itself if it has a head.
8442 proc descheads {id} {
8443 global arcnos arcstart arcids archeads idheads cached_dheads
8444 global allparents
8446 if {![info exists allparents($id)]} {
8447 return {}
8449 set aret {}
8450 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8451 # part-way along an arc; check it first
8452 set a [lindex $arcnos($id) 0]
8453 if {$archeads($a) ne {}} {
8454 validate_archeads $a
8455 set i [lsearch -exact $arcids($a) $id]
8456 foreach t $archeads($a) {
8457 set j [lsearch -exact $arcids($a) $t]
8458 if {$j > $i} break
8459 lappend aret $t
8462 set id $arcstart($a)
8464 set origid $id
8465 set todo [list $id]
8466 set seen($id) 1
8467 set ret {}
8468 for {set i 0} {$i < [llength $todo]} {incr i} {
8469 set id [lindex $todo $i]
8470 if {[info exists cached_dheads($id)]} {
8471 set ret [concat $ret $cached_dheads($id)]
8472 } else {
8473 if {[info exists idheads($id)]} {
8474 lappend ret $id
8476 foreach a $arcnos($id) {
8477 if {$archeads($a) ne {}} {
8478 validate_archeads $a
8479 if {$archeads($a) ne {}} {
8480 set ret [concat $ret $archeads($a)]
8483 set d $arcstart($a)
8484 if {![info exists seen($d)]} {
8485 lappend todo $d
8486 set seen($d) 1
8491 set ret [lsort -unique $ret]
8492 set cached_dheads($origid) $ret
8493 return [concat $ret $aret]
8496 proc addedtag {id} {
8497 global arcnos arcout cached_dtags cached_atags
8499 if {![info exists arcnos($id)]} return
8500 if {![info exists arcout($id)]} {
8501 recalcarc [lindex $arcnos($id) 0]
8503 catch {unset cached_dtags}
8504 catch {unset cached_atags}
8507 proc addedhead {hid head} {
8508 global arcnos arcout cached_dheads
8510 if {![info exists arcnos($hid)]} return
8511 if {![info exists arcout($hid)]} {
8512 recalcarc [lindex $arcnos($hid) 0]
8514 catch {unset cached_dheads}
8517 proc removedhead {hid head} {
8518 global cached_dheads
8520 catch {unset cached_dheads}
8523 proc movedhead {hid head} {
8524 global arcnos arcout cached_dheads
8526 if {![info exists arcnos($hid)]} return
8527 if {![info exists arcout($hid)]} {
8528 recalcarc [lindex $arcnos($hid) 0]
8530 catch {unset cached_dheads}
8533 proc changedrefs {} {
8534 global cached_dheads cached_dtags cached_atags
8535 global arctags archeads arcnos arcout idheads idtags
8537 foreach id [concat [array names idheads] [array names idtags]] {
8538 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8539 set a [lindex $arcnos($id) 0]
8540 if {![info exists donearc($a)]} {
8541 recalcarc $a
8542 set donearc($a) 1
8546 catch {unset cached_dtags}
8547 catch {unset cached_atags}
8548 catch {unset cached_dheads}
8551 proc rereadrefs {} {
8552 global idtags idheads idotherrefs mainheadid
8554 set refids [concat [array names idtags] \
8555 [array names idheads] [array names idotherrefs]]
8556 foreach id $refids {
8557 if {![info exists ref($id)]} {
8558 set ref($id) [listrefs $id]
8561 set oldmainhead $mainheadid
8562 readrefs
8563 changedrefs
8564 set refids [lsort -unique [concat $refids [array names idtags] \
8565 [array names idheads] [array names idotherrefs]]]
8566 foreach id $refids {
8567 set v [listrefs $id]
8568 if {![info exists ref($id)] || $ref($id) != $v ||
8569 ($id eq $oldmainhead && $id ne $mainheadid) ||
8570 ($id eq $mainheadid && $id ne $oldmainhead)} {
8571 redrawtags $id
8574 run refill_reflist
8577 proc listrefs {id} {
8578 global idtags idheads idotherrefs
8580 set x {}
8581 if {[info exists idtags($id)]} {
8582 set x $idtags($id)
8584 set y {}
8585 if {[info exists idheads($id)]} {
8586 set y $idheads($id)
8588 set z {}
8589 if {[info exists idotherrefs($id)]} {
8590 set z $idotherrefs($id)
8592 return [list $x $y $z]
8595 proc showtag {tag isnew} {
8596 global ctext tagcontents tagids linknum tagobjid
8598 if {$isnew} {
8599 addtohistory [list showtag $tag 0]
8601 $ctext conf -state normal
8602 clear_ctext
8603 settabs 0
8604 set linknum 0
8605 if {![info exists tagcontents($tag)]} {
8606 catch {
8607 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8610 if {[info exists tagcontents($tag)]} {
8611 set text $tagcontents($tag)
8612 } else {
8613 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
8615 appendwithlinks $text {}
8616 $ctext conf -state disabled
8617 init_flist {}
8620 proc doquit {} {
8621 global stopped
8622 set stopped 100
8623 savestuff .
8624 destroy .
8627 proc mkfontdisp {font top which} {
8628 global fontattr fontpref $font
8630 set fontpref($font) [set $font]
8631 button $top.${font}but -text $which -font optionfont \
8632 -command [list choosefont $font $which]
8633 label $top.$font -relief flat -font $font \
8634 -text $fontattr($font,family) -justify left
8635 grid x $top.${font}but $top.$font -sticky w
8638 proc choosefont {font which} {
8639 global fontparam fontlist fonttop fontattr
8641 set fontparam(which) $which
8642 set fontparam(font) $font
8643 set fontparam(family) [font actual $font -family]
8644 set fontparam(size) $fontattr($font,size)
8645 set fontparam(weight) $fontattr($font,weight)
8646 set fontparam(slant) $fontattr($font,slant)
8647 set top .gitkfont
8648 set fonttop $top
8649 if {![winfo exists $top]} {
8650 font create sample
8651 eval font config sample [font actual $font]
8652 toplevel $top
8653 wm title $top [mc "Gitk font chooser"]
8654 label $top.l -textvariable fontparam(which)
8655 pack $top.l -side top
8656 set fontlist [lsort [font families]]
8657 frame $top.f
8658 listbox $top.f.fam -listvariable fontlist \
8659 -yscrollcommand [list $top.f.sb set]
8660 bind $top.f.fam <<ListboxSelect>> selfontfam
8661 scrollbar $top.f.sb -command [list $top.f.fam yview]
8662 pack $top.f.sb -side right -fill y
8663 pack $top.f.fam -side left -fill both -expand 1
8664 pack $top.f -side top -fill both -expand 1
8665 frame $top.g
8666 spinbox $top.g.size -from 4 -to 40 -width 4 \
8667 -textvariable fontparam(size) \
8668 -validatecommand {string is integer -strict %s}
8669 checkbutton $top.g.bold -padx 5 \
8670 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8671 -variable fontparam(weight) -onvalue bold -offvalue normal
8672 checkbutton $top.g.ital -padx 5 \
8673 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8674 -variable fontparam(slant) -onvalue italic -offvalue roman
8675 pack $top.g.size $top.g.bold $top.g.ital -side left
8676 pack $top.g -side top
8677 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8678 -background white
8679 $top.c create text 100 25 -anchor center -text $which -font sample \
8680 -fill black -tags text
8681 bind $top.c <Configure> [list centertext $top.c]
8682 pack $top.c -side top -fill x
8683 frame $top.buts
8684 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8685 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8686 grid $top.buts.ok $top.buts.can
8687 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8688 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8689 pack $top.buts -side bottom -fill x
8690 trace add variable fontparam write chg_fontparam
8691 } else {
8692 raise $top
8693 $top.c itemconf text -text $which
8695 set i [lsearch -exact $fontlist $fontparam(family)]
8696 if {$i >= 0} {
8697 $top.f.fam selection set $i
8698 $top.f.fam see $i
8702 proc centertext {w} {
8703 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8706 proc fontok {} {
8707 global fontparam fontpref prefstop
8709 set f $fontparam(font)
8710 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8711 if {$fontparam(weight) eq "bold"} {
8712 lappend fontpref($f) "bold"
8714 if {$fontparam(slant) eq "italic"} {
8715 lappend fontpref($f) "italic"
8717 set w $prefstop.$f
8718 $w conf -text $fontparam(family) -font $fontpref($f)
8720 fontcan
8723 proc fontcan {} {
8724 global fonttop fontparam
8726 if {[info exists fonttop]} {
8727 catch {destroy $fonttop}
8728 catch {font delete sample}
8729 unset fonttop
8730 unset fontparam
8734 proc selfontfam {} {
8735 global fonttop fontparam
8737 set i [$fonttop.f.fam curselection]
8738 if {$i ne {}} {
8739 set fontparam(family) [$fonttop.f.fam get $i]
8743 proc chg_fontparam {v sub op} {
8744 global fontparam
8746 font config sample -$sub $fontparam($sub)
8749 proc doprefs {} {
8750 global maxwidth maxgraphpct
8751 global oldprefs prefstop showneartags showlocalchanges
8752 global bgcolor fgcolor ctext diffcolors selectbgcolor
8753 global tabstop limitdiffs
8755 set top .gitkprefs
8756 set prefstop $top
8757 if {[winfo exists $top]} {
8758 raise $top
8759 return
8761 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8762 limitdiffs tabstop} {
8763 set oldprefs($v) [set $v]
8765 toplevel $top
8766 wm title $top [mc "Gitk preferences"]
8767 label $top.ldisp -text [mc "Commit list display options"]
8768 grid $top.ldisp - -sticky w -pady 10
8769 label $top.spacer -text " "
8770 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8771 -font optionfont
8772 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8773 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8774 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8775 -font optionfont
8776 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8777 grid x $top.maxpctl $top.maxpct -sticky w
8778 frame $top.showlocal
8779 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8780 checkbutton $top.showlocal.b -variable showlocalchanges
8781 pack $top.showlocal.b $top.showlocal.l -side left
8782 grid x $top.showlocal -sticky w
8784 label $top.ddisp -text [mc "Diff display options"]
8785 grid $top.ddisp - -sticky w -pady 10
8786 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8787 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8788 grid x $top.tabstopl $top.tabstop -sticky w
8789 frame $top.ntag
8790 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8791 checkbutton $top.ntag.b -variable showneartags
8792 pack $top.ntag.b $top.ntag.l -side left
8793 grid x $top.ntag -sticky w
8794 frame $top.ldiff
8795 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8796 checkbutton $top.ldiff.b -variable limitdiffs
8797 pack $top.ldiff.b $top.ldiff.l -side left
8798 grid x $top.ldiff -sticky w
8800 label $top.cdisp -text [mc "Colors: press to choose"]
8801 grid $top.cdisp - -sticky w -pady 10
8802 label $top.bg -padx 40 -relief sunk -background $bgcolor
8803 button $top.bgbut -text [mc "Background"] -font optionfont \
8804 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8805 grid x $top.bgbut $top.bg -sticky w
8806 label $top.fg -padx 40 -relief sunk -background $fgcolor
8807 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8808 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8809 grid x $top.fgbut $top.fg -sticky w
8810 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8811 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8812 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8813 [list $ctext tag conf d0 -foreground]]
8814 grid x $top.diffoldbut $top.diffold -sticky w
8815 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8816 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8817 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8818 [list $ctext tag conf d1 -foreground]]
8819 grid x $top.diffnewbut $top.diffnew -sticky w
8820 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8821 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8822 -command [list choosecolor diffcolors 2 $top.hunksep \
8823 "diff hunk header" \
8824 [list $ctext tag conf hunksep -foreground]]
8825 grid x $top.hunksepbut $top.hunksep -sticky w
8826 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8827 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8828 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8829 grid x $top.selbgbut $top.selbgsep -sticky w
8831 label $top.cfont -text [mc "Fonts: press to choose"]
8832 grid $top.cfont - -sticky w -pady 10
8833 mkfontdisp mainfont $top [mc "Main font"]
8834 mkfontdisp textfont $top [mc "Diff display font"]
8835 mkfontdisp uifont $top [mc "User interface font"]
8837 frame $top.buts
8838 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8839 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8840 grid $top.buts.ok $top.buts.can
8841 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8842 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8843 grid $top.buts - - -pady 10 -sticky ew
8844 bind $top <Visibility> "focus $top.buts.ok"
8847 proc choosecolor {v vi w x cmd} {
8848 global $v
8850 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8851 -title [mc "Gitk: choose color for %s" $x]]
8852 if {$c eq {}} return
8853 $w conf -background $c
8854 lset $v $vi $c
8855 eval $cmd $c
8858 proc setselbg {c} {
8859 global bglist cflist
8860 foreach w $bglist {
8861 $w configure -selectbackground $c
8863 $cflist tag configure highlight \
8864 -background [$cflist cget -selectbackground]
8865 allcanvs itemconf secsel -fill $c
8868 proc setbg {c} {
8869 global bglist
8871 foreach w $bglist {
8872 $w conf -background $c
8876 proc setfg {c} {
8877 global fglist canv
8879 foreach w $fglist {
8880 $w conf -foreground $c
8882 allcanvs itemconf text -fill $c
8883 $canv itemconf circle -outline $c
8886 proc prefscan {} {
8887 global oldprefs prefstop
8889 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8890 limitdiffs tabstop} {
8891 global $v
8892 set $v $oldprefs($v)
8894 catch {destroy $prefstop}
8895 unset prefstop
8896 fontcan
8899 proc prefsok {} {
8900 global maxwidth maxgraphpct
8901 global oldprefs prefstop showneartags showlocalchanges
8902 global fontpref mainfont textfont uifont
8903 global limitdiffs treediffs
8905 catch {destroy $prefstop}
8906 unset prefstop
8907 fontcan
8908 set fontchanged 0
8909 if {$mainfont ne $fontpref(mainfont)} {
8910 set mainfont $fontpref(mainfont)
8911 parsefont mainfont $mainfont
8912 eval font configure mainfont [fontflags mainfont]
8913 eval font configure mainfontbold [fontflags mainfont 1]
8914 setcoords
8915 set fontchanged 1
8917 if {$textfont ne $fontpref(textfont)} {
8918 set textfont $fontpref(textfont)
8919 parsefont textfont $textfont
8920 eval font configure textfont [fontflags textfont]
8921 eval font configure textfontbold [fontflags textfont 1]
8923 if {$uifont ne $fontpref(uifont)} {
8924 set uifont $fontpref(uifont)
8925 parsefont uifont $uifont
8926 eval font configure uifont [fontflags uifont]
8928 settabs
8929 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8930 if {$showlocalchanges} {
8931 doshowlocalchanges
8932 } else {
8933 dohidelocalchanges
8936 if {$limitdiffs != $oldprefs(limitdiffs)} {
8937 # treediffs elements are limited by path
8938 catch {unset treediffs}
8940 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8941 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8942 redisplay
8943 } elseif {$showneartags != $oldprefs(showneartags) ||
8944 $limitdiffs != $oldprefs(limitdiffs)} {
8945 reselectline
8949 proc formatdate {d} {
8950 global datetimeformat
8951 if {$d ne {}} {
8952 set d [clock format $d -format $datetimeformat]
8954 return $d
8957 # This list of encoding names and aliases is distilled from
8958 # http://www.iana.org/assignments/character-sets.
8959 # Not all of them are supported by Tcl.
8960 set encoding_aliases {
8961 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8962 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8963 { ISO-10646-UTF-1 csISO10646UTF1 }
8964 { ISO_646.basic:1983 ref csISO646basic1983 }
8965 { INVARIANT csINVARIANT }
8966 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8967 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8968 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8969 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8970 { NATS-DANO iso-ir-9-1 csNATSDANO }
8971 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8972 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8973 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8974 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8975 { ISO-2022-KR csISO2022KR }
8976 { EUC-KR csEUCKR }
8977 { ISO-2022-JP csISO2022JP }
8978 { ISO-2022-JP-2 csISO2022JP2 }
8979 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8980 csISO13JISC6220jp }
8981 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8982 { IT iso-ir-15 ISO646-IT csISO15Italian }
8983 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8984 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8985 { greek7-old iso-ir-18 csISO18Greek7Old }
8986 { latin-greek iso-ir-19 csISO19LatinGreek }
8987 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8988 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8989 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8990 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8991 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8992 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8993 { INIS iso-ir-49 csISO49INIS }
8994 { INIS-8 iso-ir-50 csISO50INIS8 }
8995 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8996 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8997 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8998 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8999 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9000 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9001 csISO60Norwegian1 }
9002 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9003 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9004 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9005 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9006 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9007 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9008 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9009 { greek7 iso-ir-88 csISO88Greek7 }
9010 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9011 { iso-ir-90 csISO90 }
9012 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9013 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9014 csISO92JISC62991984b }
9015 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9016 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9017 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9018 csISO95JIS62291984handadd }
9019 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9020 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9021 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9022 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9023 CP819 csISOLatin1 }
9024 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9025 { T.61-7bit iso-ir-102 csISO102T617bit }
9026 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9027 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9028 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9029 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9030 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9031 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9032 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9033 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9034 arabic csISOLatinArabic }
9035 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9036 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9037 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9038 greek greek8 csISOLatinGreek }
9039 { T.101-G2 iso-ir-128 csISO128T101G2 }
9040 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9041 csISOLatinHebrew }
9042 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9043 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9044 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9045 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9046 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9047 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9048 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9049 csISOLatinCyrillic }
9050 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9051 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9052 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9053 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9054 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9055 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9056 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9057 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9058 { ISO_10367-box iso-ir-155 csISO10367Box }
9059 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9060 { latin-lap lap iso-ir-158 csISO158Lap }
9061 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9062 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9063 { us-dk csUSDK }
9064 { dk-us csDKUS }
9065 { JIS_X0201 X0201 csHalfWidthKatakana }
9066 { KSC5636 ISO646-KR csKSC5636 }
9067 { ISO-10646-UCS-2 csUnicode }
9068 { ISO-10646-UCS-4 csUCS4 }
9069 { DEC-MCS dec csDECMCS }
9070 { hp-roman8 roman8 r8 csHPRoman8 }
9071 { macintosh mac csMacintosh }
9072 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9073 csIBM037 }
9074 { IBM038 EBCDIC-INT cp038 csIBM038 }
9075 { IBM273 CP273 csIBM273 }
9076 { IBM274 EBCDIC-BE CP274 csIBM274 }
9077 { IBM275 EBCDIC-BR cp275 csIBM275 }
9078 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9079 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9080 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9081 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9082 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9083 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9084 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9085 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9086 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9087 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9088 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9089 { IBM437 cp437 437 csPC8CodePage437 }
9090 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9091 { IBM775 cp775 csPC775Baltic }
9092 { IBM850 cp850 850 csPC850Multilingual }
9093 { IBM851 cp851 851 csIBM851 }
9094 { IBM852 cp852 852 csPCp852 }
9095 { IBM855 cp855 855 csIBM855 }
9096 { IBM857 cp857 857 csIBM857 }
9097 { IBM860 cp860 860 csIBM860 }
9098 { IBM861 cp861 861 cp-is csIBM861 }
9099 { IBM862 cp862 862 csPC862LatinHebrew }
9100 { IBM863 cp863 863 csIBM863 }
9101 { IBM864 cp864 csIBM864 }
9102 { IBM865 cp865 865 csIBM865 }
9103 { IBM866 cp866 866 csIBM866 }
9104 { IBM868 CP868 cp-ar csIBM868 }
9105 { IBM869 cp869 869 cp-gr csIBM869 }
9106 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9107 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9108 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9109 { IBM891 cp891 csIBM891 }
9110 { IBM903 cp903 csIBM903 }
9111 { IBM904 cp904 904 csIBBM904 }
9112 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9113 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9114 { IBM1026 CP1026 csIBM1026 }
9115 { EBCDIC-AT-DE csIBMEBCDICATDE }
9116 { EBCDIC-AT-DE-A csEBCDICATDEA }
9117 { EBCDIC-CA-FR csEBCDICCAFR }
9118 { EBCDIC-DK-NO csEBCDICDKNO }
9119 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9120 { EBCDIC-FI-SE csEBCDICFISE }
9121 { EBCDIC-FI-SE-A csEBCDICFISEA }
9122 { EBCDIC-FR csEBCDICFR }
9123 { EBCDIC-IT csEBCDICIT }
9124 { EBCDIC-PT csEBCDICPT }
9125 { EBCDIC-ES csEBCDICES }
9126 { EBCDIC-ES-A csEBCDICESA }
9127 { EBCDIC-ES-S csEBCDICESS }
9128 { EBCDIC-UK csEBCDICUK }
9129 { EBCDIC-US csEBCDICUS }
9130 { UNKNOWN-8BIT csUnknown8BiT }
9131 { MNEMONIC csMnemonic }
9132 { MNEM csMnem }
9133 { VISCII csVISCII }
9134 { VIQR csVIQR }
9135 { KOI8-R csKOI8R }
9136 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9137 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9138 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9139 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9140 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9141 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9142 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9143 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9144 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9145 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9146 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9147 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9148 { IBM1047 IBM-1047 }
9149 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9150 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9151 { UNICODE-1-1 csUnicode11 }
9152 { CESU-8 csCESU-8 }
9153 { BOCU-1 csBOCU-1 }
9154 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9155 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9156 l8 }
9157 { ISO-8859-15 ISO_8859-15 Latin-9 }
9158 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9159 { GBK CP936 MS936 windows-936 }
9160 { JIS_Encoding csJISEncoding }
9161 { Shift_JIS MS_Kanji csShiftJIS }
9162 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9163 EUC-JP }
9164 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9165 { ISO-10646-UCS-Basic csUnicodeASCII }
9166 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9167 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9168 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9169 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9170 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9171 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9172 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9173 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9174 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9175 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9176 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9177 { Ventura-US csVenturaUS }
9178 { Ventura-International csVenturaInternational }
9179 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9180 { PC8-Turkish csPC8Turkish }
9181 { IBM-Symbols csIBMSymbols }
9182 { IBM-Thai csIBMThai }
9183 { HP-Legal csHPLegal }
9184 { HP-Pi-font csHPPiFont }
9185 { HP-Math8 csHPMath8 }
9186 { Adobe-Symbol-Encoding csHPPSMath }
9187 { HP-DeskTop csHPDesktop }
9188 { Ventura-Math csVenturaMath }
9189 { Microsoft-Publishing csMicrosoftPublishing }
9190 { Windows-31J csWindows31J }
9191 { GB2312 csGB2312 }
9192 { Big5 csBig5 }
9195 proc tcl_encoding {enc} {
9196 global encoding_aliases
9197 set names [encoding names]
9198 set lcnames [string tolower $names]
9199 set enc [string tolower $enc]
9200 set i [lsearch -exact $lcnames $enc]
9201 if {$i < 0} {
9202 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9203 if {[regsub {^iso[-_]} $enc iso encx]} {
9204 set i [lsearch -exact $lcnames $encx]
9207 if {$i < 0} {
9208 foreach l $encoding_aliases {
9209 set ll [string tolower $l]
9210 if {[lsearch -exact $ll $enc] < 0} continue
9211 # look through the aliases for one that tcl knows about
9212 foreach e $ll {
9213 set i [lsearch -exact $lcnames $e]
9214 if {$i < 0} {
9215 if {[regsub {^iso[-_]} $e iso ex]} {
9216 set i [lsearch -exact $lcnames $ex]
9219 if {$i >= 0} break
9221 break
9224 if {$i >= 0} {
9225 return [lindex $names $i]
9227 return {}
9230 # First check that Tcl/Tk is recent enough
9231 if {[catch {package require Tk 8.4} err]} {
9232 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9233 Gitk requires at least Tcl/Tk 8.4."]
9234 exit 1
9237 # defaults...
9238 set datemode 0
9239 set wrcomcmd "git diff-tree --stdin -p --pretty"
9241 set gitencoding {}
9242 catch {
9243 set gitencoding [exec git config --get i18n.commitencoding]
9245 if {$gitencoding == ""} {
9246 set gitencoding "utf-8"
9248 set tclencoding [tcl_encoding $gitencoding]
9249 if {$tclencoding == {}} {
9250 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9253 set mainfont {Helvetica 9}
9254 set textfont {Courier 9}
9255 set uifont {Helvetica 9 bold}
9256 set tabstop 8
9257 set findmergefiles 0
9258 set maxgraphpct 50
9259 set maxwidth 16
9260 set revlistorder 0
9261 set fastdate 0
9262 set uparrowlen 5
9263 set downarrowlen 5
9264 set mingaplen 100
9265 set cmitmode "patch"
9266 set wrapcomment "none"
9267 set showneartags 1
9268 set maxrefs 20
9269 set maxlinelen 200
9270 set showlocalchanges 1
9271 set limitdiffs 1
9272 set datetimeformat "%Y-%m-%d %H:%M:%S"
9274 set colors {green red blue magenta darkgrey brown orange}
9275 set bgcolor white
9276 set fgcolor black
9277 set diffcolors {red "#00a000" blue}
9278 set diffcontext 3
9279 set ignorespace 0
9280 set selectbgcolor gray85
9282 ## For msgcat loading, first locate the installation location.
9283 if { [info exists ::env(GITK_MSGSDIR)] } {
9284 ## Msgsdir was manually set in the environment.
9285 set gitk_msgsdir $::env(GITK_MSGSDIR)
9286 } else {
9287 ## Let's guess the prefix from argv0.
9288 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9289 set gitk_libdir [file join $gitk_prefix share gitk lib]
9290 set gitk_msgsdir [file join $gitk_libdir msgs]
9291 unset gitk_prefix
9294 ## Internationalization (i18n) through msgcat and gettext. See
9295 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9296 package require msgcat
9297 namespace import ::msgcat::mc
9298 ## And eventually load the actual message catalog
9299 ::msgcat::mcload $gitk_msgsdir
9301 catch {source ~/.gitk}
9303 font create optionfont -family sans-serif -size -12
9305 parsefont mainfont $mainfont
9306 eval font create mainfont [fontflags mainfont]
9307 eval font create mainfontbold [fontflags mainfont 1]
9309 parsefont textfont $textfont
9310 eval font create textfont [fontflags textfont]
9311 eval font create textfontbold [fontflags textfont 1]
9313 parsefont uifont $uifont
9314 eval font create uifont [fontflags uifont]
9316 setoptions
9318 # check that we can find a .git directory somewhere...
9319 if {[catch {set gitdir [gitdir]}]} {
9320 show_error {} . [mc "Cannot find a git repository here."]
9321 exit 1
9323 if {![file isdirectory $gitdir]} {
9324 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9325 exit 1
9328 set mergeonly 0
9329 set revtreeargs {}
9330 set cmdline_files {}
9331 set i 0
9332 foreach arg $argv {
9333 switch -- $arg {
9334 "" { }
9335 "-d" { set datemode 1 }
9336 "--merge" {
9337 set mergeonly 1
9338 lappend revtreeargs $arg
9340 "--" {
9341 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9342 break
9344 default {
9345 lappend revtreeargs $arg
9348 incr i
9351 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9352 # no -- on command line, but some arguments (other than -d)
9353 if {[catch {
9354 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9355 set cmdline_files [split $f "\n"]
9356 set n [llength $cmdline_files]
9357 set revtreeargs [lrange $revtreeargs 0 end-$n]
9358 # Unfortunately git rev-parse doesn't produce an error when
9359 # something is both a revision and a filename. To be consistent
9360 # with git log and git rev-list, check revtreeargs for filenames.
9361 foreach arg $revtreeargs {
9362 if {[file exists $arg]} {
9363 show_error {} . [mc "Ambiguous argument '%s': both revision\
9364 and filename" $arg]
9365 exit 1
9368 } err]} {
9369 # unfortunately we get both stdout and stderr in $err,
9370 # so look for "fatal:".
9371 set i [string first "fatal:" $err]
9372 if {$i > 0} {
9373 set err [string range $err [expr {$i + 6}] end]
9375 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9376 exit 1
9380 if {$mergeonly} {
9381 # find the list of unmerged files
9382 set mlist {}
9383 set nr_unmerged 0
9384 if {[catch {
9385 set fd [open "| git ls-files -u" r]
9386 } err]} {
9387 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9388 exit 1
9390 while {[gets $fd line] >= 0} {
9391 set i [string first "\t" $line]
9392 if {$i < 0} continue
9393 set fname [string range $line [expr {$i+1}] end]
9394 if {[lsearch -exact $mlist $fname] >= 0} continue
9395 incr nr_unmerged
9396 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9397 lappend mlist $fname
9400 catch {close $fd}
9401 if {$mlist eq {}} {
9402 if {$nr_unmerged == 0} {
9403 show_error {} . [mc "No files selected: --merge specified but\
9404 no files are unmerged."]
9405 } else {
9406 show_error {} . [mc "No files selected: --merge specified but\
9407 no unmerged files are within file limit."]
9409 exit 1
9411 set cmdline_files $mlist
9414 set nullid "0000000000000000000000000000000000000000"
9415 set nullid2 "0000000000000000000000000000000000000001"
9417 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9419 set runq {}
9420 set history {}
9421 set historyindex 0
9422 set fh_serial 0
9423 set nhl_names {}
9424 set highlight_paths {}
9425 set findpattern {}
9426 set searchdirn -forwards
9427 set boldrows {}
9428 set boldnamerows {}
9429 set diffelide {0 0}
9430 set markingmatches 0
9431 set linkentercount 0
9432 set need_redisplay 0
9433 set nrows_drawn 0
9434 set firsttabstop 0
9436 set nextviewnum 1
9437 set curview 0
9438 set selectedview 0
9439 set selectedhlview [mc "None"]
9440 set highlight_related [mc "None"]
9441 set highlight_files {}
9442 set viewfiles(0) {}
9443 set viewperm(0) 0
9444 set viewargs(0) {}
9446 set loginstance 0
9447 set cmdlineok 0
9448 set stopped 0
9449 set stuffsaved 0
9450 set patchnum 0
9451 set lserial 0
9452 setcoords
9453 makewindow
9454 # wait for the window to become visible
9455 tkwait visibility .
9456 wm title . "[file tail $argv0]: [file tail [pwd]]"
9457 readrefs
9459 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9460 # create a view for the files/dirs specified on the command line
9461 set curview 1
9462 set selectedview 1
9463 set nextviewnum 2
9464 set viewname(1) [mc "Command line"]
9465 set viewfiles(1) $cmdline_files
9466 set viewargs(1) $revtreeargs
9467 set viewperm(1) 0
9468 addviewmenu 1
9469 .bar.view entryconf [mc "Edit view..."] -state normal
9470 .bar.view entryconf [mc "Delete view"] -state normal
9473 if {[info exists permviews]} {
9474 foreach v $permviews {
9475 set n $nextviewnum
9476 incr nextviewnum
9477 set viewname($n) [lindex $v 0]
9478 set viewfiles($n) [lindex $v 1]
9479 set viewargs($n) [lindex $v 2]
9480 set viewperm($n) 1
9481 addviewmenu $n
9484 getcommits