gitk: Don't filter view arguments through git rev-parse
[git/mingw.git] / gitk
blob17f889d26dcf575000ecadd4ea970bc40e6f9c12
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
98 global showlocalchanges commitinterest mainheadid
99 global progressdirn progresscoords proglastnc curview
100 global 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 varcinit $view
109 if {[catch {
110 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
111 --boundary $viewargs($view) "--" $viewfiles($view)] r]
112 } err]} {
113 error_popup "[mc "Error executing git log:"] $err"
114 exit 1
116 set i [incr loginstance]
117 set viewinstances($view) [list $i]
118 set commfd($i) $fd
119 set leftover($i) {}
120 if {$showlocalchanges} {
121 lappend commitinterest($mainheadid) {dodiffindex}
123 fconfigure $fd -blocking 0 -translation lf -eofchar {}
124 if {$tclencoding != {}} {
125 fconfigure $fd -encoding $tclencoding
127 filerun $fd [list getcommitlines $fd $i $view 0]
128 nowbusy $view [mc "Reading"]
129 if {$view == $curview} {
130 set progressdirn 1
131 set progresscoords {0 0}
132 set proglastnc 0
133 set pending_select $mainheadid
137 proc stop_rev_list {view} {
138 global commfd viewinstances leftover
140 foreach inst $viewinstances($view) {
141 set fd $commfd($inst)
142 catch {
143 set pid [pid $fd]
144 exec kill $pid
146 catch {close $fd}
147 nukefile $fd
148 unset commfd($inst)
149 unset leftover($inst)
151 set viewinstances($view) {}
154 proc getcommits {} {
155 global canv curview need_redisplay
157 initlayout
158 start_rev_list $curview
159 show_status [mc "Reading commits..."]
160 set need_redisplay 1
163 proc updatecommits {} {
164 global curview viewargs viewfiles viewinstances
165 global viewactive viewcomplete loginstance tclencoding mainheadid
166 global startmsecs commfd showneartags showlocalchanges leftover
167 global mainheadid pending_select
169 set oldmainid $mainheadid
170 rereadrefs
171 if {$showlocalchanges} {
172 if {$mainheadid ne $oldmainid} {
173 dohidelocalchanges
175 if {[commitinview $mainheadid $curview]} {
176 dodiffindex
179 set view $curview
180 if {[catch {
181 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
182 --boundary $viewargs($view) --not [seeds $view] \
183 "--" $viewfiles($view)] r]
184 } err]} {
185 error_popup "Error executing git log: $err"
186 exit 1
188 if {$viewactive($view) == 0} {
189 set startmsecs [clock clicks -milliseconds]
191 set i [incr loginstance]
192 lappend viewinstances($view) $i
193 set commfd($i) $fd
194 set leftover($i) {}
195 fconfigure $fd -blocking 0 -translation lf -eofchar {}
196 if {$tclencoding != {}} {
197 fconfigure $fd -encoding $tclencoding
199 filerun $fd [list getcommitlines $fd $i $view 1]
200 incr viewactive($view)
201 set viewcomplete($view) 0
202 set pending_select $mainheadid
203 nowbusy $view "Reading"
204 if {$showneartags} {
205 getallcommits
209 proc reloadcommits {} {
210 global curview viewcomplete selectedline currentid thickerline
211 global showneartags treediffs commitinterest cached_commitrow
212 global progresscoords targetid
214 if {!$viewcomplete($curview)} {
215 stop_rev_list $curview
216 set progresscoords {0 0}
217 adjustprogress
219 resetvarcs $curview
220 catch {unset selectedline}
221 catch {unset currentid}
222 catch {unset thickerline}
223 catch {unset treediffs}
224 readrefs
225 changedrefs
226 if {$showneartags} {
227 getallcommits
229 clear_display
230 catch {unset commitinterest}
231 catch {unset cached_commitrow}
232 catch {unset targetid}
233 setcanvscroll
234 getcommits
235 return 0
238 # This makes a string representation of a positive integer which
239 # sorts as a string in numerical order
240 proc strrep {n} {
241 if {$n < 16} {
242 return [format "%x" $n]
243 } elseif {$n < 256} {
244 return [format "x%.2x" $n]
245 } elseif {$n < 65536} {
246 return [format "y%.4x" $n]
248 return [format "z%.8x" $n]
251 # Procedures used in reordering commits from git log (without
252 # --topo-order) into the order for display.
254 proc varcinit {view} {
255 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
256 global vtokmod varcmod vrowmod varcix vlastins
258 set varcstart($view) {{}}
259 set vupptr($view) {0}
260 set vdownptr($view) {0}
261 set vleftptr($view) {0}
262 set vbackptr($view) {0}
263 set varctok($view) {{}}
264 set varcrow($view) {{}}
265 set vtokmod($view) {}
266 set varcmod($view) 0
267 set vrowmod($view) 0
268 set varcix($view) {{}}
269 set vlastins($view) {0}
272 proc resetvarcs {view} {
273 global varcid varccommits parents children vseedcount ordertok
275 foreach vid [array names varcid $view,*] {
276 unset varcid($vid)
277 unset children($vid)
278 unset parents($vid)
280 # some commits might have children but haven't been seen yet
281 foreach vid [array names children $view,*] {
282 unset children($vid)
284 foreach va [array names varccommits $view,*] {
285 unset varccommits($va)
287 foreach vd [array names vseedcount $view,*] {
288 unset vseedcount($vd)
290 catch {unset ordertok}
293 # returns a list of the commits with no children
294 proc seeds {v} {
295 global vdownptr vleftptr varcstart
297 set ret {}
298 set a [lindex $vdownptr($v) 0]
299 while {$a != 0} {
300 lappend ret [lindex $varcstart($v) $a]
301 set a [lindex $vleftptr($v) $a]
303 return $ret
306 proc newvarc {view id} {
307 global varcid varctok parents children datemode
308 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
309 global commitdata commitinfo vseedcount varccommits vlastins
311 set a [llength $varctok($view)]
312 set vid $view,$id
313 if {[llength $children($vid)] == 0 || $datemode} {
314 if {![info exists commitinfo($id)]} {
315 parsecommit $id $commitdata($id) 1
317 set cdate [lindex $commitinfo($id) 4]
318 if {![string is integer -strict $cdate]} {
319 set cdate 0
321 if {![info exists vseedcount($view,$cdate)]} {
322 set vseedcount($view,$cdate) -1
324 set c [incr vseedcount($view,$cdate)]
325 set cdate [expr {$cdate ^ 0xffffffff}]
326 set tok "s[strrep $cdate][strrep $c]"
327 } else {
328 set tok {}
330 set ka 0
331 if {[llength $children($vid)] > 0} {
332 set kid [lindex $children($vid) end]
333 set k $varcid($view,$kid)
334 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
335 set ki $kid
336 set ka $k
337 set tok [lindex $varctok($view) $k]
340 if {$ka != 0} {
341 set i [lsearch -exact $parents($view,$ki) $id]
342 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
343 append tok [strrep $j]
345 set c [lindex $vlastins($view) $ka]
346 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
347 set c $ka
348 set b [lindex $vdownptr($view) $ka]
349 } else {
350 set b [lindex $vleftptr($view) $c]
352 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
353 set c $b
354 set b [lindex $vleftptr($view) $c]
356 if {$c == $ka} {
357 lset vdownptr($view) $ka $a
358 lappend vbackptr($view) 0
359 } else {
360 lset vleftptr($view) $c $a
361 lappend vbackptr($view) $c
363 lset vlastins($view) $ka $a
364 lappend vupptr($view) $ka
365 lappend vleftptr($view) $b
366 if {$b != 0} {
367 lset vbackptr($view) $b $a
369 lappend varctok($view) $tok
370 lappend varcstart($view) $id
371 lappend vdownptr($view) 0
372 lappend varcrow($view) {}
373 lappend varcix($view) {}
374 set varccommits($view,$a) {}
375 lappend vlastins($view) 0
376 return $a
379 proc splitvarc {p v} {
380 global varcid varcstart varccommits varctok
381 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
383 set oa $varcid($v,$p)
384 set ac $varccommits($v,$oa)
385 set i [lsearch -exact $varccommits($v,$oa) $p]
386 if {$i <= 0} return
387 set na [llength $varctok($v)]
388 # "%" sorts before "0"...
389 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
390 lappend varctok($v) $tok
391 lappend varcrow($v) {}
392 lappend varcix($v) {}
393 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
394 set varccommits($v,$na) [lrange $ac $i end]
395 lappend varcstart($v) $p
396 foreach id $varccommits($v,$na) {
397 set varcid($v,$id) $na
399 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
400 lappend vlastins($v) [lindex $vlastins($v) $oa]
401 lset vdownptr($v) $oa $na
402 lset vlastins($v) $oa 0
403 lappend vupptr($v) $oa
404 lappend vleftptr($v) 0
405 lappend vbackptr($v) 0
406 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
407 lset vupptr($v) $b $na
411 proc renumbervarc {a v} {
412 global parents children varctok varcstart varccommits
413 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
415 set t1 [clock clicks -milliseconds]
416 set todo {}
417 set isrelated($a) 1
418 set kidchanged($a) 1
419 set ntot 0
420 while {$a != 0} {
421 if {[info exists isrelated($a)]} {
422 lappend todo $a
423 set id [lindex $varccommits($v,$a) end]
424 foreach p $parents($v,$id) {
425 if {[info exists varcid($v,$p)]} {
426 set isrelated($varcid($v,$p)) 1
430 incr ntot
431 set b [lindex $vdownptr($v) $a]
432 if {$b == 0} {
433 while {$a != 0} {
434 set b [lindex $vleftptr($v) $a]
435 if {$b != 0} break
436 set a [lindex $vupptr($v) $a]
439 set a $b
441 foreach a $todo {
442 if {![info exists kidchanged($a)]} continue
443 set id [lindex $varcstart($v) $a]
444 if {[llength $children($v,$id)] > 1} {
445 set children($v,$id) [lsort -command [list vtokcmp $v] \
446 $children($v,$id)]
448 set oldtok [lindex $varctok($v) $a]
449 if {!$datemode} {
450 set tok {}
451 } else {
452 set tok $oldtok
454 set ka 0
455 set kid [last_real_child $v,$id]
456 if {$kid ne {}} {
457 set k $varcid($v,$kid)
458 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
459 set ki $kid
460 set ka $k
461 set tok [lindex $varctok($v) $k]
464 if {$ka != 0} {
465 set i [lsearch -exact $parents($v,$ki) $id]
466 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
467 append tok [strrep $j]
469 if {$tok eq $oldtok} {
470 continue
472 set id [lindex $varccommits($v,$a) end]
473 foreach p $parents($v,$id) {
474 if {[info exists varcid($v,$p)]} {
475 set kidchanged($varcid($v,$p)) 1
476 } else {
477 set sortkids($p) 1
480 lset varctok($v) $a $tok
481 set b [lindex $vupptr($v) $a]
482 if {$b != $ka} {
483 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
484 modify_arc $v $ka
486 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
487 modify_arc $v $b
489 set c [lindex $vbackptr($v) $a]
490 set d [lindex $vleftptr($v) $a]
491 if {$c == 0} {
492 lset vdownptr($v) $b $d
493 } else {
494 lset vleftptr($v) $c $d
496 if {$d != 0} {
497 lset vbackptr($v) $d $c
499 if {[lindex $vlastins($v) $b] == $a} {
500 lset vlastins($v) $b $c
502 lset vupptr($v) $a $ka
503 set c [lindex $vlastins($v) $ka]
504 if {$c == 0 || \
505 [string compare $tok [lindex $varctok($v) $c]] < 0} {
506 set c $ka
507 set b [lindex $vdownptr($v) $ka]
508 } else {
509 set b [lindex $vleftptr($v) $c]
511 while {$b != 0 && \
512 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
513 set c $b
514 set b [lindex $vleftptr($v) $c]
516 if {$c == $ka} {
517 lset vdownptr($v) $ka $a
518 lset vbackptr($v) $a 0
519 } else {
520 lset vleftptr($v) $c $a
521 lset vbackptr($v) $a $c
523 lset vleftptr($v) $a $b
524 if {$b != 0} {
525 lset vbackptr($v) $b $a
527 lset vlastins($v) $ka $a
530 foreach id [array names sortkids] {
531 if {[llength $children($v,$id)] > 1} {
532 set children($v,$id) [lsort -command [list vtokcmp $v] \
533 $children($v,$id)]
536 set t2 [clock clicks -milliseconds]
537 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
540 # Fix up the graph after we have found out that in view $v,
541 # $p (a commit that we have already seen) is actually the parent
542 # of the last commit in arc $a.
543 proc fix_reversal {p a v} {
544 global varcid varcstart varctok vupptr
546 set pa $varcid($v,$p)
547 if {$p ne [lindex $varcstart($v) $pa]} {
548 splitvarc $p $v
549 set pa $varcid($v,$p)
551 # seeds always need to be renumbered
552 if {[lindex $vupptr($v) $pa] == 0 ||
553 [string compare [lindex $varctok($v) $a] \
554 [lindex $varctok($v) $pa]] > 0} {
555 renumbervarc $pa $v
559 proc insertrow {id p v} {
560 global cmitlisted children parents varcid varctok vtokmod
561 global varccommits ordertok commitidx numcommits curview
562 global targetid targetrow
564 readcommit $id
565 set vid $v,$id
566 set cmitlisted($vid) 1
567 set children($vid) {}
568 set parents($vid) [list $p]
569 set a [newvarc $v $id]
570 set varcid($vid) $a
571 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
572 modify_arc $v $a
574 lappend varccommits($v,$a) $id
575 set vp $v,$p
576 if {[llength [lappend children($vp) $id]] > 1} {
577 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
578 catch {unset ordertok}
580 fix_reversal $p $a $v
581 incr commitidx($v)
582 if {$v == $curview} {
583 set numcommits $commitidx($v)
584 setcanvscroll
585 if {[info exists targetid]} {
586 if {![comes_before $targetid $p]} {
587 incr targetrow
593 proc insertfakerow {id p} {
594 global varcid varccommits parents children cmitlisted
595 global commitidx varctok vtokmod targetid targetrow curview numcommits
597 set v $curview
598 set a $varcid($v,$p)
599 set i [lsearch -exact $varccommits($v,$a) $p]
600 if {$i < 0} {
601 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
602 return
604 set children($v,$id) {}
605 set parents($v,$id) [list $p]
606 set varcid($v,$id) $a
607 lappend children($v,$p) $id
608 set cmitlisted($v,$id) 1
609 set numcommits [incr commitidx($v)]
610 # note we deliberately don't update varcstart($v) even if $i == 0
611 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
612 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
613 modify_arc $v $a $i
615 if {[info exists targetid]} {
616 if {![comes_before $targetid $p]} {
617 incr targetrow
620 setcanvscroll
621 drawvisible
624 proc removefakerow {id} {
625 global varcid varccommits parents children commitidx
626 global varctok vtokmod cmitlisted currentid selectedline
627 global targetid curview numcommits
629 set v $curview
630 if {[llength $parents($v,$id)] != 1} {
631 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
632 return
634 set p [lindex $parents($v,$id) 0]
635 set a $varcid($v,$id)
636 set i [lsearch -exact $varccommits($v,$a) $id]
637 if {$i < 0} {
638 puts "oops: removefakerow can't find [shortids $id] on arc $a"
639 return
641 unset varcid($v,$id)
642 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
643 unset parents($v,$id)
644 unset children($v,$id)
645 unset cmitlisted($v,$id)
646 set numcommits [incr commitidx($v) -1]
647 set j [lsearch -exact $children($v,$p) $id]
648 if {$j >= 0} {
649 set children($v,$p) [lreplace $children($v,$p) $j $j]
651 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
652 modify_arc $v $a $i
654 if {[info exist currentid] && $id eq $currentid} {
655 unset currentid
656 unset selectedline
658 if {[info exists targetid] && $targetid eq $id} {
659 set targetid $p
661 setcanvscroll
662 drawvisible
665 proc first_real_child {vp} {
666 global children nullid nullid2
668 foreach id $children($vp) {
669 if {$id ne $nullid && $id ne $nullid2} {
670 return $id
673 return {}
676 proc last_real_child {vp} {
677 global children nullid nullid2
679 set kids $children($vp)
680 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
681 set id [lindex $kids $i]
682 if {$id ne $nullid && $id ne $nullid2} {
683 return $id
686 return {}
689 proc vtokcmp {v a b} {
690 global varctok varcid
692 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
693 [lindex $varctok($v) $varcid($v,$b)]]
696 proc modify_arc {v a {lim {}}} {
697 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
699 set vtokmod($v) [lindex $varctok($v) $a]
700 set varcmod($v) $a
701 if {$v == $curview} {
702 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
703 set a [lindex $vupptr($v) $a]
704 set lim {}
706 set r 0
707 if {$a != 0} {
708 if {$lim eq {}} {
709 set lim [llength $varccommits($v,$a)]
711 set r [expr {[lindex $varcrow($v) $a] + $lim}]
713 set vrowmod($v) $r
714 undolayout $r
718 proc update_arcrows {v} {
719 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
720 global varcid vrownum varcorder varcix varccommits
721 global vupptr vdownptr vleftptr varctok
722 global displayorder parentlist curview cached_commitrow
724 set narctot [expr {[llength $varctok($v)] - 1}]
725 set a $varcmod($v)
726 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
727 # go up the tree until we find something that has a row number,
728 # or we get to a seed
729 set a [lindex $vupptr($v) $a]
731 if {$a == 0} {
732 set a [lindex $vdownptr($v) 0]
733 if {$a == 0} return
734 set vrownum($v) {0}
735 set varcorder($v) [list $a]
736 lset varcix($v) $a 0
737 lset varcrow($v) $a 0
738 set arcn 0
739 set row 0
740 } else {
741 set arcn [lindex $varcix($v) $a]
742 # see if a is the last arc; if so, nothing to do
743 if {$arcn == $narctot - 1} {
744 return
746 if {[llength $vrownum($v)] > $arcn + 1} {
747 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
748 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
750 set row [lindex $varcrow($v) $a]
752 if {$v == $curview} {
753 if {[llength $displayorder] > $vrowmod($v)} {
754 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
755 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
757 catch {unset cached_commitrow}
759 while {1} {
760 set p $a
761 incr row [llength $varccommits($v,$a)]
762 # go down if possible
763 set b [lindex $vdownptr($v) $a]
764 if {$b == 0} {
765 # if not, go left, or go up until we can go left
766 while {$a != 0} {
767 set b [lindex $vleftptr($v) $a]
768 if {$b != 0} break
769 set a [lindex $vupptr($v) $a]
771 if {$a == 0} break
773 set a $b
774 incr arcn
775 lappend vrownum($v) $row
776 lappend varcorder($v) $a
777 lset varcix($v) $a $arcn
778 lset varcrow($v) $a $row
780 set vtokmod($v) [lindex $varctok($v) $p]
781 set varcmod($v) $p
782 set vrowmod($v) $row
783 if {[info exists currentid]} {
784 set selectedline [rowofcommit $currentid]
788 # Test whether view $v contains commit $id
789 proc commitinview {id v} {
790 global varcid
792 return [info exists varcid($v,$id)]
795 # Return the row number for commit $id in the current view
796 proc rowofcommit {id} {
797 global varcid varccommits varcrow curview cached_commitrow
798 global varctok vtokmod
800 set v $curview
801 if {![info exists varcid($v,$id)]} {
802 puts "oops rowofcommit no arc for [shortids $id]"
803 return {}
805 set a $varcid($v,$id)
806 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
807 update_arcrows $v
809 if {[info exists cached_commitrow($id)]} {
810 return $cached_commitrow($id)
812 set i [lsearch -exact $varccommits($v,$a) $id]
813 if {$i < 0} {
814 puts "oops didn't find commit [shortids $id] in arc $a"
815 return {}
817 incr i [lindex $varcrow($v) $a]
818 set cached_commitrow($id) $i
819 return $i
822 # Returns 1 if a is on an earlier row than b, otherwise 0
823 proc comes_before {a b} {
824 global varcid varctok curview
826 set v $curview
827 if {$a eq $b || ![info exists varcid($v,$a)] || \
828 ![info exists varcid($v,$b)]} {
829 return 0
831 if {$varcid($v,$a) != $varcid($v,$b)} {
832 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
833 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
835 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
838 proc bsearch {l elt} {
839 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
840 return 0
842 set lo 0
843 set hi [llength $l]
844 while {$hi - $lo > 1} {
845 set mid [expr {int(($lo + $hi) / 2)}]
846 set t [lindex $l $mid]
847 if {$elt < $t} {
848 set hi $mid
849 } elseif {$elt > $t} {
850 set lo $mid
851 } else {
852 return $mid
855 return $lo
858 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
859 proc make_disporder {start end} {
860 global vrownum curview commitidx displayorder parentlist
861 global varccommits varcorder parents vrowmod varcrow
862 global d_valid_start d_valid_end
864 if {$end > $vrowmod($curview)} {
865 update_arcrows $curview
867 set ai [bsearch $vrownum($curview) $start]
868 set start [lindex $vrownum($curview) $ai]
869 set narc [llength $vrownum($curview)]
870 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
871 set a [lindex $varcorder($curview) $ai]
872 set l [llength $displayorder]
873 set al [llength $varccommits($curview,$a)]
874 if {$l < $r + $al} {
875 if {$l < $r} {
876 set pad [ntimes [expr {$r - $l}] {}]
877 set displayorder [concat $displayorder $pad]
878 set parentlist [concat $parentlist $pad]
879 } elseif {$l > $r} {
880 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
881 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
883 foreach id $varccommits($curview,$a) {
884 lappend displayorder $id
885 lappend parentlist $parents($curview,$id)
887 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
888 set i $r
889 foreach id $varccommits($curview,$a) {
890 lset displayorder $i $id
891 lset parentlist $i $parents($curview,$id)
892 incr i
895 incr r $al
899 proc commitonrow {row} {
900 global displayorder
902 set id [lindex $displayorder $row]
903 if {$id eq {}} {
904 make_disporder $row [expr {$row + 1}]
905 set id [lindex $displayorder $row]
907 return $id
910 proc closevarcs {v} {
911 global varctok varccommits varcid parents children
912 global cmitlisted commitidx commitinterest vtokmod
914 set missing_parents 0
915 set scripts {}
916 set narcs [llength $varctok($v)]
917 for {set a 1} {$a < $narcs} {incr a} {
918 set id [lindex $varccommits($v,$a) end]
919 foreach p $parents($v,$id) {
920 if {[info exists varcid($v,$p)]} continue
921 # add p as a new commit
922 incr missing_parents
923 set cmitlisted($v,$p) 0
924 set parents($v,$p) {}
925 if {[llength $children($v,$p)] == 1 &&
926 [llength $parents($v,$id)] == 1} {
927 set b $a
928 } else {
929 set b [newvarc $v $p]
931 set varcid($v,$p) $b
932 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
933 modify_arc $v $b
935 lappend varccommits($v,$b) $p
936 incr commitidx($v)
937 if {[info exists commitinterest($p)]} {
938 foreach script $commitinterest($p) {
939 lappend scripts [string map [list "%I" $p] $script]
941 unset commitinterest($id)
945 if {$missing_parents > 0} {
946 foreach s $scripts {
947 eval $s
952 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
953 # Assumes we already have an arc for $rwid.
954 proc rewrite_commit {v id rwid} {
955 global children parents varcid varctok vtokmod varccommits
957 foreach ch $children($v,$id) {
958 # make $rwid be $ch's parent in place of $id
959 set i [lsearch -exact $parents($v,$ch) $id]
960 if {$i < 0} {
961 puts "oops rewrite_commit didn't find $id in parent list for $ch"
963 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
964 # add $ch to $rwid's children and sort the list if necessary
965 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
966 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
967 $children($v,$rwid)]
969 # fix the graph after joining $id to $rwid
970 set a $varcid($v,$ch)
971 fix_reversal $rwid $a $v
972 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
973 # parentlist is wrong for the last element of arc $a
974 # even if displayorder is right, hence the 3rd arg here
975 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
980 proc getcommitlines {fd inst view updating} {
981 global cmitlisted commitinterest leftover
982 global commitidx commitdata datemode
983 global parents children curview hlview
984 global idpending ordertok
985 global varccommits varcid varctok vtokmod viewfiles
987 set stuff [read $fd 500000]
988 # git log doesn't terminate the last commit with a null...
989 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
990 set stuff "\0"
992 if {$stuff == {}} {
993 if {![eof $fd]} {
994 return 1
996 global commfd viewcomplete viewactive viewname progresscoords
997 global viewinstances
998 unset commfd($inst)
999 set i [lsearch -exact $viewinstances($view) $inst]
1000 if {$i >= 0} {
1001 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1003 # set it blocking so we wait for the process to terminate
1004 fconfigure $fd -blocking 1
1005 if {[catch {close $fd} err]} {
1006 set fv {}
1007 if {$view != $curview} {
1008 set fv " for the \"$viewname($view)\" view"
1010 if {[string range $err 0 4] == "usage"} {
1011 set err "Gitk: error reading commits$fv:\
1012 bad arguments to git rev-list."
1013 if {$viewname($view) eq "Command line"} {
1014 append err \
1015 " (Note: arguments to gitk are passed to git rev-list\
1016 to allow selection of commits to be displayed.)"
1018 } else {
1019 set err "Error reading commits$fv: $err"
1021 error_popup $err
1023 if {[incr viewactive($view) -1] <= 0} {
1024 set viewcomplete($view) 1
1025 # Check if we have seen any ids listed as parents that haven't
1026 # appeared in the list
1027 closevarcs $view
1028 notbusy $view
1029 set progresscoords {0 0}
1030 adjustprogress
1032 if {$view == $curview} {
1033 run chewcommits
1035 return 0
1037 set start 0
1038 set gotsome 0
1039 set scripts {}
1040 while 1 {
1041 set i [string first "\0" $stuff $start]
1042 if {$i < 0} {
1043 append leftover($inst) [string range $stuff $start end]
1044 break
1046 if {$start == 0} {
1047 set cmit $leftover($inst)
1048 append cmit [string range $stuff 0 [expr {$i - 1}]]
1049 set leftover($inst) {}
1050 } else {
1051 set cmit [string range $stuff $start [expr {$i - 1}]]
1053 set start [expr {$i + 1}]
1054 set j [string first "\n" $cmit]
1055 set ok 0
1056 set listed 1
1057 if {$j >= 0 && [string match "commit *" $cmit]} {
1058 set ids [string range $cmit 7 [expr {$j - 1}]]
1059 if {[string match {[-^<>]*} $ids]} {
1060 switch -- [string index $ids 0] {
1061 "-" {set listed 0}
1062 "^" {set listed 2}
1063 "<" {set listed 3}
1064 ">" {set listed 4}
1066 set ids [string range $ids 1 end]
1068 set ok 1
1069 foreach id $ids {
1070 if {[string length $id] != 40} {
1071 set ok 0
1072 break
1076 if {!$ok} {
1077 set shortcmit $cmit
1078 if {[string length $shortcmit] > 80} {
1079 set shortcmit "[string range $shortcmit 0 80]..."
1081 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1082 exit 1
1084 set id [lindex $ids 0]
1085 set vid $view,$id
1087 if {!$listed && $updating && ![info exists varcid($vid)] &&
1088 $viewfiles($view) ne {}} {
1089 # git log doesn't rewrite parents for unlisted commits
1090 # when doing path limiting, so work around that here
1091 # by working out the rewritten parent with git rev-list
1092 # and if we already know about it, using the rewritten
1093 # parent as a substitute parent for $id's children.
1094 if {![catch {
1095 set rwid [exec git rev-list --first-parent --max-count=1 \
1096 $id -- $viewfiles($view)]
1097 }]} {
1098 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1099 # use $rwid in place of $id
1100 rewrite_commit $view $id $rwid
1101 continue
1106 set a 0
1107 if {[info exists varcid($vid)]} {
1108 if {$cmitlisted($vid) || !$listed} continue
1109 set a $varcid($vid)
1111 if {$listed} {
1112 set olds [lrange $ids 1 end]
1113 } else {
1114 set olds {}
1116 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1117 set cmitlisted($vid) $listed
1118 set parents($vid) $olds
1119 if {![info exists children($vid)]} {
1120 set children($vid) {}
1121 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1122 set k [lindex $children($vid) 0]
1123 if {[llength $parents($view,$k)] == 1 &&
1124 (!$datemode ||
1125 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1126 set a $varcid($view,$k)
1129 if {$a == 0} {
1130 # new arc
1131 set a [newvarc $view $id]
1133 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1134 modify_arc $view $a
1136 if {![info exists varcid($vid)]} {
1137 set varcid($vid) $a
1138 lappend varccommits($view,$a) $id
1139 incr commitidx($view)
1142 set i 0
1143 foreach p $olds {
1144 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1145 set vp $view,$p
1146 if {[llength [lappend children($vp) $id]] > 1 &&
1147 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1148 set children($vp) [lsort -command [list vtokcmp $view] \
1149 $children($vp)]
1150 catch {unset ordertok}
1152 if {[info exists varcid($view,$p)]} {
1153 fix_reversal $p $a $view
1156 incr i
1159 if {[info exists commitinterest($id)]} {
1160 foreach script $commitinterest($id) {
1161 lappend scripts [string map [list "%I" $id] $script]
1163 unset commitinterest($id)
1165 set gotsome 1
1167 if {$gotsome} {
1168 global numcommits hlview
1170 if {$view == $curview} {
1171 set numcommits $commitidx($view)
1172 run chewcommits
1174 if {[info exists hlview] && $view == $hlview} {
1175 # we never actually get here...
1176 run vhighlightmore
1178 foreach s $scripts {
1179 eval $s
1181 if {$view == $curview} {
1182 # update progress bar
1183 global progressdirn progresscoords proglastnc
1184 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1185 set proglastnc $commitidx($view)
1186 set l [lindex $progresscoords 0]
1187 set r [lindex $progresscoords 1]
1188 if {$progressdirn} {
1189 set r [expr {$r + $inc}]
1190 if {$r >= 1.0} {
1191 set r 1.0
1192 set progressdirn 0
1194 if {$r > 0.2} {
1195 set l [expr {$r - 0.2}]
1197 } else {
1198 set l [expr {$l - $inc}]
1199 if {$l <= 0.0} {
1200 set l 0.0
1201 set progressdirn 1
1203 set r [expr {$l + 0.2}]
1205 set progresscoords [list $l $r]
1206 adjustprogress
1209 return 2
1212 proc chewcommits {} {
1213 global curview hlview viewcomplete
1214 global pending_select
1216 layoutmore
1217 if {$viewcomplete($curview)} {
1218 global commitidx varctok
1219 global numcommits startmsecs
1220 global mainheadid commitinfo nullid
1222 if {[info exists pending_select]} {
1223 set row [first_real_row]
1224 selectline $row 1
1226 if {$commitidx($curview) > 0} {
1227 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1228 #puts "overall $ms ms for $numcommits commits"
1229 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1230 } else {
1231 show_status [mc "No commits selected"]
1233 notbusy layout
1235 return 0
1238 proc readcommit {id} {
1239 if {[catch {set contents [exec git cat-file commit $id]}]} return
1240 parsecommit $id $contents 0
1243 proc parsecommit {id contents listed} {
1244 global commitinfo cdate
1246 set inhdr 1
1247 set comment {}
1248 set headline {}
1249 set auname {}
1250 set audate {}
1251 set comname {}
1252 set comdate {}
1253 set hdrend [string first "\n\n" $contents]
1254 if {$hdrend < 0} {
1255 # should never happen...
1256 set hdrend [string length $contents]
1258 set header [string range $contents 0 [expr {$hdrend - 1}]]
1259 set comment [string range $contents [expr {$hdrend + 2}] end]
1260 foreach line [split $header "\n"] {
1261 set tag [lindex $line 0]
1262 if {$tag == "author"} {
1263 set audate [lindex $line end-1]
1264 set auname [lrange $line 1 end-2]
1265 } elseif {$tag == "committer"} {
1266 set comdate [lindex $line end-1]
1267 set comname [lrange $line 1 end-2]
1270 set headline {}
1271 # take the first non-blank line of the comment as the headline
1272 set headline [string trimleft $comment]
1273 set i [string first "\n" $headline]
1274 if {$i >= 0} {
1275 set headline [string range $headline 0 $i]
1277 set headline [string trimright $headline]
1278 set i [string first "\r" $headline]
1279 if {$i >= 0} {
1280 set headline [string trimright [string range $headline 0 $i]]
1282 if {!$listed} {
1283 # git rev-list indents the comment by 4 spaces;
1284 # if we got this via git cat-file, add the indentation
1285 set newcomment {}
1286 foreach line [split $comment "\n"] {
1287 append newcomment " "
1288 append newcomment $line
1289 append newcomment "\n"
1291 set comment $newcomment
1293 if {$comdate != {}} {
1294 set cdate($id) $comdate
1296 set commitinfo($id) [list $headline $auname $audate \
1297 $comname $comdate $comment]
1300 proc getcommit {id} {
1301 global commitdata commitinfo
1303 if {[info exists commitdata($id)]} {
1304 parsecommit $id $commitdata($id) 1
1305 } else {
1306 readcommit $id
1307 if {![info exists commitinfo($id)]} {
1308 set commitinfo($id) [list [mc "No commit information available"]]
1311 return 1
1314 proc readrefs {} {
1315 global tagids idtags headids idheads tagobjid
1316 global otherrefids idotherrefs mainhead mainheadid
1318 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1319 catch {unset $v}
1321 set refd [open [list | git show-ref -d] r]
1322 while {[gets $refd line] >= 0} {
1323 if {[string index $line 40] ne " "} continue
1324 set id [string range $line 0 39]
1325 set ref [string range $line 41 end]
1326 if {![string match "refs/*" $ref]} continue
1327 set name [string range $ref 5 end]
1328 if {[string match "remotes/*" $name]} {
1329 if {![string match "*/HEAD" $name]} {
1330 set headids($name) $id
1331 lappend idheads($id) $name
1333 } elseif {[string match "heads/*" $name]} {
1334 set name [string range $name 6 end]
1335 set headids($name) $id
1336 lappend idheads($id) $name
1337 } elseif {[string match "tags/*" $name]} {
1338 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1339 # which is what we want since the former is the commit ID
1340 set name [string range $name 5 end]
1341 if {[string match "*^{}" $name]} {
1342 set name [string range $name 0 end-3]
1343 } else {
1344 set tagobjid($name) $id
1346 set tagids($name) $id
1347 lappend idtags($id) $name
1348 } else {
1349 set otherrefids($name) $id
1350 lappend idotherrefs($id) $name
1353 catch {close $refd}
1354 set mainhead {}
1355 set mainheadid {}
1356 catch {
1357 set thehead [exec git symbolic-ref HEAD]
1358 if {[string match "refs/heads/*" $thehead]} {
1359 set mainhead [string range $thehead 11 end]
1360 if {[info exists headids($mainhead)]} {
1361 set mainheadid $headids($mainhead)
1367 # skip over fake commits
1368 proc first_real_row {} {
1369 global nullid nullid2 numcommits
1371 for {set row 0} {$row < $numcommits} {incr row} {
1372 set id [commitonrow $row]
1373 if {$id ne $nullid && $id ne $nullid2} {
1374 break
1377 return $row
1380 # update things for a head moved to a child of its previous location
1381 proc movehead {id name} {
1382 global headids idheads
1384 removehead $headids($name) $name
1385 set headids($name) $id
1386 lappend idheads($id) $name
1389 # update things when a head has been removed
1390 proc removehead {id name} {
1391 global headids idheads
1393 if {$idheads($id) eq $name} {
1394 unset idheads($id)
1395 } else {
1396 set i [lsearch -exact $idheads($id) $name]
1397 if {$i >= 0} {
1398 set idheads($id) [lreplace $idheads($id) $i $i]
1401 unset headids($name)
1404 proc show_error {w top msg} {
1405 message $w.m -text $msg -justify center -aspect 400
1406 pack $w.m -side top -fill x -padx 20 -pady 20
1407 button $w.ok -text [mc OK] -command "destroy $top"
1408 pack $w.ok -side bottom -fill x
1409 bind $top <Visibility> "grab $top; focus $top"
1410 bind $top <Key-Return> "destroy $top"
1411 tkwait window $top
1414 proc error_popup msg {
1415 set w .error
1416 toplevel $w
1417 wm transient $w .
1418 show_error $w $w $msg
1421 proc confirm_popup msg {
1422 global confirm_ok
1423 set confirm_ok 0
1424 set w .confirm
1425 toplevel $w
1426 wm transient $w .
1427 message $w.m -text $msg -justify center -aspect 400
1428 pack $w.m -side top -fill x -padx 20 -pady 20
1429 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1430 pack $w.ok -side left -fill x
1431 button $w.cancel -text [mc Cancel] -command "destroy $w"
1432 pack $w.cancel -side right -fill x
1433 bind $w <Visibility> "grab $w; focus $w"
1434 tkwait window $w
1435 return $confirm_ok
1438 proc setoptions {} {
1439 option add *Panedwindow.showHandle 1 startupFile
1440 option add *Panedwindow.sashRelief raised startupFile
1441 option add *Button.font uifont startupFile
1442 option add *Checkbutton.font uifont startupFile
1443 option add *Radiobutton.font uifont startupFile
1444 option add *Menu.font uifont startupFile
1445 option add *Menubutton.font uifont startupFile
1446 option add *Label.font uifont startupFile
1447 option add *Message.font uifont startupFile
1448 option add *Entry.font uifont startupFile
1451 proc makewindow {} {
1452 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1453 global tabstop
1454 global findtype findtypemenu findloc findstring fstring geometry
1455 global entries sha1entry sha1string sha1but
1456 global diffcontextstring diffcontext
1457 global ignorespace
1458 global maincursor textcursor curtextcursor
1459 global rowctxmenu fakerowmenu mergemax wrapcomment
1460 global highlight_files gdttype
1461 global searchstring sstring
1462 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1463 global headctxmenu progresscanv progressitem progresscoords statusw
1464 global fprogitem fprogcoord lastprogupdate progupdatepending
1465 global rprogitem rprogcoord
1466 global have_tk85
1468 menu .bar
1469 .bar add cascade -label [mc "File"] -menu .bar.file
1470 menu .bar.file
1471 .bar.file add command -label [mc "Update"] -command updatecommits
1472 .bar.file add command -label [mc "Reload"] -command reloadcommits
1473 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1474 .bar.file add command -label [mc "List references"] -command showrefs
1475 .bar.file add command -label [mc "Quit"] -command doquit
1476 menu .bar.edit
1477 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1478 .bar.edit add command -label [mc "Preferences"] -command doprefs
1480 menu .bar.view
1481 .bar add cascade -label [mc "View"] -menu .bar.view
1482 .bar.view add command -label [mc "New view..."] -command {newview 0}
1483 .bar.view add command -label [mc "Edit view..."] -command editview \
1484 -state disabled
1485 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1486 .bar.view add separator
1487 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1488 -variable selectedview -value 0
1490 menu .bar.help
1491 .bar add cascade -label [mc "Help"] -menu .bar.help
1492 .bar.help add command -label [mc "About gitk"] -command about
1493 .bar.help add command -label [mc "Key bindings"] -command keys
1494 .bar.help configure
1495 . configure -menu .bar
1497 # the gui has upper and lower half, parts of a paned window.
1498 panedwindow .ctop -orient vertical
1500 # possibly use assumed geometry
1501 if {![info exists geometry(pwsash0)]} {
1502 set geometry(topheight) [expr {15 * $linespc}]
1503 set geometry(topwidth) [expr {80 * $charspc}]
1504 set geometry(botheight) [expr {15 * $linespc}]
1505 set geometry(botwidth) [expr {50 * $charspc}]
1506 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1507 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1510 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1511 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1512 frame .tf.histframe
1513 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1515 # create three canvases
1516 set cscroll .tf.histframe.csb
1517 set canv .tf.histframe.pwclist.canv
1518 canvas $canv \
1519 -selectbackground $selectbgcolor \
1520 -background $bgcolor -bd 0 \
1521 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1522 .tf.histframe.pwclist add $canv
1523 set canv2 .tf.histframe.pwclist.canv2
1524 canvas $canv2 \
1525 -selectbackground $selectbgcolor \
1526 -background $bgcolor -bd 0 -yscrollincr $linespc
1527 .tf.histframe.pwclist add $canv2
1528 set canv3 .tf.histframe.pwclist.canv3
1529 canvas $canv3 \
1530 -selectbackground $selectbgcolor \
1531 -background $bgcolor -bd 0 -yscrollincr $linespc
1532 .tf.histframe.pwclist add $canv3
1533 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1534 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1536 # a scroll bar to rule them
1537 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1538 pack $cscroll -side right -fill y
1539 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1540 lappend bglist $canv $canv2 $canv3
1541 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1543 # we have two button bars at bottom of top frame. Bar 1
1544 frame .tf.bar
1545 frame .tf.lbar -height 15
1547 set sha1entry .tf.bar.sha1
1548 set entries $sha1entry
1549 set sha1but .tf.bar.sha1label
1550 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1551 -command gotocommit -width 8
1552 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1553 pack .tf.bar.sha1label -side left
1554 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1555 trace add variable sha1string write sha1change
1556 pack $sha1entry -side left -pady 2
1558 image create bitmap bm-left -data {
1559 #define left_width 16
1560 #define left_height 16
1561 static unsigned char left_bits[] = {
1562 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1563 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1564 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1566 image create bitmap bm-right -data {
1567 #define right_width 16
1568 #define right_height 16
1569 static unsigned char right_bits[] = {
1570 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1571 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1572 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1574 button .tf.bar.leftbut -image bm-left -command goback \
1575 -state disabled -width 26
1576 pack .tf.bar.leftbut -side left -fill y
1577 button .tf.bar.rightbut -image bm-right -command goforw \
1578 -state disabled -width 26
1579 pack .tf.bar.rightbut -side left -fill y
1581 # Status label and progress bar
1582 set statusw .tf.bar.status
1583 label $statusw -width 15 -relief sunken
1584 pack $statusw -side left -padx 5
1585 set h [expr {[font metrics uifont -linespace] + 2}]
1586 set progresscanv .tf.bar.progress
1587 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1588 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1589 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1590 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1591 pack $progresscanv -side right -expand 1 -fill x
1592 set progresscoords {0 0}
1593 set fprogcoord 0
1594 set rprogcoord 0
1595 bind $progresscanv <Configure> adjustprogress
1596 set lastprogupdate [clock clicks -milliseconds]
1597 set progupdatepending 0
1599 # build up the bottom bar of upper window
1600 label .tf.lbar.flabel -text "[mc "Find"] "
1601 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1602 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1603 label .tf.lbar.flab2 -text " [mc "commit"] "
1604 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1605 -side left -fill y
1606 set gdttype [mc "containing:"]
1607 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1608 [mc "containing:"] \
1609 [mc "touching paths:"] \
1610 [mc "adding/removing string:"]]
1611 trace add variable gdttype write gdttype_change
1612 pack .tf.lbar.gdttype -side left -fill y
1614 set findstring {}
1615 set fstring .tf.lbar.findstring
1616 lappend entries $fstring
1617 entry $fstring -width 30 -font textfont -textvariable findstring
1618 trace add variable findstring write find_change
1619 set findtype [mc "Exact"]
1620 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1621 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1622 trace add variable findtype write findcom_change
1623 set findloc [mc "All fields"]
1624 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1625 [mc "Comments"] [mc "Author"] [mc "Committer"]
1626 trace add variable findloc write find_change
1627 pack .tf.lbar.findloc -side right
1628 pack .tf.lbar.findtype -side right
1629 pack $fstring -side left -expand 1 -fill x
1631 # Finish putting the upper half of the viewer together
1632 pack .tf.lbar -in .tf -side bottom -fill x
1633 pack .tf.bar -in .tf -side bottom -fill x
1634 pack .tf.histframe -fill both -side top -expand 1
1635 .ctop add .tf
1636 .ctop paneconfigure .tf -height $geometry(topheight)
1637 .ctop paneconfigure .tf -width $geometry(topwidth)
1639 # now build up the bottom
1640 panedwindow .pwbottom -orient horizontal
1642 # lower left, a text box over search bar, scroll bar to the right
1643 # if we know window height, then that will set the lower text height, otherwise
1644 # we set lower text height which will drive window height
1645 if {[info exists geometry(main)]} {
1646 frame .bleft -width $geometry(botwidth)
1647 } else {
1648 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1650 frame .bleft.top
1651 frame .bleft.mid
1653 button .bleft.top.search -text [mc "Search"] -command dosearch
1654 pack .bleft.top.search -side left -padx 5
1655 set sstring .bleft.top.sstring
1656 entry $sstring -width 20 -font textfont -textvariable searchstring
1657 lappend entries $sstring
1658 trace add variable searchstring write incrsearch
1659 pack $sstring -side left -expand 1 -fill x
1660 radiobutton .bleft.mid.diff -text [mc "Diff"] \
1661 -command changediffdisp -variable diffelide -value {0 0}
1662 radiobutton .bleft.mid.old -text [mc "Old version"] \
1663 -command changediffdisp -variable diffelide -value {0 1}
1664 radiobutton .bleft.mid.new -text [mc "New version"] \
1665 -command changediffdisp -variable diffelide -value {1 0}
1666 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
1667 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1668 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1669 -from 1 -increment 1 -to 10000000 \
1670 -validate all -validatecommand "diffcontextvalidate %P" \
1671 -textvariable diffcontextstring
1672 .bleft.mid.diffcontext set $diffcontext
1673 trace add variable diffcontextstring write diffcontextchange
1674 lappend entries .bleft.mid.diffcontext
1675 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1676 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1677 -command changeignorespace -variable ignorespace
1678 pack .bleft.mid.ignspace -side left -padx 5
1679 set ctext .bleft.ctext
1680 text $ctext -background $bgcolor -foreground $fgcolor \
1681 -state disabled -font textfont \
1682 -yscrollcommand scrolltext -wrap none
1683 if {$have_tk85} {
1684 $ctext conf -tabstyle wordprocessor
1686 scrollbar .bleft.sb -command "$ctext yview"
1687 pack .bleft.top -side top -fill x
1688 pack .bleft.mid -side top -fill x
1689 pack .bleft.sb -side right -fill y
1690 pack $ctext -side left -fill both -expand 1
1691 lappend bglist $ctext
1692 lappend fglist $ctext
1694 $ctext tag conf comment -wrap $wrapcomment
1695 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1696 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1697 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1698 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1699 $ctext tag conf m0 -fore red
1700 $ctext tag conf m1 -fore blue
1701 $ctext tag conf m2 -fore green
1702 $ctext tag conf m3 -fore purple
1703 $ctext tag conf m4 -fore brown
1704 $ctext tag conf m5 -fore "#009090"
1705 $ctext tag conf m6 -fore magenta
1706 $ctext tag conf m7 -fore "#808000"
1707 $ctext tag conf m8 -fore "#009000"
1708 $ctext tag conf m9 -fore "#ff0080"
1709 $ctext tag conf m10 -fore cyan
1710 $ctext tag conf m11 -fore "#b07070"
1711 $ctext tag conf m12 -fore "#70b0f0"
1712 $ctext tag conf m13 -fore "#70f0b0"
1713 $ctext tag conf m14 -fore "#f0b070"
1714 $ctext tag conf m15 -fore "#ff70b0"
1715 $ctext tag conf mmax -fore darkgrey
1716 set mergemax 16
1717 $ctext tag conf mresult -font textfontbold
1718 $ctext tag conf msep -font textfontbold
1719 $ctext tag conf found -back yellow
1721 .pwbottom add .bleft
1722 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1724 # lower right
1725 frame .bright
1726 frame .bright.mode
1727 radiobutton .bright.mode.patch -text [mc "Patch"] \
1728 -command reselectline -variable cmitmode -value "patch"
1729 radiobutton .bright.mode.tree -text [mc "Tree"] \
1730 -command reselectline -variable cmitmode -value "tree"
1731 grid .bright.mode.patch .bright.mode.tree -sticky ew
1732 pack .bright.mode -side top -fill x
1733 set cflist .bright.cfiles
1734 set indent [font measure mainfont "nn"]
1735 text $cflist \
1736 -selectbackground $selectbgcolor \
1737 -background $bgcolor -foreground $fgcolor \
1738 -font mainfont \
1739 -tabs [list $indent [expr {2 * $indent}]] \
1740 -yscrollcommand ".bright.sb set" \
1741 -cursor [. cget -cursor] \
1742 -spacing1 1 -spacing3 1
1743 lappend bglist $cflist
1744 lappend fglist $cflist
1745 scrollbar .bright.sb -command "$cflist yview"
1746 pack .bright.sb -side right -fill y
1747 pack $cflist -side left -fill both -expand 1
1748 $cflist tag configure highlight \
1749 -background [$cflist cget -selectbackground]
1750 $cflist tag configure bold -font mainfontbold
1752 .pwbottom add .bright
1753 .ctop add .pwbottom
1755 # restore window position if known
1756 if {[info exists geometry(main)]} {
1757 wm geometry . "$geometry(main)"
1760 if {[tk windowingsystem] eq {aqua}} {
1761 set M1B M1
1762 } else {
1763 set M1B Control
1766 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1767 pack .ctop -fill both -expand 1
1768 bindall <1> {selcanvline %W %x %y}
1769 #bindall <B1-Motion> {selcanvline %W %x %y}
1770 if {[tk windowingsystem] == "win32"} {
1771 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1772 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1773 } else {
1774 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1775 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1776 if {[tk windowingsystem] eq "aqua"} {
1777 bindall <MouseWheel> {
1778 set delta [expr {- (%D)}]
1779 allcanvs yview scroll $delta units
1783 bindall <2> "canvscan mark %W %x %y"
1784 bindall <B2-Motion> "canvscan dragto %W %x %y"
1785 bindkey <Home> selfirstline
1786 bindkey <End> sellastline
1787 bind . <Key-Up> "selnextline -1"
1788 bind . <Key-Down> "selnextline 1"
1789 bind . <Shift-Key-Up> "dofind -1 0"
1790 bind . <Shift-Key-Down> "dofind 1 0"
1791 bindkey <Key-Right> "goforw"
1792 bindkey <Key-Left> "goback"
1793 bind . <Key-Prior> "selnextpage -1"
1794 bind . <Key-Next> "selnextpage 1"
1795 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1796 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1797 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1798 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1799 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1800 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1801 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1802 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1803 bindkey <Key-space> "$ctext yview scroll 1 pages"
1804 bindkey p "selnextline -1"
1805 bindkey n "selnextline 1"
1806 bindkey z "goback"
1807 bindkey x "goforw"
1808 bindkey i "selnextline -1"
1809 bindkey k "selnextline 1"
1810 bindkey j "goback"
1811 bindkey l "goforw"
1812 bindkey b "$ctext yview scroll -1 pages"
1813 bindkey d "$ctext yview scroll 18 units"
1814 bindkey u "$ctext yview scroll -18 units"
1815 bindkey / {dofind 1 1}
1816 bindkey <Key-Return> {dofind 1 1}
1817 bindkey ? {dofind -1 1}
1818 bindkey f nextfile
1819 bindkey <F5> updatecommits
1820 bind . <$M1B-q> doquit
1821 bind . <$M1B-f> {dofind 1 1}
1822 bind . <$M1B-g> {dofind 1 0}
1823 bind . <$M1B-r> dosearchback
1824 bind . <$M1B-s> dosearch
1825 bind . <$M1B-equal> {incrfont 1}
1826 bind . <$M1B-plus> {incrfont 1}
1827 bind . <$M1B-KP_Add> {incrfont 1}
1828 bind . <$M1B-minus> {incrfont -1}
1829 bind . <$M1B-KP_Subtract> {incrfont -1}
1830 wm protocol . WM_DELETE_WINDOW doquit
1831 bind . <Button-1> "click %W"
1832 bind $fstring <Key-Return> {dofind 1 1}
1833 bind $sha1entry <Key-Return> gotocommit
1834 bind $sha1entry <<PasteSelection>> clearsha1
1835 bind $cflist <1> {sel_flist %W %x %y; break}
1836 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1837 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1838 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1840 set maincursor [. cget -cursor]
1841 set textcursor [$ctext cget -cursor]
1842 set curtextcursor $textcursor
1844 set rowctxmenu .rowctxmenu
1845 menu $rowctxmenu -tearoff 0
1846 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1847 -command {diffvssel 0}
1848 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1849 -command {diffvssel 1}
1850 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1851 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1852 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1853 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1854 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1855 -command cherrypick
1856 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1857 -command resethead
1859 set fakerowmenu .fakerowmenu
1860 menu $fakerowmenu -tearoff 0
1861 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1862 -command {diffvssel 0}
1863 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1864 -command {diffvssel 1}
1865 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1866 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1867 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1868 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1870 set headctxmenu .headctxmenu
1871 menu $headctxmenu -tearoff 0
1872 $headctxmenu add command -label [mc "Check out this branch"] \
1873 -command cobranch
1874 $headctxmenu add command -label [mc "Remove this branch"] \
1875 -command rmbranch
1877 global flist_menu
1878 set flist_menu .flistctxmenu
1879 menu $flist_menu -tearoff 0
1880 $flist_menu add command -label [mc "Highlight this too"] \
1881 -command {flist_hl 0}
1882 $flist_menu add command -label [mc "Highlight this only"] \
1883 -command {flist_hl 1}
1886 # Windows sends all mouse wheel events to the current focused window, not
1887 # the one where the mouse hovers, so bind those events here and redirect
1888 # to the correct window
1889 proc windows_mousewheel_redirector {W X Y D} {
1890 global canv canv2 canv3
1891 set w [winfo containing -displayof $W $X $Y]
1892 if {$w ne ""} {
1893 set u [expr {$D < 0 ? 5 : -5}]
1894 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1895 allcanvs yview scroll $u units
1896 } else {
1897 catch {
1898 $w yview scroll $u units
1904 # mouse-2 makes all windows scan vertically, but only the one
1905 # the cursor is in scans horizontally
1906 proc canvscan {op w x y} {
1907 global canv canv2 canv3
1908 foreach c [list $canv $canv2 $canv3] {
1909 if {$c == $w} {
1910 $c scan $op $x $y
1911 } else {
1912 $c scan $op 0 $y
1917 proc scrollcanv {cscroll f0 f1} {
1918 $cscroll set $f0 $f1
1919 drawvisible
1920 flushhighlights
1923 # when we make a key binding for the toplevel, make sure
1924 # it doesn't get triggered when that key is pressed in the
1925 # find string entry widget.
1926 proc bindkey {ev script} {
1927 global entries
1928 bind . $ev $script
1929 set escript [bind Entry $ev]
1930 if {$escript == {}} {
1931 set escript [bind Entry <Key>]
1933 foreach e $entries {
1934 bind $e $ev "$escript; break"
1938 # set the focus back to the toplevel for any click outside
1939 # the entry widgets
1940 proc click {w} {
1941 global ctext entries
1942 foreach e [concat $entries $ctext] {
1943 if {$w == $e} return
1945 focus .
1948 # Adjust the progress bar for a change in requested extent or canvas size
1949 proc adjustprogress {} {
1950 global progresscanv progressitem progresscoords
1951 global fprogitem fprogcoord lastprogupdate progupdatepending
1952 global rprogitem rprogcoord
1954 set w [expr {[winfo width $progresscanv] - 4}]
1955 set x0 [expr {$w * [lindex $progresscoords 0]}]
1956 set x1 [expr {$w * [lindex $progresscoords 1]}]
1957 set h [winfo height $progresscanv]
1958 $progresscanv coords $progressitem $x0 0 $x1 $h
1959 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1960 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1961 set now [clock clicks -milliseconds]
1962 if {$now >= $lastprogupdate + 100} {
1963 set progupdatepending 0
1964 update
1965 } elseif {!$progupdatepending} {
1966 set progupdatepending 1
1967 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1971 proc doprogupdate {} {
1972 global lastprogupdate progupdatepending
1974 if {$progupdatepending} {
1975 set progupdatepending 0
1976 set lastprogupdate [clock clicks -milliseconds]
1977 update
1981 proc savestuff {w} {
1982 global canv canv2 canv3 mainfont textfont uifont tabstop
1983 global stuffsaved findmergefiles maxgraphpct
1984 global maxwidth showneartags showlocalchanges
1985 global viewname viewfiles viewargs viewperm nextviewnum
1986 global cmitmode wrapcomment datetimeformat limitdiffs
1987 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1989 if {$stuffsaved} return
1990 if {![winfo viewable .]} return
1991 catch {
1992 set f [open "~/.gitk-new" w]
1993 puts $f [list set mainfont $mainfont]
1994 puts $f [list set textfont $textfont]
1995 puts $f [list set uifont $uifont]
1996 puts $f [list set tabstop $tabstop]
1997 puts $f [list set findmergefiles $findmergefiles]
1998 puts $f [list set maxgraphpct $maxgraphpct]
1999 puts $f [list set maxwidth $maxwidth]
2000 puts $f [list set cmitmode $cmitmode]
2001 puts $f [list set wrapcomment $wrapcomment]
2002 puts $f [list set showneartags $showneartags]
2003 puts $f [list set showlocalchanges $showlocalchanges]
2004 puts $f [list set datetimeformat $datetimeformat]
2005 puts $f [list set limitdiffs $limitdiffs]
2006 puts $f [list set bgcolor $bgcolor]
2007 puts $f [list set fgcolor $fgcolor]
2008 puts $f [list set colors $colors]
2009 puts $f [list set diffcolors $diffcolors]
2010 puts $f [list set diffcontext $diffcontext]
2011 puts $f [list set selectbgcolor $selectbgcolor]
2013 puts $f "set geometry(main) [wm geometry .]"
2014 puts $f "set geometry(topwidth) [winfo width .tf]"
2015 puts $f "set geometry(topheight) [winfo height .tf]"
2016 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2017 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2018 puts $f "set geometry(botwidth) [winfo width .bleft]"
2019 puts $f "set geometry(botheight) [winfo height .bleft]"
2021 puts -nonewline $f "set permviews {"
2022 for {set v 0} {$v < $nextviewnum} {incr v} {
2023 if {$viewperm($v)} {
2024 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
2027 puts $f "}"
2028 close $f
2029 file rename -force "~/.gitk-new" "~/.gitk"
2031 set stuffsaved 1
2034 proc resizeclistpanes {win w} {
2035 global oldwidth
2036 if {[info exists oldwidth($win)]} {
2037 set s0 [$win sash coord 0]
2038 set s1 [$win sash coord 1]
2039 if {$w < 60} {
2040 set sash0 [expr {int($w/2 - 2)}]
2041 set sash1 [expr {int($w*5/6 - 2)}]
2042 } else {
2043 set factor [expr {1.0 * $w / $oldwidth($win)}]
2044 set sash0 [expr {int($factor * [lindex $s0 0])}]
2045 set sash1 [expr {int($factor * [lindex $s1 0])}]
2046 if {$sash0 < 30} {
2047 set sash0 30
2049 if {$sash1 < $sash0 + 20} {
2050 set sash1 [expr {$sash0 + 20}]
2052 if {$sash1 > $w - 10} {
2053 set sash1 [expr {$w - 10}]
2054 if {$sash0 > $sash1 - 20} {
2055 set sash0 [expr {$sash1 - 20}]
2059 $win sash place 0 $sash0 [lindex $s0 1]
2060 $win sash place 1 $sash1 [lindex $s1 1]
2062 set oldwidth($win) $w
2065 proc resizecdetpanes {win w} {
2066 global oldwidth
2067 if {[info exists oldwidth($win)]} {
2068 set s0 [$win sash coord 0]
2069 if {$w < 60} {
2070 set sash0 [expr {int($w*3/4 - 2)}]
2071 } else {
2072 set factor [expr {1.0 * $w / $oldwidth($win)}]
2073 set sash0 [expr {int($factor * [lindex $s0 0])}]
2074 if {$sash0 < 45} {
2075 set sash0 45
2077 if {$sash0 > $w - 15} {
2078 set sash0 [expr {$w - 15}]
2081 $win sash place 0 $sash0 [lindex $s0 1]
2083 set oldwidth($win) $w
2086 proc allcanvs args {
2087 global canv canv2 canv3
2088 eval $canv $args
2089 eval $canv2 $args
2090 eval $canv3 $args
2093 proc bindall {event action} {
2094 global canv canv2 canv3
2095 bind $canv $event $action
2096 bind $canv2 $event $action
2097 bind $canv3 $event $action
2100 proc about {} {
2101 global uifont
2102 set w .about
2103 if {[winfo exists $w]} {
2104 raise $w
2105 return
2107 toplevel $w
2108 wm title $w [mc "About gitk"]
2109 message $w.m -text [mc "
2110 Gitk - a commit viewer for git
2112 Copyright © 2005-2006 Paul Mackerras
2114 Use and redistribute under the terms of the GNU General Public License"] \
2115 -justify center -aspect 400 -border 2 -bg white -relief groove
2116 pack $w.m -side top -fill x -padx 2 -pady 2
2117 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2118 pack $w.ok -side bottom
2119 bind $w <Visibility> "focus $w.ok"
2120 bind $w <Key-Escape> "destroy $w"
2121 bind $w <Key-Return> "destroy $w"
2124 proc keys {} {
2125 set w .keys
2126 if {[winfo exists $w]} {
2127 raise $w
2128 return
2130 if {[tk windowingsystem] eq {aqua}} {
2131 set M1T Cmd
2132 } else {
2133 set M1T Ctrl
2135 toplevel $w
2136 wm title $w [mc "Gitk key bindings"]
2137 message $w.m -text "
2138 [mc "Gitk key bindings:"]
2140 [mc "<%s-Q> Quit" $M1T]
2141 [mc "<Home> Move to first commit"]
2142 [mc "<End> Move to last commit"]
2143 [mc "<Up>, p, i Move up one commit"]
2144 [mc "<Down>, n, k Move down one commit"]
2145 [mc "<Left>, z, j Go back in history list"]
2146 [mc "<Right>, x, l Go forward in history list"]
2147 [mc "<PageUp> Move up one page in commit list"]
2148 [mc "<PageDown> Move down one page in commit list"]
2149 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2150 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2151 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2152 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2153 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2154 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2155 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2156 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2157 [mc "<Delete>, b Scroll diff view up one page"]
2158 [mc "<Backspace> Scroll diff view up one page"]
2159 [mc "<Space> Scroll diff view down one page"]
2160 [mc "u Scroll diff view up 18 lines"]
2161 [mc "d Scroll diff view down 18 lines"]
2162 [mc "<%s-F> Find" $M1T]
2163 [mc "<%s-G> Move to next find hit" $M1T]
2164 [mc "<Return> Move to next find hit"]
2165 [mc "/ Move to next find hit, or redo find"]
2166 [mc "? Move to previous find hit"]
2167 [mc "f Scroll diff view to next file"]
2168 [mc "<%s-S> Search for next hit in diff view" $M1T]
2169 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2170 [mc "<%s-KP+> Increase font size" $M1T]
2171 [mc "<%s-plus> Increase font size" $M1T]
2172 [mc "<%s-KP-> Decrease font size" $M1T]
2173 [mc "<%s-minus> Decrease font size" $M1T]
2174 [mc "<F5> Update"]
2176 -justify left -bg white -border 2 -relief groove
2177 pack $w.m -side top -fill both -padx 2 -pady 2
2178 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2179 pack $w.ok -side bottom
2180 bind $w <Visibility> "focus $w.ok"
2181 bind $w <Key-Escape> "destroy $w"
2182 bind $w <Key-Return> "destroy $w"
2185 # Procedures for manipulating the file list window at the
2186 # bottom right of the overall window.
2188 proc treeview {w l openlevs} {
2189 global treecontents treediropen treeheight treeparent treeindex
2191 set ix 0
2192 set treeindex() 0
2193 set lev 0
2194 set prefix {}
2195 set prefixend -1
2196 set prefendstack {}
2197 set htstack {}
2198 set ht 0
2199 set treecontents() {}
2200 $w conf -state normal
2201 foreach f $l {
2202 while {[string range $f 0 $prefixend] ne $prefix} {
2203 if {$lev <= $openlevs} {
2204 $w mark set e:$treeindex($prefix) "end -1c"
2205 $w mark gravity e:$treeindex($prefix) left
2207 set treeheight($prefix) $ht
2208 incr ht [lindex $htstack end]
2209 set htstack [lreplace $htstack end end]
2210 set prefixend [lindex $prefendstack end]
2211 set prefendstack [lreplace $prefendstack end end]
2212 set prefix [string range $prefix 0 $prefixend]
2213 incr lev -1
2215 set tail [string range $f [expr {$prefixend+1}] end]
2216 while {[set slash [string first "/" $tail]] >= 0} {
2217 lappend htstack $ht
2218 set ht 0
2219 lappend prefendstack $prefixend
2220 incr prefixend [expr {$slash + 1}]
2221 set d [string range $tail 0 $slash]
2222 lappend treecontents($prefix) $d
2223 set oldprefix $prefix
2224 append prefix $d
2225 set treecontents($prefix) {}
2226 set treeindex($prefix) [incr ix]
2227 set treeparent($prefix) $oldprefix
2228 set tail [string range $tail [expr {$slash+1}] end]
2229 if {$lev <= $openlevs} {
2230 set ht 1
2231 set treediropen($prefix) [expr {$lev < $openlevs}]
2232 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2233 $w mark set d:$ix "end -1c"
2234 $w mark gravity d:$ix left
2235 set str "\n"
2236 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2237 $w insert end $str
2238 $w image create end -align center -image $bm -padx 1 \
2239 -name a:$ix
2240 $w insert end $d [highlight_tag $prefix]
2241 $w mark set s:$ix "end -1c"
2242 $w mark gravity s:$ix left
2244 incr lev
2246 if {$tail ne {}} {
2247 if {$lev <= $openlevs} {
2248 incr ht
2249 set str "\n"
2250 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2251 $w insert end $str
2252 $w insert end $tail [highlight_tag $f]
2254 lappend treecontents($prefix) $tail
2257 while {$htstack ne {}} {
2258 set treeheight($prefix) $ht
2259 incr ht [lindex $htstack end]
2260 set htstack [lreplace $htstack end end]
2261 set prefixend [lindex $prefendstack end]
2262 set prefendstack [lreplace $prefendstack end end]
2263 set prefix [string range $prefix 0 $prefixend]
2265 $w conf -state disabled
2268 proc linetoelt {l} {
2269 global treeheight treecontents
2271 set y 2
2272 set prefix {}
2273 while {1} {
2274 foreach e $treecontents($prefix) {
2275 if {$y == $l} {
2276 return "$prefix$e"
2278 set n 1
2279 if {[string index $e end] eq "/"} {
2280 set n $treeheight($prefix$e)
2281 if {$y + $n > $l} {
2282 append prefix $e
2283 incr y
2284 break
2287 incr y $n
2292 proc highlight_tree {y prefix} {
2293 global treeheight treecontents cflist
2295 foreach e $treecontents($prefix) {
2296 set path $prefix$e
2297 if {[highlight_tag $path] ne {}} {
2298 $cflist tag add bold $y.0 "$y.0 lineend"
2300 incr y
2301 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2302 set y [highlight_tree $y $path]
2305 return $y
2308 proc treeclosedir {w dir} {
2309 global treediropen treeheight treeparent treeindex
2311 set ix $treeindex($dir)
2312 $w conf -state normal
2313 $w delete s:$ix e:$ix
2314 set treediropen($dir) 0
2315 $w image configure a:$ix -image tri-rt
2316 $w conf -state disabled
2317 set n [expr {1 - $treeheight($dir)}]
2318 while {$dir ne {}} {
2319 incr treeheight($dir) $n
2320 set dir $treeparent($dir)
2324 proc treeopendir {w dir} {
2325 global treediropen treeheight treeparent treecontents treeindex
2327 set ix $treeindex($dir)
2328 $w conf -state normal
2329 $w image configure a:$ix -image tri-dn
2330 $w mark set e:$ix s:$ix
2331 $w mark gravity e:$ix right
2332 set lev 0
2333 set str "\n"
2334 set n [llength $treecontents($dir)]
2335 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2336 incr lev
2337 append str "\t"
2338 incr treeheight($x) $n
2340 foreach e $treecontents($dir) {
2341 set de $dir$e
2342 if {[string index $e end] eq "/"} {
2343 set iy $treeindex($de)
2344 $w mark set d:$iy e:$ix
2345 $w mark gravity d:$iy left
2346 $w insert e:$ix $str
2347 set treediropen($de) 0
2348 $w image create e:$ix -align center -image tri-rt -padx 1 \
2349 -name a:$iy
2350 $w insert e:$ix $e [highlight_tag $de]
2351 $w mark set s:$iy e:$ix
2352 $w mark gravity s:$iy left
2353 set treeheight($de) 1
2354 } else {
2355 $w insert e:$ix $str
2356 $w insert e:$ix $e [highlight_tag $de]
2359 $w mark gravity e:$ix left
2360 $w conf -state disabled
2361 set treediropen($dir) 1
2362 set top [lindex [split [$w index @0,0] .] 0]
2363 set ht [$w cget -height]
2364 set l [lindex [split [$w index s:$ix] .] 0]
2365 if {$l < $top} {
2366 $w yview $l.0
2367 } elseif {$l + $n + 1 > $top + $ht} {
2368 set top [expr {$l + $n + 2 - $ht}]
2369 if {$l < $top} {
2370 set top $l
2372 $w yview $top.0
2376 proc treeclick {w x y} {
2377 global treediropen cmitmode ctext cflist cflist_top
2379 if {$cmitmode ne "tree"} return
2380 if {![info exists cflist_top]} return
2381 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2382 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2383 $cflist tag add highlight $l.0 "$l.0 lineend"
2384 set cflist_top $l
2385 if {$l == 1} {
2386 $ctext yview 1.0
2387 return
2389 set e [linetoelt $l]
2390 if {[string index $e end] ne "/"} {
2391 showfile $e
2392 } elseif {$treediropen($e)} {
2393 treeclosedir $w $e
2394 } else {
2395 treeopendir $w $e
2399 proc setfilelist {id} {
2400 global treefilelist cflist
2402 treeview $cflist $treefilelist($id) 0
2405 image create bitmap tri-rt -background black -foreground blue -data {
2406 #define tri-rt_width 13
2407 #define tri-rt_height 13
2408 static unsigned char tri-rt_bits[] = {
2409 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2410 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2411 0x00, 0x00};
2412 } -maskdata {
2413 #define tri-rt-mask_width 13
2414 #define tri-rt-mask_height 13
2415 static unsigned char tri-rt-mask_bits[] = {
2416 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2417 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2418 0x08, 0x00};
2420 image create bitmap tri-dn -background black -foreground blue -data {
2421 #define tri-dn_width 13
2422 #define tri-dn_height 13
2423 static unsigned char tri-dn_bits[] = {
2424 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2425 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2426 0x00, 0x00};
2427 } -maskdata {
2428 #define tri-dn-mask_width 13
2429 #define tri-dn-mask_height 13
2430 static unsigned char tri-dn-mask_bits[] = {
2431 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2432 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2433 0x00, 0x00};
2436 image create bitmap reficon-T -background black -foreground yellow -data {
2437 #define tagicon_width 13
2438 #define tagicon_height 9
2439 static unsigned char tagicon_bits[] = {
2440 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2441 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2442 } -maskdata {
2443 #define tagicon-mask_width 13
2444 #define tagicon-mask_height 9
2445 static unsigned char tagicon-mask_bits[] = {
2446 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2447 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2449 set rectdata {
2450 #define headicon_width 13
2451 #define headicon_height 9
2452 static unsigned char headicon_bits[] = {
2453 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2454 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2456 set rectmask {
2457 #define headicon-mask_width 13
2458 #define headicon-mask_height 9
2459 static unsigned char headicon-mask_bits[] = {
2460 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2461 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2463 image create bitmap reficon-H -background black -foreground green \
2464 -data $rectdata -maskdata $rectmask
2465 image create bitmap reficon-o -background black -foreground "#ddddff" \
2466 -data $rectdata -maskdata $rectmask
2468 proc init_flist {first} {
2469 global cflist cflist_top difffilestart
2471 $cflist conf -state normal
2472 $cflist delete 0.0 end
2473 if {$first ne {}} {
2474 $cflist insert end $first
2475 set cflist_top 1
2476 $cflist tag add highlight 1.0 "1.0 lineend"
2477 } else {
2478 catch {unset cflist_top}
2480 $cflist conf -state disabled
2481 set difffilestart {}
2484 proc highlight_tag {f} {
2485 global highlight_paths
2487 foreach p $highlight_paths {
2488 if {[string match $p $f]} {
2489 return "bold"
2492 return {}
2495 proc highlight_filelist {} {
2496 global cmitmode cflist
2498 $cflist conf -state normal
2499 if {$cmitmode ne "tree"} {
2500 set end [lindex [split [$cflist index end] .] 0]
2501 for {set l 2} {$l < $end} {incr l} {
2502 set line [$cflist get $l.0 "$l.0 lineend"]
2503 if {[highlight_tag $line] ne {}} {
2504 $cflist tag add bold $l.0 "$l.0 lineend"
2507 } else {
2508 highlight_tree 2 {}
2510 $cflist conf -state disabled
2513 proc unhighlight_filelist {} {
2514 global cflist
2516 $cflist conf -state normal
2517 $cflist tag remove bold 1.0 end
2518 $cflist conf -state disabled
2521 proc add_flist {fl} {
2522 global cflist
2524 $cflist conf -state normal
2525 foreach f $fl {
2526 $cflist insert end "\n"
2527 $cflist insert end $f [highlight_tag $f]
2529 $cflist conf -state disabled
2532 proc sel_flist {w x y} {
2533 global ctext difffilestart cflist cflist_top cmitmode
2535 if {$cmitmode eq "tree"} return
2536 if {![info exists cflist_top]} return
2537 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2538 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2539 $cflist tag add highlight $l.0 "$l.0 lineend"
2540 set cflist_top $l
2541 if {$l == 1} {
2542 $ctext yview 1.0
2543 } else {
2544 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2548 proc pop_flist_menu {w X Y x y} {
2549 global ctext cflist cmitmode flist_menu flist_menu_file
2550 global treediffs diffids
2552 stopfinding
2553 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2554 if {$l <= 1} return
2555 if {$cmitmode eq "tree"} {
2556 set e [linetoelt $l]
2557 if {[string index $e end] eq "/"} return
2558 } else {
2559 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2561 set flist_menu_file $e
2562 tk_popup $flist_menu $X $Y
2565 proc flist_hl {only} {
2566 global flist_menu_file findstring gdttype
2568 set x [shellquote $flist_menu_file]
2569 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2570 set findstring $x
2571 } else {
2572 append findstring " " $x
2574 set gdttype [mc "touching paths:"]
2577 # Functions for adding and removing shell-type quoting
2579 proc shellquote {str} {
2580 if {![string match "*\['\"\\ \t]*" $str]} {
2581 return $str
2583 if {![string match "*\['\"\\]*" $str]} {
2584 return "\"$str\""
2586 if {![string match "*'*" $str]} {
2587 return "'$str'"
2589 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2592 proc shellarglist {l} {
2593 set str {}
2594 foreach a $l {
2595 if {$str ne {}} {
2596 append str " "
2598 append str [shellquote $a]
2600 return $str
2603 proc shelldequote {str} {
2604 set ret {}
2605 set used -1
2606 while {1} {
2607 incr used
2608 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2609 append ret [string range $str $used end]
2610 set used [string length $str]
2611 break
2613 set first [lindex $first 0]
2614 set ch [string index $str $first]
2615 if {$first > $used} {
2616 append ret [string range $str $used [expr {$first - 1}]]
2617 set used $first
2619 if {$ch eq " " || $ch eq "\t"} break
2620 incr used
2621 if {$ch eq "'"} {
2622 set first [string first "'" $str $used]
2623 if {$first < 0} {
2624 error "unmatched single-quote"
2626 append ret [string range $str $used [expr {$first - 1}]]
2627 set used $first
2628 continue
2630 if {$ch eq "\\"} {
2631 if {$used >= [string length $str]} {
2632 error "trailing backslash"
2634 append ret [string index $str $used]
2635 continue
2637 # here ch == "\""
2638 while {1} {
2639 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2640 error "unmatched double-quote"
2642 set first [lindex $first 0]
2643 set ch [string index $str $first]
2644 if {$first > $used} {
2645 append ret [string range $str $used [expr {$first - 1}]]
2646 set used $first
2648 if {$ch eq "\""} break
2649 incr used
2650 append ret [string index $str $used]
2651 incr used
2654 return [list $used $ret]
2657 proc shellsplit {str} {
2658 set l {}
2659 while {1} {
2660 set str [string trimleft $str]
2661 if {$str eq {}} break
2662 set dq [shelldequote $str]
2663 set n [lindex $dq 0]
2664 set word [lindex $dq 1]
2665 set str [string range $str $n end]
2666 lappend l $word
2668 return $l
2671 # Code to implement multiple views
2673 proc newview {ishighlight} {
2674 global nextviewnum newviewname newviewperm newishighlight
2675 global newviewargs revtreeargs
2677 set newishighlight $ishighlight
2678 set top .gitkview
2679 if {[winfo exists $top]} {
2680 raise $top
2681 return
2683 set newviewname($nextviewnum) "View $nextviewnum"
2684 set newviewperm($nextviewnum) 0
2685 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2686 vieweditor $top $nextviewnum [mc "Gitk view definition"]
2689 proc editview {} {
2690 global curview
2691 global viewname viewperm newviewname newviewperm
2692 global viewargs newviewargs
2694 set top .gitkvedit-$curview
2695 if {[winfo exists $top]} {
2696 raise $top
2697 return
2699 set newviewname($curview) $viewname($curview)
2700 set newviewperm($curview) $viewperm($curview)
2701 set newviewargs($curview) [shellarglist $viewargs($curview)]
2702 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2705 proc vieweditor {top n title} {
2706 global newviewname newviewperm viewfiles bgcolor
2708 toplevel $top
2709 wm title $top $title
2710 label $top.nl -text [mc "Name"]
2711 entry $top.name -width 20 -textvariable newviewname($n)
2712 grid $top.nl $top.name -sticky w -pady 5
2713 checkbutton $top.perm -text [mc "Remember this view"] \
2714 -variable newviewperm($n)
2715 grid $top.perm - -pady 5 -sticky w
2716 message $top.al -aspect 1000 \
2717 -text [mc "Commits to include (arguments to git rev-list):"]
2718 grid $top.al - -sticky w -pady 5
2719 entry $top.args -width 50 -textvariable newviewargs($n) \
2720 -background $bgcolor
2721 grid $top.args - -sticky ew -padx 5
2722 message $top.l -aspect 1000 \
2723 -text [mc "Enter files and directories to include, one per line:"]
2724 grid $top.l - -sticky w
2725 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
2726 if {[info exists viewfiles($n)]} {
2727 foreach f $viewfiles($n) {
2728 $top.t insert end $f
2729 $top.t insert end "\n"
2731 $top.t delete {end - 1c} end
2732 $top.t mark set insert 0.0
2734 grid $top.t - -sticky ew -padx 5
2735 frame $top.buts
2736 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
2737 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
2738 grid $top.buts.ok $top.buts.can
2739 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2740 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2741 grid $top.buts - -pady 10 -sticky ew
2742 focus $top.t
2745 proc doviewmenu {m first cmd op argv} {
2746 set nmenu [$m index end]
2747 for {set i $first} {$i <= $nmenu} {incr i} {
2748 if {[$m entrycget $i -command] eq $cmd} {
2749 eval $m $op $i $argv
2750 break
2755 proc allviewmenus {n op args} {
2756 # global viewhlmenu
2758 doviewmenu .bar.view 5 [list showview $n] $op $args
2759 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2762 proc newviewok {top n} {
2763 global nextviewnum newviewperm newviewname newishighlight
2764 global viewname viewfiles viewperm selectedview curview
2765 global viewargs newviewargs viewhlmenu
2767 if {[catch {
2768 set newargs [shellsplit $newviewargs($n)]
2769 } err]} {
2770 error_popup "[mc "Error in commit selection arguments:"] $err"
2771 wm raise $top
2772 focus $top
2773 return
2775 set files {}
2776 foreach f [split [$top.t get 0.0 end] "\n"] {
2777 set ft [string trim $f]
2778 if {$ft ne {}} {
2779 lappend files $ft
2782 if {![info exists viewfiles($n)]} {
2783 # creating a new view
2784 incr nextviewnum
2785 set viewname($n) $newviewname($n)
2786 set viewperm($n) $newviewperm($n)
2787 set viewfiles($n) $files
2788 set viewargs($n) $newargs
2789 addviewmenu $n
2790 if {!$newishighlight} {
2791 run showview $n
2792 } else {
2793 run addvhighlight $n
2795 } else {
2796 # editing an existing view
2797 set viewperm($n) $newviewperm($n)
2798 if {$newviewname($n) ne $viewname($n)} {
2799 set viewname($n) $newviewname($n)
2800 doviewmenu .bar.view 5 [list showview $n] \
2801 entryconf [list -label $viewname($n)]
2802 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2803 # entryconf [list -label $viewname($n) -value $viewname($n)]
2805 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2806 set viewfiles($n) $files
2807 set viewargs($n) $newargs
2808 if {$curview == $n} {
2809 run reloadcommits
2813 catch {destroy $top}
2816 proc delview {} {
2817 global curview viewperm hlview selectedhlview
2819 if {$curview == 0} return
2820 if {[info exists hlview] && $hlview == $curview} {
2821 set selectedhlview [mc "None"]
2822 unset hlview
2824 allviewmenus $curview delete
2825 set viewperm($curview) 0
2826 showview 0
2829 proc addviewmenu {n} {
2830 global viewname viewhlmenu
2832 .bar.view add radiobutton -label $viewname($n) \
2833 -command [list showview $n] -variable selectedview -value $n
2834 #$viewhlmenu add radiobutton -label $viewname($n) \
2835 # -command [list addvhighlight $n] -variable selectedhlview
2838 proc showview {n} {
2839 global curview viewfiles cached_commitrow ordertok
2840 global displayorder parentlist rowidlist rowisopt rowfinal
2841 global colormap rowtextx nextcolor canvxmax
2842 global numcommits viewcomplete
2843 global selectedline currentid canv canvy0
2844 global treediffs
2845 global pending_select mainheadid
2846 global commitidx
2847 global selectedview
2848 global hlview selectedhlview commitinterest
2850 if {$n == $curview} return
2851 set selid {}
2852 set ymax [lindex [$canv cget -scrollregion] 3]
2853 set span [$canv yview]
2854 set ytop [expr {[lindex $span 0] * $ymax}]
2855 set ybot [expr {[lindex $span 1] * $ymax}]
2856 set yscreen [expr {($ybot - $ytop) / 2}]
2857 if {[info exists selectedline]} {
2858 set selid $currentid
2859 set y [yc $selectedline]
2860 if {$ytop < $y && $y < $ybot} {
2861 set yscreen [expr {$y - $ytop}]
2863 } elseif {[info exists pending_select]} {
2864 set selid $pending_select
2865 unset pending_select
2867 unselectline
2868 normalline
2869 catch {unset treediffs}
2870 clear_display
2871 if {[info exists hlview] && $hlview == $n} {
2872 unset hlview
2873 set selectedhlview [mc "None"]
2875 catch {unset commitinterest}
2876 catch {unset cached_commitrow}
2877 catch {unset ordertok}
2879 set curview $n
2880 set selectedview $n
2881 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
2882 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
2884 run refill_reflist
2885 if {![info exists viewcomplete($n)]} {
2886 if {$selid ne {}} {
2887 set pending_select $selid
2889 getcommits
2890 return
2893 set displayorder {}
2894 set parentlist {}
2895 set rowidlist {}
2896 set rowisopt {}
2897 set rowfinal {}
2898 set numcommits $commitidx($n)
2900 catch {unset colormap}
2901 catch {unset rowtextx}
2902 set nextcolor 0
2903 set canvxmax [$canv cget -width]
2904 set curview $n
2905 set row 0
2906 setcanvscroll
2907 set yf 0
2908 set row {}
2909 if {$selid ne {} && [commitinview $selid $n]} {
2910 set row [rowofcommit $selid]
2911 # try to get the selected row in the same position on the screen
2912 set ymax [lindex [$canv cget -scrollregion] 3]
2913 set ytop [expr {[yc $row] - $yscreen}]
2914 if {$ytop < 0} {
2915 set ytop 0
2917 set yf [expr {$ytop * 1.0 / $ymax}]
2919 allcanvs yview moveto $yf
2920 drawvisible
2921 if {$row ne {}} {
2922 selectline $row 0
2923 } elseif {$mainheadid ne {} && [commitinview $mainheadid $curview]} {
2924 selectline [rowofcommit $mainheadid] 1
2925 } elseif {!$viewcomplete($n)} {
2926 if {$selid ne {}} {
2927 set pending_select $selid
2928 } else {
2929 set pending_select $mainheadid
2931 } else {
2932 set row [first_real_row]
2933 if {$row < $numcommits} {
2934 selectline $row 0
2937 if {!$viewcomplete($n)} {
2938 if {$numcommits == 0} {
2939 show_status [mc "Reading commits..."]
2941 } elseif {$numcommits == 0} {
2942 show_status [mc "No commits selected"]
2946 # Stuff relating to the highlighting facility
2948 proc ishighlighted {id} {
2949 global vhighlights fhighlights nhighlights rhighlights
2951 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
2952 return $nhighlights($id)
2954 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
2955 return $vhighlights($id)
2957 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
2958 return $fhighlights($id)
2960 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
2961 return $rhighlights($id)
2963 return 0
2966 proc bolden {row font} {
2967 global canv linehtag selectedline boldrows
2969 lappend boldrows $row
2970 $canv itemconf $linehtag($row) -font $font
2971 if {[info exists selectedline] && $row == $selectedline} {
2972 $canv delete secsel
2973 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2974 -outline {{}} -tags secsel \
2975 -fill [$canv cget -selectbackground]]
2976 $canv lower $t
2980 proc bolden_name {row font} {
2981 global canv2 linentag selectedline boldnamerows
2983 lappend boldnamerows $row
2984 $canv2 itemconf $linentag($row) -font $font
2985 if {[info exists selectedline] && $row == $selectedline} {
2986 $canv2 delete secsel
2987 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2988 -outline {{}} -tags secsel \
2989 -fill [$canv2 cget -selectbackground]]
2990 $canv2 lower $t
2994 proc unbolden {} {
2995 global boldrows
2997 set stillbold {}
2998 foreach row $boldrows {
2999 if {![ishighlighted [commitonrow $row]]} {
3000 bolden $row mainfont
3001 } else {
3002 lappend stillbold $row
3005 set boldrows $stillbold
3008 proc addvhighlight {n} {
3009 global hlview viewcomplete curview vhl_done commitidx
3011 if {[info exists hlview]} {
3012 delvhighlight
3014 set hlview $n
3015 if {$n != $curview && ![info exists viewcomplete($n)]} {
3016 start_rev_list $n
3018 set vhl_done $commitidx($hlview)
3019 if {$vhl_done > 0} {
3020 drawvisible
3024 proc delvhighlight {} {
3025 global hlview vhighlights
3027 if {![info exists hlview]} return
3028 unset hlview
3029 catch {unset vhighlights}
3030 unbolden
3033 proc vhighlightmore {} {
3034 global hlview vhl_done commitidx vhighlights curview
3036 set max $commitidx($hlview)
3037 set vr [visiblerows]
3038 set r0 [lindex $vr 0]
3039 set r1 [lindex $vr 1]
3040 for {set i $vhl_done} {$i < $max} {incr i} {
3041 set id [commitonrow $i $hlview]
3042 if {[commitinview $id $curview]} {
3043 set row [rowofcommit $id]
3044 if {$r0 <= $row && $row <= $r1} {
3045 if {![highlighted $row]} {
3046 bolden $row mainfontbold
3048 set vhighlights($id) 1
3052 set vhl_done $max
3053 return 0
3056 proc askvhighlight {row id} {
3057 global hlview vhighlights iddrawn
3059 if {[commitinview $id $hlview]} {
3060 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3061 bolden $row mainfontbold
3063 set vhighlights($id) 1
3064 } else {
3065 set vhighlights($id) 0
3069 proc hfiles_change {} {
3070 global highlight_files filehighlight fhighlights fh_serial
3071 global highlight_paths gdttype
3073 if {[info exists filehighlight]} {
3074 # delete previous highlights
3075 catch {close $filehighlight}
3076 unset filehighlight
3077 catch {unset fhighlights}
3078 unbolden
3079 unhighlight_filelist
3081 set highlight_paths {}
3082 after cancel do_file_hl $fh_serial
3083 incr fh_serial
3084 if {$highlight_files ne {}} {
3085 after 300 do_file_hl $fh_serial
3089 proc gdttype_change {name ix op} {
3090 global gdttype highlight_files findstring findpattern
3092 stopfinding
3093 if {$findstring ne {}} {
3094 if {$gdttype eq [mc "containing:"]} {
3095 if {$highlight_files ne {}} {
3096 set highlight_files {}
3097 hfiles_change
3099 findcom_change
3100 } else {
3101 if {$findpattern ne {}} {
3102 set findpattern {}
3103 findcom_change
3105 set highlight_files $findstring
3106 hfiles_change
3108 drawvisible
3110 # enable/disable findtype/findloc menus too
3113 proc find_change {name ix op} {
3114 global gdttype findstring highlight_files
3116 stopfinding
3117 if {$gdttype eq [mc "containing:"]} {
3118 findcom_change
3119 } else {
3120 if {$highlight_files ne $findstring} {
3121 set highlight_files $findstring
3122 hfiles_change
3125 drawvisible
3128 proc findcom_change args {
3129 global nhighlights boldnamerows
3130 global findpattern findtype findstring gdttype
3132 stopfinding
3133 # delete previous highlights, if any
3134 foreach row $boldnamerows {
3135 bolden_name $row mainfont
3137 set boldnamerows {}
3138 catch {unset nhighlights}
3139 unbolden
3140 unmarkmatches
3141 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3142 set findpattern {}
3143 } elseif {$findtype eq [mc "Regexp"]} {
3144 set findpattern $findstring
3145 } else {
3146 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3147 $findstring]
3148 set findpattern "*$e*"
3152 proc makepatterns {l} {
3153 set ret {}
3154 foreach e $l {
3155 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3156 if {[string index $ee end] eq "/"} {
3157 lappend ret "$ee*"
3158 } else {
3159 lappend ret $ee
3160 lappend ret "$ee/*"
3163 return $ret
3166 proc do_file_hl {serial} {
3167 global highlight_files filehighlight highlight_paths gdttype fhl_list
3169 if {$gdttype eq [mc "touching paths:"]} {
3170 if {[catch {set paths [shellsplit $highlight_files]}]} return
3171 set highlight_paths [makepatterns $paths]
3172 highlight_filelist
3173 set gdtargs [concat -- $paths]
3174 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3175 set gdtargs [list "-S$highlight_files"]
3176 } else {
3177 # must be "containing:", i.e. we're searching commit info
3178 return
3180 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3181 set filehighlight [open $cmd r+]
3182 fconfigure $filehighlight -blocking 0
3183 filerun $filehighlight readfhighlight
3184 set fhl_list {}
3185 drawvisible
3186 flushhighlights
3189 proc flushhighlights {} {
3190 global filehighlight fhl_list
3192 if {[info exists filehighlight]} {
3193 lappend fhl_list {}
3194 puts $filehighlight ""
3195 flush $filehighlight
3199 proc askfilehighlight {row id} {
3200 global filehighlight fhighlights fhl_list
3202 lappend fhl_list $id
3203 set fhighlights($id) -1
3204 puts $filehighlight $id
3207 proc readfhighlight {} {
3208 global filehighlight fhighlights curview iddrawn
3209 global fhl_list find_dirn
3211 if {![info exists filehighlight]} {
3212 return 0
3214 set nr 0
3215 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3216 set line [string trim $line]
3217 set i [lsearch -exact $fhl_list $line]
3218 if {$i < 0} continue
3219 for {set j 0} {$j < $i} {incr j} {
3220 set id [lindex $fhl_list $j]
3221 set fhighlights($id) 0
3223 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3224 if {$line eq {}} continue
3225 if {![commitinview $line $curview]} continue
3226 set row [rowofcommit $line]
3227 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3228 bolden $row mainfontbold
3230 set fhighlights($line) 1
3232 if {[eof $filehighlight]} {
3233 # strange...
3234 puts "oops, git diff-tree died"
3235 catch {close $filehighlight}
3236 unset filehighlight
3237 return 0
3239 if {[info exists find_dirn]} {
3240 run findmore
3242 return 1
3245 proc doesmatch {f} {
3246 global findtype findpattern
3248 if {$findtype eq [mc "Regexp"]} {
3249 return [regexp $findpattern $f]
3250 } elseif {$findtype eq [mc "IgnCase"]} {
3251 return [string match -nocase $findpattern $f]
3252 } else {
3253 return [string match $findpattern $f]
3257 proc askfindhighlight {row id} {
3258 global nhighlights commitinfo iddrawn
3259 global findloc
3260 global markingmatches
3262 if {![info exists commitinfo($id)]} {
3263 getcommit $id
3265 set info $commitinfo($id)
3266 set isbold 0
3267 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3268 foreach f $info ty $fldtypes {
3269 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3270 [doesmatch $f]} {
3271 if {$ty eq [mc "Author"]} {
3272 set isbold 2
3273 break
3275 set isbold 1
3278 if {$isbold && [info exists iddrawn($id)]} {
3279 if {![ishighlighted $id]} {
3280 bolden $row mainfontbold
3281 if {$isbold > 1} {
3282 bolden_name $row mainfontbold
3285 if {$markingmatches} {
3286 markrowmatches $row $id
3289 set nhighlights($id) $isbold
3292 proc markrowmatches {row id} {
3293 global canv canv2 linehtag linentag commitinfo findloc
3295 set headline [lindex $commitinfo($id) 0]
3296 set author [lindex $commitinfo($id) 1]
3297 $canv delete match$row
3298 $canv2 delete match$row
3299 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3300 set m [findmatches $headline]
3301 if {$m ne {}} {
3302 markmatches $canv $row $headline $linehtag($row) $m \
3303 [$canv itemcget $linehtag($row) -font] $row
3306 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3307 set m [findmatches $author]
3308 if {$m ne {}} {
3309 markmatches $canv2 $row $author $linentag($row) $m \
3310 [$canv2 itemcget $linentag($row) -font] $row
3315 proc vrel_change {name ix op} {
3316 global highlight_related
3318 rhighlight_none
3319 if {$highlight_related ne [mc "None"]} {
3320 run drawvisible
3324 # prepare for testing whether commits are descendents or ancestors of a
3325 proc rhighlight_sel {a} {
3326 global descendent desc_todo ancestor anc_todo
3327 global highlight_related
3329 catch {unset descendent}
3330 set desc_todo [list $a]
3331 catch {unset ancestor}
3332 set anc_todo [list $a]
3333 if {$highlight_related ne [mc "None"]} {
3334 rhighlight_none
3335 run drawvisible
3339 proc rhighlight_none {} {
3340 global rhighlights
3342 catch {unset rhighlights}
3343 unbolden
3346 proc is_descendent {a} {
3347 global curview children descendent desc_todo
3349 set v $curview
3350 set la [rowofcommit $a]
3351 set todo $desc_todo
3352 set leftover {}
3353 set done 0
3354 for {set i 0} {$i < [llength $todo]} {incr i} {
3355 set do [lindex $todo $i]
3356 if {[rowofcommit $do] < $la} {
3357 lappend leftover $do
3358 continue
3360 foreach nk $children($v,$do) {
3361 if {![info exists descendent($nk)]} {
3362 set descendent($nk) 1
3363 lappend todo $nk
3364 if {$nk eq $a} {
3365 set done 1
3369 if {$done} {
3370 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3371 return
3374 set descendent($a) 0
3375 set desc_todo $leftover
3378 proc is_ancestor {a} {
3379 global curview parents ancestor anc_todo
3381 set v $curview
3382 set la [rowofcommit $a]
3383 set todo $anc_todo
3384 set leftover {}
3385 set done 0
3386 for {set i 0} {$i < [llength $todo]} {incr i} {
3387 set do [lindex $todo $i]
3388 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3389 lappend leftover $do
3390 continue
3392 foreach np $parents($v,$do) {
3393 if {![info exists ancestor($np)]} {
3394 set ancestor($np) 1
3395 lappend todo $np
3396 if {$np eq $a} {
3397 set done 1
3401 if {$done} {
3402 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3403 return
3406 set ancestor($a) 0
3407 set anc_todo $leftover
3410 proc askrelhighlight {row id} {
3411 global descendent highlight_related iddrawn rhighlights
3412 global selectedline ancestor
3414 if {![info exists selectedline]} return
3415 set isbold 0
3416 if {$highlight_related eq [mc "Descendant"] ||
3417 $highlight_related eq [mc "Not descendant"]} {
3418 if {![info exists descendent($id)]} {
3419 is_descendent $id
3421 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3422 set isbold 1
3424 } elseif {$highlight_related eq [mc "Ancestor"] ||
3425 $highlight_related eq [mc "Not ancestor"]} {
3426 if {![info exists ancestor($id)]} {
3427 is_ancestor $id
3429 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3430 set isbold 1
3433 if {[info exists iddrawn($id)]} {
3434 if {$isbold && ![ishighlighted $id]} {
3435 bolden $row mainfontbold
3438 set rhighlights($id) $isbold
3441 # Graph layout functions
3443 proc shortids {ids} {
3444 set res {}
3445 foreach id $ids {
3446 if {[llength $id] > 1} {
3447 lappend res [shortids $id]
3448 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3449 lappend res [string range $id 0 7]
3450 } else {
3451 lappend res $id
3454 return $res
3457 proc ntimes {n o} {
3458 set ret {}
3459 set o [list $o]
3460 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3461 if {($n & $mask) != 0} {
3462 set ret [concat $ret $o]
3464 set o [concat $o $o]
3466 return $ret
3469 proc ordertoken {id} {
3470 global ordertok curview varcid varcstart varctok curview parents children
3471 global nullid nullid2
3473 if {[info exists ordertok($id)]} {
3474 return $ordertok($id)
3476 set origid $id
3477 set todo {}
3478 while {1} {
3479 if {[info exists varcid($curview,$id)]} {
3480 set a $varcid($curview,$id)
3481 set p [lindex $varcstart($curview) $a]
3482 } else {
3483 set p [lindex $children($curview,$id) 0]
3485 if {[info exists ordertok($p)]} {
3486 set tok $ordertok($p)
3487 break
3489 set id [first_real_child $curview,$p]
3490 if {$id eq {}} {
3491 # it's a root
3492 set tok [lindex $varctok($curview) $varcid($curview,$p)]
3493 break
3495 if {[llength $parents($curview,$id)] == 1} {
3496 lappend todo [list $p {}]
3497 } else {
3498 set j [lsearch -exact $parents($curview,$id) $p]
3499 if {$j < 0} {
3500 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3502 lappend todo [list $p [strrep $j]]
3505 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3506 set p [lindex $todo $i 0]
3507 append tok [lindex $todo $i 1]
3508 set ordertok($p) $tok
3510 set ordertok($origid) $tok
3511 return $tok
3514 # Work out where id should go in idlist so that order-token
3515 # values increase from left to right
3516 proc idcol {idlist id {i 0}} {
3517 set t [ordertoken $id]
3518 if {$i < 0} {
3519 set i 0
3521 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3522 if {$i > [llength $idlist]} {
3523 set i [llength $idlist]
3525 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3526 incr i
3527 } else {
3528 if {$t > [ordertoken [lindex $idlist $i]]} {
3529 while {[incr i] < [llength $idlist] &&
3530 $t >= [ordertoken [lindex $idlist $i]]} {}
3533 return $i
3536 proc initlayout {} {
3537 global rowidlist rowisopt rowfinal displayorder parentlist
3538 global numcommits canvxmax canv
3539 global nextcolor
3540 global colormap rowtextx
3542 set numcommits 0
3543 set displayorder {}
3544 set parentlist {}
3545 set nextcolor 0
3546 set rowidlist {}
3547 set rowisopt {}
3548 set rowfinal {}
3549 set canvxmax [$canv cget -width]
3550 catch {unset colormap}
3551 catch {unset rowtextx}
3552 setcanvscroll
3555 proc setcanvscroll {} {
3556 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3557 global lastscrollset lastscrollrows
3559 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3560 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3561 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3562 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3563 set lastscrollset [clock clicks -milliseconds]
3564 set lastscrollrows $numcommits
3567 proc visiblerows {} {
3568 global canv numcommits linespc
3570 set ymax [lindex [$canv cget -scrollregion] 3]
3571 if {$ymax eq {} || $ymax == 0} return
3572 set f [$canv yview]
3573 set y0 [expr {int([lindex $f 0] * $ymax)}]
3574 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3575 if {$r0 < 0} {
3576 set r0 0
3578 set y1 [expr {int([lindex $f 1] * $ymax)}]
3579 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3580 if {$r1 >= $numcommits} {
3581 set r1 [expr {$numcommits - 1}]
3583 return [list $r0 $r1]
3586 proc layoutmore {} {
3587 global commitidx viewcomplete curview
3588 global numcommits pending_select selectedline curview
3589 global lastscrollset lastscrollrows commitinterest
3591 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
3592 [clock clicks -milliseconds] - $lastscrollset > 500} {
3593 setcanvscroll
3595 if {[info exists pending_select] &&
3596 [commitinview $pending_select $curview]} {
3597 selectline [rowofcommit $pending_select] 1
3599 drawvisible
3602 proc doshowlocalchanges {} {
3603 global curview mainheadid
3605 if {[commitinview $mainheadid $curview]} {
3606 dodiffindex
3607 } else {
3608 lappend commitinterest($mainheadid) {dodiffindex}
3612 proc dohidelocalchanges {} {
3613 global nullid nullid2 lserial curview
3615 if {[commitinview $nullid $curview]} {
3616 removefakerow $nullid
3618 if {[commitinview $nullid2 $curview]} {
3619 removefakerow $nullid2
3621 incr lserial
3624 # spawn off a process to do git diff-index --cached HEAD
3625 proc dodiffindex {} {
3626 global lserial showlocalchanges
3628 if {!$showlocalchanges} return
3629 incr lserial
3630 set fd [open "|git diff-index --cached HEAD" r]
3631 fconfigure $fd -blocking 0
3632 filerun $fd [list readdiffindex $fd $lserial]
3635 proc readdiffindex {fd serial} {
3636 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3638 set isdiff 1
3639 if {[gets $fd line] < 0} {
3640 if {![eof $fd]} {
3641 return 1
3643 set isdiff 0
3645 # we only need to see one line and we don't really care what it says...
3646 close $fd
3648 if {$serial != $lserial} {
3649 return 0
3652 # now see if there are any local changes not checked in to the index
3653 set fd [open "|git diff-files" r]
3654 fconfigure $fd -blocking 0
3655 filerun $fd [list readdifffiles $fd $serial]
3657 if {$isdiff && ![commitinview $nullid2 $curview]} {
3658 # add the line for the changes in the index to the graph
3659 set hl [mc "Local changes checked in to index but not committed"]
3660 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3661 set commitdata($nullid2) "\n $hl\n"
3662 if {[commitinview $nullid $curview]} {
3663 removefakerow $nullid
3665 insertfakerow $nullid2 $mainheadid
3666 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
3667 removefakerow $nullid2
3669 return 0
3672 proc readdifffiles {fd serial} {
3673 global mainheadid nullid nullid2 curview
3674 global commitinfo commitdata lserial
3676 set isdiff 1
3677 if {[gets $fd line] < 0} {
3678 if {![eof $fd]} {
3679 return 1
3681 set isdiff 0
3683 # we only need to see one line and we don't really care what it says...
3684 close $fd
3686 if {$serial != $lserial} {
3687 return 0
3690 if {$isdiff && ![commitinview $nullid $curview]} {
3691 # add the line for the local diff to the graph
3692 set hl [mc "Local uncommitted changes, not checked in to index"]
3693 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3694 set commitdata($nullid) "\n $hl\n"
3695 if {[commitinview $nullid2 $curview]} {
3696 set p $nullid2
3697 } else {
3698 set p $mainheadid
3700 insertfakerow $nullid $p
3701 } elseif {!$isdiff && [commitinview $nullid $curview]} {
3702 removefakerow $nullid
3704 return 0
3707 proc nextuse {id row} {
3708 global curview children
3710 if {[info exists children($curview,$id)]} {
3711 foreach kid $children($curview,$id) {
3712 if {![commitinview $kid $curview]} {
3713 return -1
3715 if {[rowofcommit $kid] > $row} {
3716 return [rowofcommit $kid]
3720 if {[commitinview $id $curview]} {
3721 return [rowofcommit $id]
3723 return -1
3726 proc prevuse {id row} {
3727 global curview children
3729 set ret -1
3730 if {[info exists children($curview,$id)]} {
3731 foreach kid $children($curview,$id) {
3732 if {![commitinview $kid $curview]} break
3733 if {[rowofcommit $kid] < $row} {
3734 set ret [rowofcommit $kid]
3738 return $ret
3741 proc make_idlist {row} {
3742 global displayorder parentlist uparrowlen downarrowlen mingaplen
3743 global commitidx curview children
3745 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3746 if {$r < 0} {
3747 set r 0
3749 set ra [expr {$row - $downarrowlen}]
3750 if {$ra < 0} {
3751 set ra 0
3753 set rb [expr {$row + $uparrowlen}]
3754 if {$rb > $commitidx($curview)} {
3755 set rb $commitidx($curview)
3757 make_disporder $r [expr {$rb + 1}]
3758 set ids {}
3759 for {} {$r < $ra} {incr r} {
3760 set nextid [lindex $displayorder [expr {$r + 1}]]
3761 foreach p [lindex $parentlist $r] {
3762 if {$p eq $nextid} continue
3763 set rn [nextuse $p $r]
3764 if {$rn >= $row &&
3765 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3766 lappend ids [list [ordertoken $p] $p]
3770 for {} {$r < $row} {incr r} {
3771 set nextid [lindex $displayorder [expr {$r + 1}]]
3772 foreach p [lindex $parentlist $r] {
3773 if {$p eq $nextid} continue
3774 set rn [nextuse $p $r]
3775 if {$rn < 0 || $rn >= $row} {
3776 lappend ids [list [ordertoken $p] $p]
3780 set id [lindex $displayorder $row]
3781 lappend ids [list [ordertoken $id] $id]
3782 while {$r < $rb} {
3783 foreach p [lindex $parentlist $r] {
3784 set firstkid [lindex $children($curview,$p) 0]
3785 if {[rowofcommit $firstkid] < $row} {
3786 lappend ids [list [ordertoken $p] $p]
3789 incr r
3790 set id [lindex $displayorder $r]
3791 if {$id ne {}} {
3792 set firstkid [lindex $children($curview,$id) 0]
3793 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3794 lappend ids [list [ordertoken $id] $id]
3798 set idlist {}
3799 foreach idx [lsort -unique $ids] {
3800 lappend idlist [lindex $idx 1]
3802 return $idlist
3805 proc rowsequal {a b} {
3806 while {[set i [lsearch -exact $a {}]] >= 0} {
3807 set a [lreplace $a $i $i]
3809 while {[set i [lsearch -exact $b {}]] >= 0} {
3810 set b [lreplace $b $i $i]
3812 return [expr {$a eq $b}]
3815 proc makeupline {id row rend col} {
3816 global rowidlist uparrowlen downarrowlen mingaplen
3818 for {set r $rend} {1} {set r $rstart} {
3819 set rstart [prevuse $id $r]
3820 if {$rstart < 0} return
3821 if {$rstart < $row} break
3823 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3824 set rstart [expr {$rend - $uparrowlen - 1}]
3826 for {set r $rstart} {[incr r] <= $row} {} {
3827 set idlist [lindex $rowidlist $r]
3828 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3829 set col [idcol $idlist $id $col]
3830 lset rowidlist $r [linsert $idlist $col $id]
3831 changedrow $r
3836 proc layoutrows {row endrow} {
3837 global rowidlist rowisopt rowfinal displayorder
3838 global uparrowlen downarrowlen maxwidth mingaplen
3839 global children parentlist
3840 global commitidx viewcomplete curview
3842 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3843 set idlist {}
3844 if {$row > 0} {
3845 set rm1 [expr {$row - 1}]
3846 foreach id [lindex $rowidlist $rm1] {
3847 if {$id ne {}} {
3848 lappend idlist $id
3851 set final [lindex $rowfinal $rm1]
3853 for {} {$row < $endrow} {incr row} {
3854 set rm1 [expr {$row - 1}]
3855 if {$rm1 < 0 || $idlist eq {}} {
3856 set idlist [make_idlist $row]
3857 set final 1
3858 } else {
3859 set id [lindex $displayorder $rm1]
3860 set col [lsearch -exact $idlist $id]
3861 set idlist [lreplace $idlist $col $col]
3862 foreach p [lindex $parentlist $rm1] {
3863 if {[lsearch -exact $idlist $p] < 0} {
3864 set col [idcol $idlist $p $col]
3865 set idlist [linsert $idlist $col $p]
3866 # if not the first child, we have to insert a line going up
3867 if {$id ne [lindex $children($curview,$p) 0]} {
3868 makeupline $p $rm1 $row $col
3872 set id [lindex $displayorder $row]
3873 if {$row > $downarrowlen} {
3874 set termrow [expr {$row - $downarrowlen - 1}]
3875 foreach p [lindex $parentlist $termrow] {
3876 set i [lsearch -exact $idlist $p]
3877 if {$i < 0} continue
3878 set nr [nextuse $p $termrow]
3879 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3880 set idlist [lreplace $idlist $i $i]
3884 set col [lsearch -exact $idlist $id]
3885 if {$col < 0} {
3886 set col [idcol $idlist $id]
3887 set idlist [linsert $idlist $col $id]
3888 if {$children($curview,$id) ne {}} {
3889 makeupline $id $rm1 $row $col
3892 set r [expr {$row + $uparrowlen - 1}]
3893 if {$r < $commitidx($curview)} {
3894 set x $col
3895 foreach p [lindex $parentlist $r] {
3896 if {[lsearch -exact $idlist $p] >= 0} continue
3897 set fk [lindex $children($curview,$p) 0]
3898 if {[rowofcommit $fk] < $row} {
3899 set x [idcol $idlist $p $x]
3900 set idlist [linsert $idlist $x $p]
3903 if {[incr r] < $commitidx($curview)} {
3904 set p [lindex $displayorder $r]
3905 if {[lsearch -exact $idlist $p] < 0} {
3906 set fk [lindex $children($curview,$p) 0]
3907 if {$fk ne {} && [rowofcommit $fk] < $row} {
3908 set x [idcol $idlist $p $x]
3909 set idlist [linsert $idlist $x $p]
3915 if {$final && !$viewcomplete($curview) &&
3916 $row + $uparrowlen + $mingaplen + $downarrowlen
3917 >= $commitidx($curview)} {
3918 set final 0
3920 set l [llength $rowidlist]
3921 if {$row == $l} {
3922 lappend rowidlist $idlist
3923 lappend rowisopt 0
3924 lappend rowfinal $final
3925 } elseif {$row < $l} {
3926 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3927 lset rowidlist $row $idlist
3928 changedrow $row
3930 lset rowfinal $row $final
3931 } else {
3932 set pad [ntimes [expr {$row - $l}] {}]
3933 set rowidlist [concat $rowidlist $pad]
3934 lappend rowidlist $idlist
3935 set rowfinal [concat $rowfinal $pad]
3936 lappend rowfinal $final
3937 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3940 return $row
3943 proc changedrow {row} {
3944 global displayorder iddrawn rowisopt need_redisplay
3946 set l [llength $rowisopt]
3947 if {$row < $l} {
3948 lset rowisopt $row 0
3949 if {$row + 1 < $l} {
3950 lset rowisopt [expr {$row + 1}] 0
3951 if {$row + 2 < $l} {
3952 lset rowisopt [expr {$row + 2}] 0
3956 set id [lindex $displayorder $row]
3957 if {[info exists iddrawn($id)]} {
3958 set need_redisplay 1
3962 proc insert_pad {row col npad} {
3963 global rowidlist
3965 set pad [ntimes $npad {}]
3966 set idlist [lindex $rowidlist $row]
3967 set bef [lrange $idlist 0 [expr {$col - 1}]]
3968 set aft [lrange $idlist $col end]
3969 set i [lsearch -exact $aft {}]
3970 if {$i > 0} {
3971 set aft [lreplace $aft $i $i]
3973 lset rowidlist $row [concat $bef $pad $aft]
3974 changedrow $row
3977 proc optimize_rows {row col endrow} {
3978 global rowidlist rowisopt displayorder curview children
3980 if {$row < 1} {
3981 set row 1
3983 for {} {$row < $endrow} {incr row; set col 0} {
3984 if {[lindex $rowisopt $row]} continue
3985 set haspad 0
3986 set y0 [expr {$row - 1}]
3987 set ym [expr {$row - 2}]
3988 set idlist [lindex $rowidlist $row]
3989 set previdlist [lindex $rowidlist $y0]
3990 if {$idlist eq {} || $previdlist eq {}} continue
3991 if {$ym >= 0} {
3992 set pprevidlist [lindex $rowidlist $ym]
3993 if {$pprevidlist eq {}} continue
3994 } else {
3995 set pprevidlist {}
3997 set x0 -1
3998 set xm -1
3999 for {} {$col < [llength $idlist]} {incr col} {
4000 set id [lindex $idlist $col]
4001 if {[lindex $previdlist $col] eq $id} continue
4002 if {$id eq {}} {
4003 set haspad 1
4004 continue
4006 set x0 [lsearch -exact $previdlist $id]
4007 if {$x0 < 0} continue
4008 set z [expr {$x0 - $col}]
4009 set isarrow 0
4010 set z0 {}
4011 if {$ym >= 0} {
4012 set xm [lsearch -exact $pprevidlist $id]
4013 if {$xm >= 0} {
4014 set z0 [expr {$xm - $x0}]
4017 if {$z0 eq {}} {
4018 # if row y0 is the first child of $id then it's not an arrow
4019 if {[lindex $children($curview,$id) 0] ne
4020 [lindex $displayorder $y0]} {
4021 set isarrow 1
4024 if {!$isarrow && $id ne [lindex $displayorder $row] &&
4025 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4026 set isarrow 1
4028 # Looking at lines from this row to the previous row,
4029 # make them go straight up if they end in an arrow on
4030 # the previous row; otherwise make them go straight up
4031 # or at 45 degrees.
4032 if {$z < -1 || ($z < 0 && $isarrow)} {
4033 # Line currently goes left too much;
4034 # insert pads in the previous row, then optimize it
4035 set npad [expr {-1 - $z + $isarrow}]
4036 insert_pad $y0 $x0 $npad
4037 if {$y0 > 0} {
4038 optimize_rows $y0 $x0 $row
4040 set previdlist [lindex $rowidlist $y0]
4041 set x0 [lsearch -exact $previdlist $id]
4042 set z [expr {$x0 - $col}]
4043 if {$z0 ne {}} {
4044 set pprevidlist [lindex $rowidlist $ym]
4045 set xm [lsearch -exact $pprevidlist $id]
4046 set z0 [expr {$xm - $x0}]
4048 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4049 # Line currently goes right too much;
4050 # insert pads in this line
4051 set npad [expr {$z - 1 + $isarrow}]
4052 insert_pad $row $col $npad
4053 set idlist [lindex $rowidlist $row]
4054 incr col $npad
4055 set z [expr {$x0 - $col}]
4056 set haspad 1
4058 if {$z0 eq {} && !$isarrow && $ym >= 0} {
4059 # this line links to its first child on row $row-2
4060 set id [lindex $displayorder $ym]
4061 set xc [lsearch -exact $pprevidlist $id]
4062 if {$xc >= 0} {
4063 set z0 [expr {$xc - $x0}]
4066 # avoid lines jigging left then immediately right
4067 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4068 insert_pad $y0 $x0 1
4069 incr x0
4070 optimize_rows $y0 $x0 $row
4071 set previdlist [lindex $rowidlist $y0]
4074 if {!$haspad} {
4075 # Find the first column that doesn't have a line going right
4076 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4077 set id [lindex $idlist $col]
4078 if {$id eq {}} break
4079 set x0 [lsearch -exact $previdlist $id]
4080 if {$x0 < 0} {
4081 # check if this is the link to the first child
4082 set kid [lindex $displayorder $y0]
4083 if {[lindex $children($curview,$id) 0] eq $kid} {
4084 # it is, work out offset to child
4085 set x0 [lsearch -exact $previdlist $kid]
4088 if {$x0 <= $col} break
4090 # Insert a pad at that column as long as it has a line and
4091 # isn't the last column
4092 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4093 set idlist [linsert $idlist $col {}]
4094 lset rowidlist $row $idlist
4095 changedrow $row
4101 proc xc {row col} {
4102 global canvx0 linespc
4103 return [expr {$canvx0 + $col * $linespc}]
4106 proc yc {row} {
4107 global canvy0 linespc
4108 return [expr {$canvy0 + $row * $linespc}]
4111 proc linewidth {id} {
4112 global thickerline lthickness
4114 set wid $lthickness
4115 if {[info exists thickerline] && $id eq $thickerline} {
4116 set wid [expr {2 * $lthickness}]
4118 return $wid
4121 proc rowranges {id} {
4122 global curview children uparrowlen downarrowlen
4123 global rowidlist
4125 set kids $children($curview,$id)
4126 if {$kids eq {}} {
4127 return {}
4129 set ret {}
4130 lappend kids $id
4131 foreach child $kids {
4132 if {![commitinview $child $curview]} break
4133 set row [rowofcommit $child]
4134 if {![info exists prev]} {
4135 lappend ret [expr {$row + 1}]
4136 } else {
4137 if {$row <= $prevrow} {
4138 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4140 # see if the line extends the whole way from prevrow to row
4141 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4142 [lsearch -exact [lindex $rowidlist \
4143 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4144 # it doesn't, see where it ends
4145 set r [expr {$prevrow + $downarrowlen}]
4146 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4147 while {[incr r -1] > $prevrow &&
4148 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4149 } else {
4150 while {[incr r] <= $row &&
4151 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4152 incr r -1
4154 lappend ret $r
4155 # see where it starts up again
4156 set r [expr {$row - $uparrowlen}]
4157 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4158 while {[incr r] < $row &&
4159 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4160 } else {
4161 while {[incr r -1] >= $prevrow &&
4162 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4163 incr r
4165 lappend ret $r
4168 if {$child eq $id} {
4169 lappend ret $row
4171 set prev $child
4172 set prevrow $row
4174 return $ret
4177 proc drawlineseg {id row endrow arrowlow} {
4178 global rowidlist displayorder iddrawn linesegs
4179 global canv colormap linespc curview maxlinelen parentlist
4181 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4182 set le [expr {$row + 1}]
4183 set arrowhigh 1
4184 while {1} {
4185 set c [lsearch -exact [lindex $rowidlist $le] $id]
4186 if {$c < 0} {
4187 incr le -1
4188 break
4190 lappend cols $c
4191 set x [lindex $displayorder $le]
4192 if {$x eq $id} {
4193 set arrowhigh 0
4194 break
4196 if {[info exists iddrawn($x)] || $le == $endrow} {
4197 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4198 if {$c >= 0} {
4199 lappend cols $c
4200 set arrowhigh 0
4202 break
4204 incr le
4206 if {$le <= $row} {
4207 return $row
4210 set lines {}
4211 set i 0
4212 set joinhigh 0
4213 if {[info exists linesegs($id)]} {
4214 set lines $linesegs($id)
4215 foreach li $lines {
4216 set r0 [lindex $li 0]
4217 if {$r0 > $row} {
4218 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4219 set joinhigh 1
4221 break
4223 incr i
4226 set joinlow 0
4227 if {$i > 0} {
4228 set li [lindex $lines [expr {$i-1}]]
4229 set r1 [lindex $li 1]
4230 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4231 set joinlow 1
4235 set x [lindex $cols [expr {$le - $row}]]
4236 set xp [lindex $cols [expr {$le - 1 - $row}]]
4237 set dir [expr {$xp - $x}]
4238 if {$joinhigh} {
4239 set ith [lindex $lines $i 2]
4240 set coords [$canv coords $ith]
4241 set ah [$canv itemcget $ith -arrow]
4242 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4243 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4244 if {$x2 ne {} && $x - $x2 == $dir} {
4245 set coords [lrange $coords 0 end-2]
4247 } else {
4248 set coords [list [xc $le $x] [yc $le]]
4250 if {$joinlow} {
4251 set itl [lindex $lines [expr {$i-1}] 2]
4252 set al [$canv itemcget $itl -arrow]
4253 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4254 } elseif {$arrowlow} {
4255 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4256 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4257 set arrowlow 0
4260 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4261 for {set y $le} {[incr y -1] > $row} {} {
4262 set x $xp
4263 set xp [lindex $cols [expr {$y - 1 - $row}]]
4264 set ndir [expr {$xp - $x}]
4265 if {$dir != $ndir || $xp < 0} {
4266 lappend coords [xc $y $x] [yc $y]
4268 set dir $ndir
4270 if {!$joinlow} {
4271 if {$xp < 0} {
4272 # join parent line to first child
4273 set ch [lindex $displayorder $row]
4274 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4275 if {$xc < 0} {
4276 puts "oops: drawlineseg: child $ch not on row $row"
4277 } elseif {$xc != $x} {
4278 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4279 set d [expr {int(0.5 * $linespc)}]
4280 set x1 [xc $row $x]
4281 if {$xc < $x} {
4282 set x2 [expr {$x1 - $d}]
4283 } else {
4284 set x2 [expr {$x1 + $d}]
4286 set y2 [yc $row]
4287 set y1 [expr {$y2 + $d}]
4288 lappend coords $x1 $y1 $x2 $y2
4289 } elseif {$xc < $x - 1} {
4290 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4291 } elseif {$xc > $x + 1} {
4292 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4294 set x $xc
4296 lappend coords [xc $row $x] [yc $row]
4297 } else {
4298 set xn [xc $row $xp]
4299 set yn [yc $row]
4300 lappend coords $xn $yn
4302 if {!$joinhigh} {
4303 assigncolor $id
4304 set t [$canv create line $coords -width [linewidth $id] \
4305 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4306 $canv lower $t
4307 bindline $t $id
4308 set lines [linsert $lines $i [list $row $le $t]]
4309 } else {
4310 $canv coords $ith $coords
4311 if {$arrow ne $ah} {
4312 $canv itemconf $ith -arrow $arrow
4314 lset lines $i 0 $row
4316 } else {
4317 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4318 set ndir [expr {$xo - $xp}]
4319 set clow [$canv coords $itl]
4320 if {$dir == $ndir} {
4321 set clow [lrange $clow 2 end]
4323 set coords [concat $coords $clow]
4324 if {!$joinhigh} {
4325 lset lines [expr {$i-1}] 1 $le
4326 } else {
4327 # coalesce two pieces
4328 $canv delete $ith
4329 set b [lindex $lines [expr {$i-1}] 0]
4330 set e [lindex $lines $i 1]
4331 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4333 $canv coords $itl $coords
4334 if {$arrow ne $al} {
4335 $canv itemconf $itl -arrow $arrow
4339 set linesegs($id) $lines
4340 return $le
4343 proc drawparentlinks {id row} {
4344 global rowidlist canv colormap curview parentlist
4345 global idpos linespc
4347 set rowids [lindex $rowidlist $row]
4348 set col [lsearch -exact $rowids $id]
4349 if {$col < 0} return
4350 set olds [lindex $parentlist $row]
4351 set row2 [expr {$row + 1}]
4352 set x [xc $row $col]
4353 set y [yc $row]
4354 set y2 [yc $row2]
4355 set d [expr {int(0.5 * $linespc)}]
4356 set ymid [expr {$y + $d}]
4357 set ids [lindex $rowidlist $row2]
4358 # rmx = right-most X coord used
4359 set rmx 0
4360 foreach p $olds {
4361 set i [lsearch -exact $ids $p]
4362 if {$i < 0} {
4363 puts "oops, parent $p of $id not in list"
4364 continue
4366 set x2 [xc $row2 $i]
4367 if {$x2 > $rmx} {
4368 set rmx $x2
4370 set j [lsearch -exact $rowids $p]
4371 if {$j < 0} {
4372 # drawlineseg will do this one for us
4373 continue
4375 assigncolor $p
4376 # should handle duplicated parents here...
4377 set coords [list $x $y]
4378 if {$i != $col} {
4379 # if attaching to a vertical segment, draw a smaller
4380 # slant for visual distinctness
4381 if {$i == $j} {
4382 if {$i < $col} {
4383 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4384 } else {
4385 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4387 } elseif {$i < $col && $i < $j} {
4388 # segment slants towards us already
4389 lappend coords [xc $row $j] $y
4390 } else {
4391 if {$i < $col - 1} {
4392 lappend coords [expr {$x2 + $linespc}] $y
4393 } elseif {$i > $col + 1} {
4394 lappend coords [expr {$x2 - $linespc}] $y
4396 lappend coords $x2 $y2
4398 } else {
4399 lappend coords $x2 $y2
4401 set t [$canv create line $coords -width [linewidth $p] \
4402 -fill $colormap($p) -tags lines.$p]
4403 $canv lower $t
4404 bindline $t $p
4406 if {$rmx > [lindex $idpos($id) 1]} {
4407 lset idpos($id) 1 $rmx
4408 redrawtags $id
4412 proc drawlines {id} {
4413 global canv
4415 $canv itemconf lines.$id -width [linewidth $id]
4418 proc drawcmittext {id row col} {
4419 global linespc canv canv2 canv3 fgcolor curview
4420 global cmitlisted commitinfo rowidlist parentlist
4421 global rowtextx idpos idtags idheads idotherrefs
4422 global linehtag linentag linedtag selectedline
4423 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4425 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4426 set listed $cmitlisted($curview,$id)
4427 if {$id eq $nullid} {
4428 set ofill red
4429 } elseif {$id eq $nullid2} {
4430 set ofill green
4431 } else {
4432 set ofill [expr {$listed != 0 ? $listed == 2 ? "gray" : "blue" : "white"}]
4434 set x [xc $row $col]
4435 set y [yc $row]
4436 set orad [expr {$linespc / 3}]
4437 if {$listed <= 2} {
4438 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4439 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4440 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4441 } elseif {$listed == 3} {
4442 # triangle pointing left for left-side commits
4443 set t [$canv create polygon \
4444 [expr {$x - $orad}] $y \
4445 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4446 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4447 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4448 } else {
4449 # triangle pointing right for right-side commits
4450 set t [$canv create polygon \
4451 [expr {$x + $orad - 1}] $y \
4452 [expr {$x - $orad}] [expr {$y - $orad}] \
4453 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4454 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4456 $canv raise $t
4457 $canv bind $t <1> {selcanvline {} %x %y}
4458 set rmx [llength [lindex $rowidlist $row]]
4459 set olds [lindex $parentlist $row]
4460 if {$olds ne {}} {
4461 set nextids [lindex $rowidlist [expr {$row + 1}]]
4462 foreach p $olds {
4463 set i [lsearch -exact $nextids $p]
4464 if {$i > $rmx} {
4465 set rmx $i
4469 set xt [xc $row $rmx]
4470 set rowtextx($row) $xt
4471 set idpos($id) [list $x $xt $y]
4472 if {[info exists idtags($id)] || [info exists idheads($id)]
4473 || [info exists idotherrefs($id)]} {
4474 set xt [drawtags $id $x $xt $y]
4476 set headline [lindex $commitinfo($id) 0]
4477 set name [lindex $commitinfo($id) 1]
4478 set date [lindex $commitinfo($id) 2]
4479 set date [formatdate $date]
4480 set font mainfont
4481 set nfont mainfont
4482 set isbold [ishighlighted $id]
4483 if {$isbold > 0} {
4484 lappend boldrows $row
4485 set font mainfontbold
4486 if {$isbold > 1} {
4487 lappend boldnamerows $row
4488 set nfont mainfontbold
4491 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4492 -text $headline -font $font -tags text]
4493 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4494 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4495 -text $name -font $nfont -tags text]
4496 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4497 -text $date -font mainfont -tags text]
4498 if {[info exists selectedline] && $selectedline == $row} {
4499 make_secsel $row
4501 set xr [expr {$xt + [font measure $font $headline]}]
4502 if {$xr > $canvxmax} {
4503 set canvxmax $xr
4504 setcanvscroll
4508 proc drawcmitrow {row} {
4509 global displayorder rowidlist nrows_drawn
4510 global iddrawn markingmatches
4511 global commitinfo numcommits
4512 global filehighlight fhighlights findpattern nhighlights
4513 global hlview vhighlights
4514 global highlight_related rhighlights
4516 if {$row >= $numcommits} return
4518 set id [lindex $displayorder $row]
4519 if {[info exists hlview] && ![info exists vhighlights($id)]} {
4520 askvhighlight $row $id
4522 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
4523 askfilehighlight $row $id
4525 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
4526 askfindhighlight $row $id
4528 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
4529 askrelhighlight $row $id
4531 if {![info exists iddrawn($id)]} {
4532 set col [lsearch -exact [lindex $rowidlist $row] $id]
4533 if {$col < 0} {
4534 puts "oops, row $row id $id not in list"
4535 return
4537 if {![info exists commitinfo($id)]} {
4538 getcommit $id
4540 assigncolor $id
4541 drawcmittext $id $row $col
4542 set iddrawn($id) 1
4543 incr nrows_drawn
4545 if {$markingmatches} {
4546 markrowmatches $row $id
4550 proc drawcommits {row {endrow {}}} {
4551 global numcommits iddrawn displayorder curview need_redisplay
4552 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4554 if {$row < 0} {
4555 set row 0
4557 if {$endrow eq {}} {
4558 set endrow $row
4560 if {$endrow >= $numcommits} {
4561 set endrow [expr {$numcommits - 1}]
4564 set rl1 [expr {$row - $downarrowlen - 3}]
4565 if {$rl1 < 0} {
4566 set rl1 0
4568 set ro1 [expr {$row - 3}]
4569 if {$ro1 < 0} {
4570 set ro1 0
4572 set r2 [expr {$endrow + $uparrowlen + 3}]
4573 if {$r2 > $numcommits} {
4574 set r2 $numcommits
4576 for {set r $rl1} {$r < $r2} {incr r} {
4577 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4578 if {$rl1 < $r} {
4579 layoutrows $rl1 $r
4581 set rl1 [expr {$r + 1}]
4584 if {$rl1 < $r} {
4585 layoutrows $rl1 $r
4587 optimize_rows $ro1 0 $r2
4588 if {$need_redisplay || $nrows_drawn > 2000} {
4589 clear_display
4590 drawvisible
4593 # make the lines join to already-drawn rows either side
4594 set r [expr {$row - 1}]
4595 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4596 set r $row
4598 set er [expr {$endrow + 1}]
4599 if {$er >= $numcommits ||
4600 ![info exists iddrawn([lindex $displayorder $er])]} {
4601 set er $endrow
4603 for {} {$r <= $er} {incr r} {
4604 set id [lindex $displayorder $r]
4605 set wasdrawn [info exists iddrawn($id)]
4606 drawcmitrow $r
4607 if {$r == $er} break
4608 set nextid [lindex $displayorder [expr {$r + 1}]]
4609 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4610 drawparentlinks $id $r
4612 set rowids [lindex $rowidlist $r]
4613 foreach lid $rowids {
4614 if {$lid eq {}} continue
4615 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4616 if {$lid eq $id} {
4617 # see if this is the first child of any of its parents
4618 foreach p [lindex $parentlist $r] {
4619 if {[lsearch -exact $rowids $p] < 0} {
4620 # make this line extend up to the child
4621 set lineend($p) [drawlineseg $p $r $er 0]
4624 } else {
4625 set lineend($lid) [drawlineseg $lid $r $er 1]
4631 proc undolayout {row} {
4632 global uparrowlen mingaplen downarrowlen
4633 global rowidlist rowisopt rowfinal need_redisplay
4635 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4636 if {$r < 0} {
4637 set r 0
4639 if {[llength $rowidlist] > $r} {
4640 incr r -1
4641 set rowidlist [lrange $rowidlist 0 $r]
4642 set rowfinal [lrange $rowfinal 0 $r]
4643 set rowisopt [lrange $rowisopt 0 $r]
4644 set need_redisplay 1
4645 run drawvisible
4649 proc drawvisible {} {
4650 global canv linespc curview vrowmod selectedline targetrow targetid
4651 global need_redisplay cscroll numcommits
4653 set fs [$canv yview]
4654 set ymax [lindex [$canv cget -scrollregion] 3]
4655 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
4656 set f0 [lindex $fs 0]
4657 set f1 [lindex $fs 1]
4658 set y0 [expr {int($f0 * $ymax)}]
4659 set y1 [expr {int($f1 * $ymax)}]
4661 if {[info exists targetid]} {
4662 if {[commitinview $targetid $curview]} {
4663 set r [rowofcommit $targetid]
4664 if {$r != $targetrow} {
4665 # Fix up the scrollregion and change the scrolling position
4666 # now that our target row has moved.
4667 set diff [expr {($r - $targetrow) * $linespc}]
4668 set targetrow $r
4669 setcanvscroll
4670 set ymax [lindex [$canv cget -scrollregion] 3]
4671 incr y0 $diff
4672 incr y1 $diff
4673 set f0 [expr {$y0 / $ymax}]
4674 set f1 [expr {$y1 / $ymax}]
4675 allcanvs yview moveto $f0
4676 $cscroll set $f0 $f1
4677 set need_redisplay 1
4679 } else {
4680 unset targetid
4684 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4685 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4686 if {$endrow >= $vrowmod($curview)} {
4687 update_arcrows $curview
4689 if {[info exists selectedline] &&
4690 $row <= $selectedline && $selectedline <= $endrow} {
4691 set targetrow $selectedline
4692 } elseif {[info exists targetid]} {
4693 set targetrow [expr {int(($row + $endrow) / 2)}]
4695 if {[info exists targetrow]} {
4696 if {$targetrow >= $numcommits} {
4697 set targetrow [expr {$numcommits - 1}]
4699 set targetid [commitonrow $targetrow]
4701 drawcommits $row $endrow
4704 proc clear_display {} {
4705 global iddrawn linesegs need_redisplay nrows_drawn
4706 global vhighlights fhighlights nhighlights rhighlights
4708 allcanvs delete all
4709 catch {unset iddrawn}
4710 catch {unset linesegs}
4711 catch {unset vhighlights}
4712 catch {unset fhighlights}
4713 catch {unset nhighlights}
4714 catch {unset rhighlights}
4715 set need_redisplay 0
4716 set nrows_drawn 0
4719 proc findcrossings {id} {
4720 global rowidlist parentlist numcommits displayorder
4722 set cross {}
4723 set ccross {}
4724 foreach {s e} [rowranges $id] {
4725 if {$e >= $numcommits} {
4726 set e [expr {$numcommits - 1}]
4728 if {$e <= $s} continue
4729 for {set row $e} {[incr row -1] >= $s} {} {
4730 set x [lsearch -exact [lindex $rowidlist $row] $id]
4731 if {$x < 0} break
4732 set olds [lindex $parentlist $row]
4733 set kid [lindex $displayorder $row]
4734 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4735 if {$kidx < 0} continue
4736 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4737 foreach p $olds {
4738 set px [lsearch -exact $nextrow $p]
4739 if {$px < 0} continue
4740 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4741 if {[lsearch -exact $ccross $p] >= 0} continue
4742 if {$x == $px + ($kidx < $px? -1: 1)} {
4743 lappend ccross $p
4744 } elseif {[lsearch -exact $cross $p] < 0} {
4745 lappend cross $p
4751 return [concat $ccross {{}} $cross]
4754 proc assigncolor {id} {
4755 global colormap colors nextcolor
4756 global parents children children curview
4758 if {[info exists colormap($id)]} return
4759 set ncolors [llength $colors]
4760 if {[info exists children($curview,$id)]} {
4761 set kids $children($curview,$id)
4762 } else {
4763 set kids {}
4765 if {[llength $kids] == 1} {
4766 set child [lindex $kids 0]
4767 if {[info exists colormap($child)]
4768 && [llength $parents($curview,$child)] == 1} {
4769 set colormap($id) $colormap($child)
4770 return
4773 set badcolors {}
4774 set origbad {}
4775 foreach x [findcrossings $id] {
4776 if {$x eq {}} {
4777 # delimiter between corner crossings and other crossings
4778 if {[llength $badcolors] >= $ncolors - 1} break
4779 set origbad $badcolors
4781 if {[info exists colormap($x)]
4782 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4783 lappend badcolors $colormap($x)
4786 if {[llength $badcolors] >= $ncolors} {
4787 set badcolors $origbad
4789 set origbad $badcolors
4790 if {[llength $badcolors] < $ncolors - 1} {
4791 foreach child $kids {
4792 if {[info exists colormap($child)]
4793 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4794 lappend badcolors $colormap($child)
4796 foreach p $parents($curview,$child) {
4797 if {[info exists colormap($p)]
4798 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4799 lappend badcolors $colormap($p)
4803 if {[llength $badcolors] >= $ncolors} {
4804 set badcolors $origbad
4807 for {set i 0} {$i <= $ncolors} {incr i} {
4808 set c [lindex $colors $nextcolor]
4809 if {[incr nextcolor] >= $ncolors} {
4810 set nextcolor 0
4812 if {[lsearch -exact $badcolors $c]} break
4814 set colormap($id) $c
4817 proc bindline {t id} {
4818 global canv
4820 $canv bind $t <Enter> "lineenter %x %y $id"
4821 $canv bind $t <Motion> "linemotion %x %y $id"
4822 $canv bind $t <Leave> "lineleave $id"
4823 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4826 proc drawtags {id x xt y1} {
4827 global idtags idheads idotherrefs mainhead
4828 global linespc lthickness
4829 global canv rowtextx curview fgcolor bgcolor
4831 set marks {}
4832 set ntags 0
4833 set nheads 0
4834 if {[info exists idtags($id)]} {
4835 set marks $idtags($id)
4836 set ntags [llength $marks]
4838 if {[info exists idheads($id)]} {
4839 set marks [concat $marks $idheads($id)]
4840 set nheads [llength $idheads($id)]
4842 if {[info exists idotherrefs($id)]} {
4843 set marks [concat $marks $idotherrefs($id)]
4845 if {$marks eq {}} {
4846 return $xt
4849 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4850 set yt [expr {$y1 - 0.5 * $linespc}]
4851 set yb [expr {$yt + $linespc - 1}]
4852 set xvals {}
4853 set wvals {}
4854 set i -1
4855 foreach tag $marks {
4856 incr i
4857 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4858 set wid [font measure mainfontbold $tag]
4859 } else {
4860 set wid [font measure mainfont $tag]
4862 lappend xvals $xt
4863 lappend wvals $wid
4864 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4866 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4867 -width $lthickness -fill black -tags tag.$id]
4868 $canv lower $t
4869 foreach tag $marks x $xvals wid $wvals {
4870 set xl [expr {$x + $delta}]
4871 set xr [expr {$x + $delta + $wid + $lthickness}]
4872 set font mainfont
4873 if {[incr ntags -1] >= 0} {
4874 # draw a tag
4875 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4876 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4877 -width 1 -outline black -fill yellow -tags tag.$id]
4878 $canv bind $t <1> [list showtag $tag 1]
4879 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4880 } else {
4881 # draw a head or other ref
4882 if {[incr nheads -1] >= 0} {
4883 set col green
4884 if {$tag eq $mainhead} {
4885 set font mainfontbold
4887 } else {
4888 set col "#ddddff"
4890 set xl [expr {$xl - $delta/2}]
4891 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4892 -width 1 -outline black -fill $col -tags tag.$id
4893 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4894 set rwid [font measure mainfont $remoteprefix]
4895 set xi [expr {$x + 1}]
4896 set yti [expr {$yt + 1}]
4897 set xri [expr {$x + $rwid}]
4898 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4899 -width 0 -fill "#ffddaa" -tags tag.$id
4902 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4903 -font $font -tags [list tag.$id text]]
4904 if {$ntags >= 0} {
4905 $canv bind $t <1> [list showtag $tag 1]
4906 } elseif {$nheads >= 0} {
4907 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4910 return $xt
4913 proc xcoord {i level ln} {
4914 global canvx0 xspc1 xspc2
4916 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4917 if {$i > 0 && $i == $level} {
4918 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4919 } elseif {$i > $level} {
4920 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4922 return $x
4925 proc show_status {msg} {
4926 global canv fgcolor
4928 clear_display
4929 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4930 -tags text -fill $fgcolor
4933 # Don't change the text pane cursor if it is currently the hand cursor,
4934 # showing that we are over a sha1 ID link.
4935 proc settextcursor {c} {
4936 global ctext curtextcursor
4938 if {[$ctext cget -cursor] == $curtextcursor} {
4939 $ctext config -cursor $c
4941 set curtextcursor $c
4944 proc nowbusy {what {name {}}} {
4945 global isbusy busyname statusw
4947 if {[array names isbusy] eq {}} {
4948 . config -cursor watch
4949 settextcursor watch
4951 set isbusy($what) 1
4952 set busyname($what) $name
4953 if {$name ne {}} {
4954 $statusw conf -text $name
4958 proc notbusy {what} {
4959 global isbusy maincursor textcursor busyname statusw
4961 catch {
4962 unset isbusy($what)
4963 if {$busyname($what) ne {} &&
4964 [$statusw cget -text] eq $busyname($what)} {
4965 $statusw conf -text {}
4968 if {[array names isbusy] eq {}} {
4969 . config -cursor $maincursor
4970 settextcursor $textcursor
4974 proc findmatches {f} {
4975 global findtype findstring
4976 if {$findtype == [mc "Regexp"]} {
4977 set matches [regexp -indices -all -inline $findstring $f]
4978 } else {
4979 set fs $findstring
4980 if {$findtype == [mc "IgnCase"]} {
4981 set f [string tolower $f]
4982 set fs [string tolower $fs]
4984 set matches {}
4985 set i 0
4986 set l [string length $fs]
4987 while {[set j [string first $fs $f $i]] >= 0} {
4988 lappend matches [list $j [expr {$j+$l-1}]]
4989 set i [expr {$j + $l}]
4992 return $matches
4995 proc dofind {{dirn 1} {wrap 1}} {
4996 global findstring findstartline findcurline selectedline numcommits
4997 global gdttype filehighlight fh_serial find_dirn findallowwrap
4999 if {[info exists find_dirn]} {
5000 if {$find_dirn == $dirn} return
5001 stopfinding
5003 focus .
5004 if {$findstring eq {} || $numcommits == 0} return
5005 if {![info exists selectedline]} {
5006 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5007 } else {
5008 set findstartline $selectedline
5010 set findcurline $findstartline
5011 nowbusy finding [mc "Searching"]
5012 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5013 after cancel do_file_hl $fh_serial
5014 do_file_hl $fh_serial
5016 set find_dirn $dirn
5017 set findallowwrap $wrap
5018 run findmore
5021 proc stopfinding {} {
5022 global find_dirn findcurline fprogcoord
5024 if {[info exists find_dirn]} {
5025 unset find_dirn
5026 unset findcurline
5027 notbusy finding
5028 set fprogcoord 0
5029 adjustprogress
5033 proc findmore {} {
5034 global commitdata commitinfo numcommits findpattern findloc
5035 global findstartline findcurline findallowwrap
5036 global find_dirn gdttype fhighlights fprogcoord
5037 global curview varcorder vrownum varccommits vrowmod
5039 if {![info exists find_dirn]} {
5040 return 0
5042 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5043 set l $findcurline
5044 set moretodo 0
5045 if {$find_dirn > 0} {
5046 incr l
5047 if {$l >= $numcommits} {
5048 set l 0
5050 if {$l <= $findstartline} {
5051 set lim [expr {$findstartline + 1}]
5052 } else {
5053 set lim $numcommits
5054 set moretodo $findallowwrap
5056 } else {
5057 if {$l == 0} {
5058 set l $numcommits
5060 incr l -1
5061 if {$l >= $findstartline} {
5062 set lim [expr {$findstartline - 1}]
5063 } else {
5064 set lim -1
5065 set moretodo $findallowwrap
5068 set n [expr {($lim - $l) * $find_dirn}]
5069 if {$n > 500} {
5070 set n 500
5071 set moretodo 1
5073 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5074 update_arcrows $curview
5076 set found 0
5077 set domore 1
5078 set ai [bsearch $vrownum($curview) $l]
5079 set a [lindex $varcorder($curview) $ai]
5080 set arow [lindex $vrownum($curview) $ai]
5081 set ids [lindex $varccommits($curview,$a)]
5082 set arowend [expr {$arow + [llength $ids]}]
5083 if {$gdttype eq [mc "containing:"]} {
5084 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5085 if {$l < $arow || $l >= $arowend} {
5086 incr ai $find_dirn
5087 set a [lindex $varcorder($curview) $ai]
5088 set arow [lindex $vrownum($curview) $ai]
5089 set ids [lindex $varccommits($curview,$a)]
5090 set arowend [expr {$arow + [llength $ids]}]
5092 set id [lindex $ids [expr {$l - $arow}]]
5093 # shouldn't happen unless git log doesn't give all the commits...
5094 if {![info exists commitdata($id)] ||
5095 ![doesmatch $commitdata($id)]} {
5096 continue
5098 if {![info exists commitinfo($id)]} {
5099 getcommit $id
5101 set info $commitinfo($id)
5102 foreach f $info ty $fldtypes {
5103 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5104 [doesmatch $f]} {
5105 set found 1
5106 break
5109 if {$found} break
5111 } else {
5112 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5113 if {$l < $arow || $l >= $arowend} {
5114 incr ai $find_dirn
5115 set a [lindex $varcorder($curview) $ai]
5116 set arow [lindex $vrownum($curview) $ai]
5117 set ids [lindex $varccommits($curview,$a)]
5118 set arowend [expr {$arow + [llength $ids]}]
5120 set id [lindex $ids [expr {$l - $arow}]]
5121 if {![info exists fhighlights($id)]} {
5122 # this sets fhighlights($id) to -1
5123 askfilehighlight $l $id
5125 if {$fhighlights($id) > 0} {
5126 set found $domore
5127 break
5129 if {$fhighlights($id) < 0} {
5130 if {$domore} {
5131 set domore 0
5132 set findcurline [expr {$l - $find_dirn}]
5137 if {$found || ($domore && !$moretodo)} {
5138 unset findcurline
5139 unset find_dirn
5140 notbusy finding
5141 set fprogcoord 0
5142 adjustprogress
5143 if {$found} {
5144 findselectline $l
5145 } else {
5146 bell
5148 return 0
5150 if {!$domore} {
5151 flushhighlights
5152 } else {
5153 set findcurline [expr {$l - $find_dirn}]
5155 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5156 if {$n < 0} {
5157 incr n $numcommits
5159 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5160 adjustprogress
5161 return $domore
5164 proc findselectline {l} {
5165 global findloc commentend ctext findcurline markingmatches gdttype
5167 set markingmatches 1
5168 set findcurline $l
5169 selectline $l 1
5170 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5171 # highlight the matches in the comments
5172 set f [$ctext get 1.0 $commentend]
5173 set matches [findmatches $f]
5174 foreach match $matches {
5175 set start [lindex $match 0]
5176 set end [expr {[lindex $match 1] + 1}]
5177 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5180 drawvisible
5183 # mark the bits of a headline or author that match a find string
5184 proc markmatches {canv l str tag matches font row} {
5185 global selectedline
5187 set bbox [$canv bbox $tag]
5188 set x0 [lindex $bbox 0]
5189 set y0 [lindex $bbox 1]
5190 set y1 [lindex $bbox 3]
5191 foreach match $matches {
5192 set start [lindex $match 0]
5193 set end [lindex $match 1]
5194 if {$start > $end} continue
5195 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5196 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5197 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5198 [expr {$x0+$xlen+2}] $y1 \
5199 -outline {} -tags [list match$l matches] -fill yellow]
5200 $canv lower $t
5201 if {[info exists selectedline] && $row == $selectedline} {
5202 $canv raise $t secsel
5207 proc unmarkmatches {} {
5208 global markingmatches
5210 allcanvs delete matches
5211 set markingmatches 0
5212 stopfinding
5215 proc selcanvline {w x y} {
5216 global canv canvy0 ctext linespc
5217 global rowtextx
5218 set ymax [lindex [$canv cget -scrollregion] 3]
5219 if {$ymax == {}} return
5220 set yfrac [lindex [$canv yview] 0]
5221 set y [expr {$y + $yfrac * $ymax}]
5222 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5223 if {$l < 0} {
5224 set l 0
5226 if {$w eq $canv} {
5227 set xmax [lindex [$canv cget -scrollregion] 2]
5228 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5229 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5231 unmarkmatches
5232 selectline $l 1
5235 proc commit_descriptor {p} {
5236 global commitinfo
5237 if {![info exists commitinfo($p)]} {
5238 getcommit $p
5240 set l "..."
5241 if {[llength $commitinfo($p)] > 1} {
5242 set l [lindex $commitinfo($p) 0]
5244 return "$p ($l)\n"
5247 # append some text to the ctext widget, and make any SHA1 ID
5248 # that we know about be a clickable link.
5249 proc appendwithlinks {text tags} {
5250 global ctext linknum curview pendinglinks
5252 set start [$ctext index "end - 1c"]
5253 $ctext insert end $text $tags
5254 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5255 foreach l $links {
5256 set s [lindex $l 0]
5257 set e [lindex $l 1]
5258 set linkid [string range $text $s $e]
5259 incr e
5260 $ctext tag delete link$linknum
5261 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5262 setlink $linkid link$linknum
5263 incr linknum
5267 proc setlink {id lk} {
5268 global curview ctext pendinglinks commitinterest
5270 if {[commitinview $id $curview]} {
5271 $ctext tag conf $lk -foreground blue -underline 1
5272 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5273 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5274 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5275 } else {
5276 lappend pendinglinks($id) $lk
5277 lappend commitinterest($id) {makelink %I}
5281 proc makelink {id} {
5282 global pendinglinks
5284 if {![info exists pendinglinks($id)]} return
5285 foreach lk $pendinglinks($id) {
5286 setlink $id $lk
5288 unset pendinglinks($id)
5291 proc linkcursor {w inc} {
5292 global linkentercount curtextcursor
5294 if {[incr linkentercount $inc] > 0} {
5295 $w configure -cursor hand2
5296 } else {
5297 $w configure -cursor $curtextcursor
5298 if {$linkentercount < 0} {
5299 set linkentercount 0
5304 proc viewnextline {dir} {
5305 global canv linespc
5307 $canv delete hover
5308 set ymax [lindex [$canv cget -scrollregion] 3]
5309 set wnow [$canv yview]
5310 set wtop [expr {[lindex $wnow 0] * $ymax}]
5311 set newtop [expr {$wtop + $dir * $linespc}]
5312 if {$newtop < 0} {
5313 set newtop 0
5314 } elseif {$newtop > $ymax} {
5315 set newtop $ymax
5317 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5320 # add a list of tag or branch names at position pos
5321 # returns the number of names inserted
5322 proc appendrefs {pos ids var} {
5323 global ctext linknum curview $var maxrefs
5325 if {[catch {$ctext index $pos}]} {
5326 return 0
5328 $ctext conf -state normal
5329 $ctext delete $pos "$pos lineend"
5330 set tags {}
5331 foreach id $ids {
5332 foreach tag [set $var\($id\)] {
5333 lappend tags [list $tag $id]
5336 if {[llength $tags] > $maxrefs} {
5337 $ctext insert $pos "many ([llength $tags])"
5338 } else {
5339 set tags [lsort -index 0 -decreasing $tags]
5340 set sep {}
5341 foreach ti $tags {
5342 set id [lindex $ti 1]
5343 set lk link$linknum
5344 incr linknum
5345 $ctext tag delete $lk
5346 $ctext insert $pos $sep
5347 $ctext insert $pos [lindex $ti 0] $lk
5348 setlink $id $lk
5349 set sep ", "
5352 $ctext conf -state disabled
5353 return [llength $tags]
5356 # called when we have finished computing the nearby tags
5357 proc dispneartags {delay} {
5358 global selectedline currentid showneartags tagphase
5360 if {![info exists selectedline] || !$showneartags} return
5361 after cancel dispnexttag
5362 if {$delay} {
5363 after 200 dispnexttag
5364 set tagphase -1
5365 } else {
5366 after idle dispnexttag
5367 set tagphase 0
5371 proc dispnexttag {} {
5372 global selectedline currentid showneartags tagphase ctext
5374 if {![info exists selectedline] || !$showneartags} return
5375 switch -- $tagphase {
5377 set dtags [desctags $currentid]
5378 if {$dtags ne {}} {
5379 appendrefs precedes $dtags idtags
5383 set atags [anctags $currentid]
5384 if {$atags ne {}} {
5385 appendrefs follows $atags idtags
5389 set dheads [descheads $currentid]
5390 if {$dheads ne {}} {
5391 if {[appendrefs branch $dheads idheads] > 1
5392 && [$ctext get "branch -3c"] eq "h"} {
5393 # turn "Branch" into "Branches"
5394 $ctext conf -state normal
5395 $ctext insert "branch -2c" "es"
5396 $ctext conf -state disabled
5401 if {[incr tagphase] <= 2} {
5402 after idle dispnexttag
5406 proc make_secsel {l} {
5407 global linehtag linentag linedtag canv canv2 canv3
5409 if {![info exists linehtag($l)]} return
5410 $canv delete secsel
5411 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5412 -tags secsel -fill [$canv cget -selectbackground]]
5413 $canv lower $t
5414 $canv2 delete secsel
5415 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5416 -tags secsel -fill [$canv2 cget -selectbackground]]
5417 $canv2 lower $t
5418 $canv3 delete secsel
5419 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5420 -tags secsel -fill [$canv3 cget -selectbackground]]
5421 $canv3 lower $t
5424 proc selectline {l isnew} {
5425 global canv ctext commitinfo selectedline
5426 global canvy0 linespc parents children curview
5427 global currentid sha1entry
5428 global commentend idtags linknum
5429 global mergemax numcommits pending_select
5430 global cmitmode showneartags allcommits
5431 global targetrow targetid
5433 catch {unset pending_select}
5434 $canv delete hover
5435 normalline
5436 unsel_reflist
5437 stopfinding
5438 if {$l < 0 || $l >= $numcommits} return
5439 set id [commitonrow $l]
5440 set targetid $id
5441 set targetrow $l
5443 set y [expr {$canvy0 + $l * $linespc}]
5444 set ymax [lindex [$canv cget -scrollregion] 3]
5445 set ytop [expr {$y - $linespc - 1}]
5446 set ybot [expr {$y + $linespc + 1}]
5447 set wnow [$canv yview]
5448 set wtop [expr {[lindex $wnow 0] * $ymax}]
5449 set wbot [expr {[lindex $wnow 1] * $ymax}]
5450 set wh [expr {$wbot - $wtop}]
5451 set newtop $wtop
5452 if {$ytop < $wtop} {
5453 if {$ybot < $wtop} {
5454 set newtop [expr {$y - $wh / 2.0}]
5455 } else {
5456 set newtop $ytop
5457 if {$newtop > $wtop - $linespc} {
5458 set newtop [expr {$wtop - $linespc}]
5461 } elseif {$ybot > $wbot} {
5462 if {$ytop > $wbot} {
5463 set newtop [expr {$y - $wh / 2.0}]
5464 } else {
5465 set newtop [expr {$ybot - $wh}]
5466 if {$newtop < $wtop + $linespc} {
5467 set newtop [expr {$wtop + $linespc}]
5471 if {$newtop != $wtop} {
5472 if {$newtop < 0} {
5473 set newtop 0
5475 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5476 drawvisible
5479 make_secsel $l
5481 if {$isnew} {
5482 addtohistory [list selbyid $id]
5485 set selectedline $l
5486 set currentid $id
5487 $sha1entry delete 0 end
5488 $sha1entry insert 0 $id
5489 $sha1entry selection from 0
5490 $sha1entry selection to end
5491 rhighlight_sel $id
5493 $ctext conf -state normal
5494 clear_ctext
5495 set linknum 0
5496 set info $commitinfo($id)
5497 set date [formatdate [lindex $info 2]]
5498 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5499 set date [formatdate [lindex $info 4]]
5500 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5501 if {[info exists idtags($id)]} {
5502 $ctext insert end [mc "Tags:"]
5503 foreach tag $idtags($id) {
5504 $ctext insert end " $tag"
5506 $ctext insert end "\n"
5509 set headers {}
5510 set olds $parents($curview,$id)
5511 if {[llength $olds] > 1} {
5512 set np 0
5513 foreach p $olds {
5514 if {$np >= $mergemax} {
5515 set tag mmax
5516 } else {
5517 set tag m$np
5519 $ctext insert end "[mc "Parent"]: " $tag
5520 appendwithlinks [commit_descriptor $p] {}
5521 incr np
5523 } else {
5524 foreach p $olds {
5525 append headers "[mc "Parent"]: [commit_descriptor $p]"
5529 foreach c $children($curview,$id) {
5530 append headers "[mc "Child"]: [commit_descriptor $c]"
5533 # make anything that looks like a SHA1 ID be a clickable link
5534 appendwithlinks $headers {}
5535 if {$showneartags} {
5536 if {![info exists allcommits]} {
5537 getallcommits
5539 $ctext insert end "[mc "Branch"]: "
5540 $ctext mark set branch "end -1c"
5541 $ctext mark gravity branch left
5542 $ctext insert end "\n[mc "Follows"]: "
5543 $ctext mark set follows "end -1c"
5544 $ctext mark gravity follows left
5545 $ctext insert end "\n[mc "Precedes"]: "
5546 $ctext mark set precedes "end -1c"
5547 $ctext mark gravity precedes left
5548 $ctext insert end "\n"
5549 dispneartags 1
5551 $ctext insert end "\n"
5552 set comment [lindex $info 5]
5553 if {[string first "\r" $comment] >= 0} {
5554 set comment [string map {"\r" "\n "} $comment]
5556 appendwithlinks $comment {comment}
5558 $ctext tag remove found 1.0 end
5559 $ctext conf -state disabled
5560 set commentend [$ctext index "end - 1c"]
5562 init_flist [mc "Comments"]
5563 if {$cmitmode eq "tree"} {
5564 gettree $id
5565 } elseif {[llength $olds] <= 1} {
5566 startdiff $id
5567 } else {
5568 mergediff $id
5572 proc selfirstline {} {
5573 unmarkmatches
5574 selectline 0 1
5577 proc sellastline {} {
5578 global numcommits
5579 unmarkmatches
5580 set l [expr {$numcommits - 1}]
5581 selectline $l 1
5584 proc selnextline {dir} {
5585 global selectedline
5586 focus .
5587 if {![info exists selectedline]} return
5588 set l [expr {$selectedline + $dir}]
5589 unmarkmatches
5590 selectline $l 1
5593 proc selnextpage {dir} {
5594 global canv linespc selectedline numcommits
5596 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5597 if {$lpp < 1} {
5598 set lpp 1
5600 allcanvs yview scroll [expr {$dir * $lpp}] units
5601 drawvisible
5602 if {![info exists selectedline]} return
5603 set l [expr {$selectedline + $dir * $lpp}]
5604 if {$l < 0} {
5605 set l 0
5606 } elseif {$l >= $numcommits} {
5607 set l [expr $numcommits - 1]
5609 unmarkmatches
5610 selectline $l 1
5613 proc unselectline {} {
5614 global selectedline currentid
5616 catch {unset selectedline}
5617 catch {unset currentid}
5618 allcanvs delete secsel
5619 rhighlight_none
5622 proc reselectline {} {
5623 global selectedline
5625 if {[info exists selectedline]} {
5626 selectline $selectedline 0
5630 proc addtohistory {cmd} {
5631 global history historyindex curview
5633 set elt [list $curview $cmd]
5634 if {$historyindex > 0
5635 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5636 return
5639 if {$historyindex < [llength $history]} {
5640 set history [lreplace $history $historyindex end $elt]
5641 } else {
5642 lappend history $elt
5644 incr historyindex
5645 if {$historyindex > 1} {
5646 .tf.bar.leftbut conf -state normal
5647 } else {
5648 .tf.bar.leftbut conf -state disabled
5650 .tf.bar.rightbut conf -state disabled
5653 proc godo {elt} {
5654 global curview
5656 set view [lindex $elt 0]
5657 set cmd [lindex $elt 1]
5658 if {$curview != $view} {
5659 showview $view
5661 eval $cmd
5664 proc goback {} {
5665 global history historyindex
5666 focus .
5668 if {$historyindex > 1} {
5669 incr historyindex -1
5670 godo [lindex $history [expr {$historyindex - 1}]]
5671 .tf.bar.rightbut conf -state normal
5673 if {$historyindex <= 1} {
5674 .tf.bar.leftbut conf -state disabled
5678 proc goforw {} {
5679 global history historyindex
5680 focus .
5682 if {$historyindex < [llength $history]} {
5683 set cmd [lindex $history $historyindex]
5684 incr historyindex
5685 godo $cmd
5686 .tf.bar.leftbut conf -state normal
5688 if {$historyindex >= [llength $history]} {
5689 .tf.bar.rightbut conf -state disabled
5693 proc gettree {id} {
5694 global treefilelist treeidlist diffids diffmergeid treepending
5695 global nullid nullid2
5697 set diffids $id
5698 catch {unset diffmergeid}
5699 if {![info exists treefilelist($id)]} {
5700 if {![info exists treepending]} {
5701 if {$id eq $nullid} {
5702 set cmd [list | git ls-files]
5703 } elseif {$id eq $nullid2} {
5704 set cmd [list | git ls-files --stage -t]
5705 } else {
5706 set cmd [list | git ls-tree -r $id]
5708 if {[catch {set gtf [open $cmd r]}]} {
5709 return
5711 set treepending $id
5712 set treefilelist($id) {}
5713 set treeidlist($id) {}
5714 fconfigure $gtf -blocking 0
5715 filerun $gtf [list gettreeline $gtf $id]
5717 } else {
5718 setfilelist $id
5722 proc gettreeline {gtf id} {
5723 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5725 set nl 0
5726 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5727 if {$diffids eq $nullid} {
5728 set fname $line
5729 } else {
5730 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5731 set i [string first "\t" $line]
5732 if {$i < 0} continue
5733 set sha1 [lindex $line 2]
5734 set fname [string range $line [expr {$i+1}] end]
5735 if {[string index $fname 0] eq "\""} {
5736 set fname [lindex $fname 0]
5738 lappend treeidlist($id) $sha1
5740 lappend treefilelist($id) $fname
5742 if {![eof $gtf]} {
5743 return [expr {$nl >= 1000? 2: 1}]
5745 close $gtf
5746 unset treepending
5747 if {$cmitmode ne "tree"} {
5748 if {![info exists diffmergeid]} {
5749 gettreediffs $diffids
5751 } elseif {$id ne $diffids} {
5752 gettree $diffids
5753 } else {
5754 setfilelist $id
5756 return 0
5759 proc showfile {f} {
5760 global treefilelist treeidlist diffids nullid nullid2
5761 global ctext commentend
5763 set i [lsearch -exact $treefilelist($diffids) $f]
5764 if {$i < 0} {
5765 puts "oops, $f not in list for id $diffids"
5766 return
5768 if {$diffids eq $nullid} {
5769 if {[catch {set bf [open $f r]} err]} {
5770 puts "oops, can't read $f: $err"
5771 return
5773 } else {
5774 set blob [lindex $treeidlist($diffids) $i]
5775 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5776 puts "oops, error reading blob $blob: $err"
5777 return
5780 fconfigure $bf -blocking 0
5781 filerun $bf [list getblobline $bf $diffids]
5782 $ctext config -state normal
5783 clear_ctext $commentend
5784 $ctext insert end "\n"
5785 $ctext insert end "$f\n" filesep
5786 $ctext config -state disabled
5787 $ctext yview $commentend
5788 settabs 0
5791 proc getblobline {bf id} {
5792 global diffids cmitmode ctext
5794 if {$id ne $diffids || $cmitmode ne "tree"} {
5795 catch {close $bf}
5796 return 0
5798 $ctext config -state normal
5799 set nl 0
5800 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5801 $ctext insert end "$line\n"
5803 if {[eof $bf]} {
5804 # delete last newline
5805 $ctext delete "end - 2c" "end - 1c"
5806 close $bf
5807 return 0
5809 $ctext config -state disabled
5810 return [expr {$nl >= 1000? 2: 1}]
5813 proc mergediff {id} {
5814 global diffmergeid mdifffd
5815 global diffids
5816 global parents
5817 global diffcontext
5818 global limitdiffs viewfiles curview
5820 set diffmergeid $id
5821 set diffids $id
5822 # this doesn't seem to actually affect anything...
5823 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
5824 if {$limitdiffs && $viewfiles($curview) ne {}} {
5825 set cmd [concat $cmd -- $viewfiles($curview)]
5827 if {[catch {set mdf [open $cmd r]} err]} {
5828 error_popup "[mc "Error getting merge diffs:"] $err"
5829 return
5831 fconfigure $mdf -blocking 0
5832 set mdifffd($id) $mdf
5833 set np [llength $parents($curview,$id)]
5834 settabs $np
5835 filerun $mdf [list getmergediffline $mdf $id $np]
5838 proc getmergediffline {mdf id np} {
5839 global diffmergeid ctext cflist mergemax
5840 global difffilestart mdifffd
5842 $ctext conf -state normal
5843 set nr 0
5844 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5845 if {![info exists diffmergeid] || $id != $diffmergeid
5846 || $mdf != $mdifffd($id)} {
5847 close $mdf
5848 return 0
5850 if {[regexp {^diff --cc (.*)} $line match fname]} {
5851 # start of a new file
5852 $ctext insert end "\n"
5853 set here [$ctext index "end - 1c"]
5854 lappend difffilestart $here
5855 add_flist [list $fname]
5856 set l [expr {(78 - [string length $fname]) / 2}]
5857 set pad [string range "----------------------------------------" 1 $l]
5858 $ctext insert end "$pad $fname $pad\n" filesep
5859 } elseif {[regexp {^@@} $line]} {
5860 $ctext insert end "$line\n" hunksep
5861 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5862 # do nothing
5863 } else {
5864 # parse the prefix - one ' ', '-' or '+' for each parent
5865 set spaces {}
5866 set minuses {}
5867 set pluses {}
5868 set isbad 0
5869 for {set j 0} {$j < $np} {incr j} {
5870 set c [string range $line $j $j]
5871 if {$c == " "} {
5872 lappend spaces $j
5873 } elseif {$c == "-"} {
5874 lappend minuses $j
5875 } elseif {$c == "+"} {
5876 lappend pluses $j
5877 } else {
5878 set isbad 1
5879 break
5882 set tags {}
5883 set num {}
5884 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5885 # line doesn't appear in result, parents in $minuses have the line
5886 set num [lindex $minuses 0]
5887 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5888 # line appears in result, parents in $pluses don't have the line
5889 lappend tags mresult
5890 set num [lindex $spaces 0]
5892 if {$num ne {}} {
5893 if {$num >= $mergemax} {
5894 set num "max"
5896 lappend tags m$num
5898 $ctext insert end "$line\n" $tags
5901 $ctext conf -state disabled
5902 if {[eof $mdf]} {
5903 close $mdf
5904 return 0
5906 return [expr {$nr >= 1000? 2: 1}]
5909 proc startdiff {ids} {
5910 global treediffs diffids treepending diffmergeid nullid nullid2
5912 settabs 1
5913 set diffids $ids
5914 catch {unset diffmergeid}
5915 if {![info exists treediffs($ids)] ||
5916 [lsearch -exact $ids $nullid] >= 0 ||
5917 [lsearch -exact $ids $nullid2] >= 0} {
5918 if {![info exists treepending]} {
5919 gettreediffs $ids
5921 } else {
5922 addtocflist $ids
5926 proc path_filter {filter name} {
5927 foreach p $filter {
5928 set l [string length $p]
5929 if {[string index $p end] eq "/"} {
5930 if {[string compare -length $l $p $name] == 0} {
5931 return 1
5933 } else {
5934 if {[string compare -length $l $p $name] == 0 &&
5935 ([string length $name] == $l ||
5936 [string index $name $l] eq "/")} {
5937 return 1
5941 return 0
5944 proc addtocflist {ids} {
5945 global treediffs
5947 add_flist $treediffs($ids)
5948 getblobdiffs $ids
5951 proc diffcmd {ids flags} {
5952 global nullid nullid2
5954 set i [lsearch -exact $ids $nullid]
5955 set j [lsearch -exact $ids $nullid2]
5956 if {$i >= 0} {
5957 if {[llength $ids] > 1 && $j < 0} {
5958 # comparing working directory with some specific revision
5959 set cmd [concat | git diff-index $flags]
5960 if {$i == 0} {
5961 lappend cmd -R [lindex $ids 1]
5962 } else {
5963 lappend cmd [lindex $ids 0]
5965 } else {
5966 # comparing working directory with index
5967 set cmd [concat | git diff-files $flags]
5968 if {$j == 1} {
5969 lappend cmd -R
5972 } elseif {$j >= 0} {
5973 set cmd [concat | git diff-index --cached $flags]
5974 if {[llength $ids] > 1} {
5975 # comparing index with specific revision
5976 if {$i == 0} {
5977 lappend cmd -R [lindex $ids 1]
5978 } else {
5979 lappend cmd [lindex $ids 0]
5981 } else {
5982 # comparing index with HEAD
5983 lappend cmd HEAD
5985 } else {
5986 set cmd [concat | git diff-tree -r $flags $ids]
5988 return $cmd
5991 proc gettreediffs {ids} {
5992 global treediff treepending
5994 set treepending $ids
5995 set treediff {}
5996 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5997 fconfigure $gdtf -blocking 0
5998 filerun $gdtf [list gettreediffline $gdtf $ids]
6001 proc gettreediffline {gdtf ids} {
6002 global treediff treediffs treepending diffids diffmergeid
6003 global cmitmode viewfiles curview limitdiffs
6005 set nr 0
6006 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
6007 set i [string first "\t" $line]
6008 if {$i >= 0} {
6009 set file [string range $line [expr {$i+1}] end]
6010 if {[string index $file 0] eq "\""} {
6011 set file [lindex $file 0]
6013 lappend treediff $file
6016 if {![eof $gdtf]} {
6017 return [expr {$nr >= 1000? 2: 1}]
6019 close $gdtf
6020 if {$limitdiffs && $viewfiles($curview) ne {}} {
6021 set flist {}
6022 foreach f $treediff {
6023 if {[path_filter $viewfiles($curview) $f]} {
6024 lappend flist $f
6027 set treediffs($ids) $flist
6028 } else {
6029 set treediffs($ids) $treediff
6031 unset treepending
6032 if {$cmitmode eq "tree"} {
6033 gettree $diffids
6034 } elseif {$ids != $diffids} {
6035 if {![info exists diffmergeid]} {
6036 gettreediffs $diffids
6038 } else {
6039 addtocflist $ids
6041 return 0
6044 # empty string or positive integer
6045 proc diffcontextvalidate {v} {
6046 return [regexp {^(|[1-9][0-9]*)$} $v]
6049 proc diffcontextchange {n1 n2 op} {
6050 global diffcontextstring diffcontext
6052 if {[string is integer -strict $diffcontextstring]} {
6053 if {$diffcontextstring > 0} {
6054 set diffcontext $diffcontextstring
6055 reselectline
6060 proc changeignorespace {} {
6061 reselectline
6064 proc getblobdiffs {ids} {
6065 global blobdifffd diffids env
6066 global diffinhdr treediffs
6067 global diffcontext
6068 global ignorespace
6069 global limitdiffs viewfiles curview
6071 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6072 if {$ignorespace} {
6073 append cmd " -w"
6075 if {$limitdiffs && $viewfiles($curview) ne {}} {
6076 set cmd [concat $cmd -- $viewfiles($curview)]
6078 if {[catch {set bdf [open $cmd r]} err]} {
6079 puts "error getting diffs: $err"
6080 return
6082 set diffinhdr 0
6083 fconfigure $bdf -blocking 0
6084 set blobdifffd($ids) $bdf
6085 filerun $bdf [list getblobdiffline $bdf $diffids]
6088 proc setinlist {var i val} {
6089 global $var
6091 while {[llength [set $var]] < $i} {
6092 lappend $var {}
6094 if {[llength [set $var]] == $i} {
6095 lappend $var $val
6096 } else {
6097 lset $var $i $val
6101 proc makediffhdr {fname ids} {
6102 global ctext curdiffstart treediffs
6104 set i [lsearch -exact $treediffs($ids) $fname]
6105 if {$i >= 0} {
6106 setinlist difffilestart $i $curdiffstart
6108 set l [expr {(78 - [string length $fname]) / 2}]
6109 set pad [string range "----------------------------------------" 1 $l]
6110 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6113 proc getblobdiffline {bdf ids} {
6114 global diffids blobdifffd ctext curdiffstart
6115 global diffnexthead diffnextnote difffilestart
6116 global diffinhdr treediffs
6118 set nr 0
6119 $ctext conf -state normal
6120 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6121 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6122 close $bdf
6123 return 0
6125 if {![string compare -length 11 "diff --git " $line]} {
6126 # trim off "diff --git "
6127 set line [string range $line 11 end]
6128 set diffinhdr 1
6129 # start of a new file
6130 $ctext insert end "\n"
6131 set curdiffstart [$ctext index "end - 1c"]
6132 $ctext insert end "\n" filesep
6133 # If the name hasn't changed the length will be odd,
6134 # the middle char will be a space, and the two bits either
6135 # side will be a/name and b/name, or "a/name" and "b/name".
6136 # If the name has changed we'll get "rename from" and
6137 # "rename to" or "copy from" and "copy to" lines following this,
6138 # and we'll use them to get the filenames.
6139 # This complexity is necessary because spaces in the filename(s)
6140 # don't get escaped.
6141 set l [string length $line]
6142 set i [expr {$l / 2}]
6143 if {!(($l & 1) && [string index $line $i] eq " " &&
6144 [string range $line 2 [expr {$i - 1}]] eq \
6145 [string range $line [expr {$i + 3}] end])} {
6146 continue
6148 # unescape if quoted and chop off the a/ from the front
6149 if {[string index $line 0] eq "\""} {
6150 set fname [string range [lindex $line 0] 2 end]
6151 } else {
6152 set fname [string range $line 2 [expr {$i - 1}]]
6154 makediffhdr $fname $ids
6156 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6157 $line match f1l f1c f2l f2c rest]} {
6158 $ctext insert end "$line\n" hunksep
6159 set diffinhdr 0
6161 } elseif {$diffinhdr} {
6162 if {![string compare -length 12 "rename from " $line]} {
6163 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6164 if {[string index $fname 0] eq "\""} {
6165 set fname [lindex $fname 0]
6167 set i [lsearch -exact $treediffs($ids) $fname]
6168 if {$i >= 0} {
6169 setinlist difffilestart $i $curdiffstart
6171 } elseif {![string compare -length 10 $line "rename to "] ||
6172 ![string compare -length 8 $line "copy to "]} {
6173 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6174 if {[string index $fname 0] eq "\""} {
6175 set fname [lindex $fname 0]
6177 makediffhdr $fname $ids
6178 } elseif {[string compare -length 3 $line "---"] == 0} {
6179 # do nothing
6180 continue
6181 } elseif {[string compare -length 3 $line "+++"] == 0} {
6182 set diffinhdr 0
6183 continue
6185 $ctext insert end "$line\n" filesep
6187 } else {
6188 set x [string range $line 0 0]
6189 if {$x == "-" || $x == "+"} {
6190 set tag [expr {$x == "+"}]
6191 $ctext insert end "$line\n" d$tag
6192 } elseif {$x == " "} {
6193 $ctext insert end "$line\n"
6194 } else {
6195 # "\ No newline at end of file",
6196 # or something else we don't recognize
6197 $ctext insert end "$line\n" hunksep
6201 $ctext conf -state disabled
6202 if {[eof $bdf]} {
6203 close $bdf
6204 return 0
6206 return [expr {$nr >= 1000? 2: 1}]
6209 proc changediffdisp {} {
6210 global ctext diffelide
6212 $ctext tag conf d0 -elide [lindex $diffelide 0]
6213 $ctext tag conf d1 -elide [lindex $diffelide 1]
6216 proc prevfile {} {
6217 global difffilestart ctext
6218 set prev [lindex $difffilestart 0]
6219 set here [$ctext index @0,0]
6220 foreach loc $difffilestart {
6221 if {[$ctext compare $loc >= $here]} {
6222 $ctext yview $prev
6223 return
6225 set prev $loc
6227 $ctext yview $prev
6230 proc nextfile {} {
6231 global difffilestart ctext
6232 set here [$ctext index @0,0]
6233 foreach loc $difffilestart {
6234 if {[$ctext compare $loc > $here]} {
6235 $ctext yview $loc
6236 return
6241 proc clear_ctext {{first 1.0}} {
6242 global ctext smarktop smarkbot
6243 global pendinglinks
6245 set l [lindex [split $first .] 0]
6246 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6247 set smarktop $l
6249 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6250 set smarkbot $l
6252 $ctext delete $first end
6253 if {$first eq "1.0"} {
6254 catch {unset pendinglinks}
6258 proc settabs {{firstab {}}} {
6259 global firsttabstop tabstop ctext have_tk85
6261 if {$firstab ne {} && $have_tk85} {
6262 set firsttabstop $firstab
6264 set w [font measure textfont "0"]
6265 if {$firsttabstop != 0} {
6266 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6267 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6268 } elseif {$have_tk85 || $tabstop != 8} {
6269 $ctext conf -tabs [expr {$tabstop * $w}]
6270 } else {
6271 $ctext conf -tabs {}
6275 proc incrsearch {name ix op} {
6276 global ctext searchstring searchdirn
6278 $ctext tag remove found 1.0 end
6279 if {[catch {$ctext index anchor}]} {
6280 # no anchor set, use start of selection, or of visible area
6281 set sel [$ctext tag ranges sel]
6282 if {$sel ne {}} {
6283 $ctext mark set anchor [lindex $sel 0]
6284 } elseif {$searchdirn eq "-forwards"} {
6285 $ctext mark set anchor @0,0
6286 } else {
6287 $ctext mark set anchor @0,[winfo height $ctext]
6290 if {$searchstring ne {}} {
6291 set here [$ctext search $searchdirn -- $searchstring anchor]
6292 if {$here ne {}} {
6293 $ctext see $here
6295 searchmarkvisible 1
6299 proc dosearch {} {
6300 global sstring ctext searchstring searchdirn
6302 focus $sstring
6303 $sstring icursor end
6304 set searchdirn -forwards
6305 if {$searchstring ne {}} {
6306 set sel [$ctext tag ranges sel]
6307 if {$sel ne {}} {
6308 set start "[lindex $sel 0] + 1c"
6309 } elseif {[catch {set start [$ctext index anchor]}]} {
6310 set start "@0,0"
6312 set match [$ctext search -count mlen -- $searchstring $start]
6313 $ctext tag remove sel 1.0 end
6314 if {$match eq {}} {
6315 bell
6316 return
6318 $ctext see $match
6319 set mend "$match + $mlen c"
6320 $ctext tag add sel $match $mend
6321 $ctext mark unset anchor
6325 proc dosearchback {} {
6326 global sstring ctext searchstring searchdirn
6328 focus $sstring
6329 $sstring icursor end
6330 set searchdirn -backwards
6331 if {$searchstring ne {}} {
6332 set sel [$ctext tag ranges sel]
6333 if {$sel ne {}} {
6334 set start [lindex $sel 0]
6335 } elseif {[catch {set start [$ctext index anchor]}]} {
6336 set start @0,[winfo height $ctext]
6338 set match [$ctext search -backwards -count ml -- $searchstring $start]
6339 $ctext tag remove sel 1.0 end
6340 if {$match eq {}} {
6341 bell
6342 return
6344 $ctext see $match
6345 set mend "$match + $ml c"
6346 $ctext tag add sel $match $mend
6347 $ctext mark unset anchor
6351 proc searchmark {first last} {
6352 global ctext searchstring
6354 set mend $first.0
6355 while {1} {
6356 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6357 if {$match eq {}} break
6358 set mend "$match + $mlen c"
6359 $ctext tag add found $match $mend
6363 proc searchmarkvisible {doall} {
6364 global ctext smarktop smarkbot
6366 set topline [lindex [split [$ctext index @0,0] .] 0]
6367 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6368 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6369 # no overlap with previous
6370 searchmark $topline $botline
6371 set smarktop $topline
6372 set smarkbot $botline
6373 } else {
6374 if {$topline < $smarktop} {
6375 searchmark $topline [expr {$smarktop-1}]
6376 set smarktop $topline
6378 if {$botline > $smarkbot} {
6379 searchmark [expr {$smarkbot+1}] $botline
6380 set smarkbot $botline
6385 proc scrolltext {f0 f1} {
6386 global searchstring
6388 .bleft.sb set $f0 $f1
6389 if {$searchstring ne {}} {
6390 searchmarkvisible 0
6394 proc setcoords {} {
6395 global linespc charspc canvx0 canvy0
6396 global xspc1 xspc2 lthickness
6398 set linespc [font metrics mainfont -linespace]
6399 set charspc [font measure mainfont "m"]
6400 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6401 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6402 set lthickness [expr {int($linespc / 9) + 1}]
6403 set xspc1(0) $linespc
6404 set xspc2 $linespc
6407 proc redisplay {} {
6408 global canv
6409 global selectedline
6411 set ymax [lindex [$canv cget -scrollregion] 3]
6412 if {$ymax eq {} || $ymax == 0} return
6413 set span [$canv yview]
6414 clear_display
6415 setcanvscroll
6416 allcanvs yview moveto [lindex $span 0]
6417 drawvisible
6418 if {[info exists selectedline]} {
6419 selectline $selectedline 0
6420 allcanvs yview moveto [lindex $span 0]
6424 proc parsefont {f n} {
6425 global fontattr
6427 set fontattr($f,family) [lindex $n 0]
6428 set s [lindex $n 1]
6429 if {$s eq {} || $s == 0} {
6430 set s 10
6431 } elseif {$s < 0} {
6432 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6434 set fontattr($f,size) $s
6435 set fontattr($f,weight) normal
6436 set fontattr($f,slant) roman
6437 foreach style [lrange $n 2 end] {
6438 switch -- $style {
6439 "normal" -
6440 "bold" {set fontattr($f,weight) $style}
6441 "roman" -
6442 "italic" {set fontattr($f,slant) $style}
6447 proc fontflags {f {isbold 0}} {
6448 global fontattr
6450 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6451 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6452 -slant $fontattr($f,slant)]
6455 proc fontname {f} {
6456 global fontattr
6458 set n [list $fontattr($f,family) $fontattr($f,size)]
6459 if {$fontattr($f,weight) eq "bold"} {
6460 lappend n "bold"
6462 if {$fontattr($f,slant) eq "italic"} {
6463 lappend n "italic"
6465 return $n
6468 proc incrfont {inc} {
6469 global mainfont textfont ctext canv cflist showrefstop
6470 global stopped entries fontattr
6472 unmarkmatches
6473 set s $fontattr(mainfont,size)
6474 incr s $inc
6475 if {$s < 1} {
6476 set s 1
6478 set fontattr(mainfont,size) $s
6479 font config mainfont -size $s
6480 font config mainfontbold -size $s
6481 set mainfont [fontname mainfont]
6482 set s $fontattr(textfont,size)
6483 incr s $inc
6484 if {$s < 1} {
6485 set s 1
6487 set fontattr(textfont,size) $s
6488 font config textfont -size $s
6489 font config textfontbold -size $s
6490 set textfont [fontname textfont]
6491 setcoords
6492 settabs
6493 redisplay
6496 proc clearsha1 {} {
6497 global sha1entry sha1string
6498 if {[string length $sha1string] == 40} {
6499 $sha1entry delete 0 end
6503 proc sha1change {n1 n2 op} {
6504 global sha1string currentid sha1but
6505 if {$sha1string == {}
6506 || ([info exists currentid] && $sha1string == $currentid)} {
6507 set state disabled
6508 } else {
6509 set state normal
6511 if {[$sha1but cget -state] == $state} return
6512 if {$state == "normal"} {
6513 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6514 } else {
6515 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6519 proc gotocommit {} {
6520 global sha1string tagids headids curview varcid
6522 if {$sha1string == {}
6523 || ([info exists currentid] && $sha1string == $currentid)} return
6524 if {[info exists tagids($sha1string)]} {
6525 set id $tagids($sha1string)
6526 } elseif {[info exists headids($sha1string)]} {
6527 set id $headids($sha1string)
6528 } else {
6529 set id [string tolower $sha1string]
6530 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6531 set matches [array names varcid "$curview,$id*"]
6532 if {$matches ne {}} {
6533 if {[llength $matches] > 1} {
6534 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6535 return
6537 set id [lindex [split [lindex $matches 0] ","] 1]
6541 if {[commitinview $id $curview]} {
6542 selectline [rowofcommit $id] 1
6543 return
6545 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6546 set msg [mc "SHA1 id %s is not known" $sha1string]
6547 } else {
6548 set msg [mc "Tag/Head %s is not known" $sha1string]
6550 error_popup $msg
6553 proc lineenter {x y id} {
6554 global hoverx hovery hoverid hovertimer
6555 global commitinfo canv
6557 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6558 set hoverx $x
6559 set hovery $y
6560 set hoverid $id
6561 if {[info exists hovertimer]} {
6562 after cancel $hovertimer
6564 set hovertimer [after 500 linehover]
6565 $canv delete hover
6568 proc linemotion {x y id} {
6569 global hoverx hovery hoverid hovertimer
6571 if {[info exists hoverid] && $id == $hoverid} {
6572 set hoverx $x
6573 set hovery $y
6574 if {[info exists hovertimer]} {
6575 after cancel $hovertimer
6577 set hovertimer [after 500 linehover]
6581 proc lineleave {id} {
6582 global hoverid hovertimer canv
6584 if {[info exists hoverid] && $id == $hoverid} {
6585 $canv delete hover
6586 if {[info exists hovertimer]} {
6587 after cancel $hovertimer
6588 unset hovertimer
6590 unset hoverid
6594 proc linehover {} {
6595 global hoverx hovery hoverid hovertimer
6596 global canv linespc lthickness
6597 global commitinfo
6599 set text [lindex $commitinfo($hoverid) 0]
6600 set ymax [lindex [$canv cget -scrollregion] 3]
6601 if {$ymax == {}} return
6602 set yfrac [lindex [$canv yview] 0]
6603 set x [expr {$hoverx + 2 * $linespc}]
6604 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6605 set x0 [expr {$x - 2 * $lthickness}]
6606 set y0 [expr {$y - 2 * $lthickness}]
6607 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6608 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6609 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6610 -fill \#ffff80 -outline black -width 1 -tags hover]
6611 $canv raise $t
6612 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6613 -font mainfont]
6614 $canv raise $t
6617 proc clickisonarrow {id y} {
6618 global lthickness
6620 set ranges [rowranges $id]
6621 set thresh [expr {2 * $lthickness + 6}]
6622 set n [expr {[llength $ranges] - 1}]
6623 for {set i 1} {$i < $n} {incr i} {
6624 set row [lindex $ranges $i]
6625 if {abs([yc $row] - $y) < $thresh} {
6626 return $i
6629 return {}
6632 proc arrowjump {id n y} {
6633 global canv
6635 # 1 <-> 2, 3 <-> 4, etc...
6636 set n [expr {(($n - 1) ^ 1) + 1}]
6637 set row [lindex [rowranges $id] $n]
6638 set yt [yc $row]
6639 set ymax [lindex [$canv cget -scrollregion] 3]
6640 if {$ymax eq {} || $ymax <= 0} return
6641 set view [$canv yview]
6642 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6643 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6644 if {$yfrac < 0} {
6645 set yfrac 0
6647 allcanvs yview moveto $yfrac
6650 proc lineclick {x y id isnew} {
6651 global ctext commitinfo children canv thickerline curview
6653 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6654 unmarkmatches
6655 unselectline
6656 normalline
6657 $canv delete hover
6658 # draw this line thicker than normal
6659 set thickerline $id
6660 drawlines $id
6661 if {$isnew} {
6662 set ymax [lindex [$canv cget -scrollregion] 3]
6663 if {$ymax eq {}} return
6664 set yfrac [lindex [$canv yview] 0]
6665 set y [expr {$y + $yfrac * $ymax}]
6667 set dirn [clickisonarrow $id $y]
6668 if {$dirn ne {}} {
6669 arrowjump $id $dirn $y
6670 return
6673 if {$isnew} {
6674 addtohistory [list lineclick $x $y $id 0]
6676 # fill the details pane with info about this line
6677 $ctext conf -state normal
6678 clear_ctext
6679 settabs 0
6680 $ctext insert end "[mc "Parent"]:\t"
6681 $ctext insert end $id link0
6682 setlink $id link0
6683 set info $commitinfo($id)
6684 $ctext insert end "\n\t[lindex $info 0]\n"
6685 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
6686 set date [formatdate [lindex $info 2]]
6687 $ctext insert end "\t[mc "Date"]:\t$date\n"
6688 set kids $children($curview,$id)
6689 if {$kids ne {}} {
6690 $ctext insert end "\n[mc "Children"]:"
6691 set i 0
6692 foreach child $kids {
6693 incr i
6694 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6695 set info $commitinfo($child)
6696 $ctext insert end "\n\t"
6697 $ctext insert end $child link$i
6698 setlink $child link$i
6699 $ctext insert end "\n\t[lindex $info 0]"
6700 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
6701 set date [formatdate [lindex $info 2]]
6702 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
6705 $ctext conf -state disabled
6706 init_flist {}
6709 proc normalline {} {
6710 global thickerline
6711 if {[info exists thickerline]} {
6712 set id $thickerline
6713 unset thickerline
6714 drawlines $id
6718 proc selbyid {id} {
6719 global curview
6720 if {[commitinview $id $curview]} {
6721 selectline [rowofcommit $id] 1
6725 proc mstime {} {
6726 global startmstime
6727 if {![info exists startmstime]} {
6728 set startmstime [clock clicks -milliseconds]
6730 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6733 proc rowmenu {x y id} {
6734 global rowctxmenu selectedline rowmenuid curview
6735 global nullid nullid2 fakerowmenu mainhead
6737 stopfinding
6738 set rowmenuid $id
6739 if {![info exists selectedline]
6740 || [rowofcommit $id] eq $selectedline} {
6741 set state disabled
6742 } else {
6743 set state normal
6745 if {$id ne $nullid && $id ne $nullid2} {
6746 set menu $rowctxmenu
6747 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6748 } else {
6749 set menu $fakerowmenu
6751 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6752 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6753 $menu entryconfigure [mc "Make patch"] -state $state
6754 tk_popup $menu $x $y
6757 proc diffvssel {dirn} {
6758 global rowmenuid selectedline
6760 if {![info exists selectedline]} return
6761 if {$dirn} {
6762 set oldid [commitonrow $selectedline]
6763 set newid $rowmenuid
6764 } else {
6765 set oldid $rowmenuid
6766 set newid [commitonrow $selectedline]
6768 addtohistory [list doseldiff $oldid $newid]
6769 doseldiff $oldid $newid
6772 proc doseldiff {oldid newid} {
6773 global ctext
6774 global commitinfo
6776 $ctext conf -state normal
6777 clear_ctext
6778 init_flist [mc "Top"]
6779 $ctext insert end "[mc "From"] "
6780 $ctext insert end $oldid link0
6781 setlink $oldid link0
6782 $ctext insert end "\n "
6783 $ctext insert end [lindex $commitinfo($oldid) 0]
6784 $ctext insert end "\n\n[mc "To"] "
6785 $ctext insert end $newid link1
6786 setlink $newid link1
6787 $ctext insert end "\n "
6788 $ctext insert end [lindex $commitinfo($newid) 0]
6789 $ctext insert end "\n"
6790 $ctext conf -state disabled
6791 $ctext tag remove found 1.0 end
6792 startdiff [list $oldid $newid]
6795 proc mkpatch {} {
6796 global rowmenuid currentid commitinfo patchtop patchnum
6798 if {![info exists currentid]} return
6799 set oldid $currentid
6800 set oldhead [lindex $commitinfo($oldid) 0]
6801 set newid $rowmenuid
6802 set newhead [lindex $commitinfo($newid) 0]
6803 set top .patch
6804 set patchtop $top
6805 catch {destroy $top}
6806 toplevel $top
6807 label $top.title -text [mc "Generate patch"]
6808 grid $top.title - -pady 10
6809 label $top.from -text [mc "From:"]
6810 entry $top.fromsha1 -width 40 -relief flat
6811 $top.fromsha1 insert 0 $oldid
6812 $top.fromsha1 conf -state readonly
6813 grid $top.from $top.fromsha1 -sticky w
6814 entry $top.fromhead -width 60 -relief flat
6815 $top.fromhead insert 0 $oldhead
6816 $top.fromhead conf -state readonly
6817 grid x $top.fromhead -sticky w
6818 label $top.to -text [mc "To:"]
6819 entry $top.tosha1 -width 40 -relief flat
6820 $top.tosha1 insert 0 $newid
6821 $top.tosha1 conf -state readonly
6822 grid $top.to $top.tosha1 -sticky w
6823 entry $top.tohead -width 60 -relief flat
6824 $top.tohead insert 0 $newhead
6825 $top.tohead conf -state readonly
6826 grid x $top.tohead -sticky w
6827 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6828 grid $top.rev x -pady 10
6829 label $top.flab -text [mc "Output file:"]
6830 entry $top.fname -width 60
6831 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6832 incr patchnum
6833 grid $top.flab $top.fname -sticky w
6834 frame $top.buts
6835 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6836 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6837 grid $top.buts.gen $top.buts.can
6838 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6839 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6840 grid $top.buts - -pady 10 -sticky ew
6841 focus $top.fname
6844 proc mkpatchrev {} {
6845 global patchtop
6847 set oldid [$patchtop.fromsha1 get]
6848 set oldhead [$patchtop.fromhead get]
6849 set newid [$patchtop.tosha1 get]
6850 set newhead [$patchtop.tohead get]
6851 foreach e [list fromsha1 fromhead tosha1 tohead] \
6852 v [list $newid $newhead $oldid $oldhead] {
6853 $patchtop.$e conf -state normal
6854 $patchtop.$e delete 0 end
6855 $patchtop.$e insert 0 $v
6856 $patchtop.$e conf -state readonly
6860 proc mkpatchgo {} {
6861 global patchtop nullid nullid2
6863 set oldid [$patchtop.fromsha1 get]
6864 set newid [$patchtop.tosha1 get]
6865 set fname [$patchtop.fname get]
6866 set cmd [diffcmd [list $oldid $newid] -p]
6867 # trim off the initial "|"
6868 set cmd [lrange $cmd 1 end]
6869 lappend cmd >$fname &
6870 if {[catch {eval exec $cmd} err]} {
6871 error_popup "[mc "Error creating patch:"] $err"
6873 catch {destroy $patchtop}
6874 unset patchtop
6877 proc mkpatchcan {} {
6878 global patchtop
6880 catch {destroy $patchtop}
6881 unset patchtop
6884 proc mktag {} {
6885 global rowmenuid mktagtop commitinfo
6887 set top .maketag
6888 set mktagtop $top
6889 catch {destroy $top}
6890 toplevel $top
6891 label $top.title -text [mc "Create tag"]
6892 grid $top.title - -pady 10
6893 label $top.id -text [mc "ID:"]
6894 entry $top.sha1 -width 40 -relief flat
6895 $top.sha1 insert 0 $rowmenuid
6896 $top.sha1 conf -state readonly
6897 grid $top.id $top.sha1 -sticky w
6898 entry $top.head -width 60 -relief flat
6899 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6900 $top.head conf -state readonly
6901 grid x $top.head -sticky w
6902 label $top.tlab -text [mc "Tag name:"]
6903 entry $top.tag -width 60
6904 grid $top.tlab $top.tag -sticky w
6905 frame $top.buts
6906 button $top.buts.gen -text [mc "Create"] -command mktaggo
6907 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6908 grid $top.buts.gen $top.buts.can
6909 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6910 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6911 grid $top.buts - -pady 10 -sticky ew
6912 focus $top.tag
6915 proc domktag {} {
6916 global mktagtop env tagids idtags
6918 set id [$mktagtop.sha1 get]
6919 set tag [$mktagtop.tag get]
6920 if {$tag == {}} {
6921 error_popup [mc "No tag name specified"]
6922 return
6924 if {[info exists tagids($tag)]} {
6925 error_popup [mc "Tag \"%s\" already exists" $tag]
6926 return
6928 if {[catch {
6929 exec git tag $tag $id
6930 } err]} {
6931 error_popup "[mc "Error creating tag:"] $err"
6932 return
6935 set tagids($tag) $id
6936 lappend idtags($id) $tag
6937 redrawtags $id
6938 addedtag $id
6939 dispneartags 0
6940 run refill_reflist
6943 proc redrawtags {id} {
6944 global canv linehtag idpos currentid curview
6945 global canvxmax iddrawn
6947 if {![commitinview $id $curview]} return
6948 if {![info exists iddrawn($id)]} return
6949 set row [rowofcommit $id]
6950 $canv delete tag.$id
6951 set xt [eval drawtags $id $idpos($id)]
6952 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
6953 set text [$canv itemcget $linehtag($row) -text]
6954 set font [$canv itemcget $linehtag($row) -font]
6955 set xr [expr {$xt + [font measure $font $text]}]
6956 if {$xr > $canvxmax} {
6957 set canvxmax $xr
6958 setcanvscroll
6960 if {[info exists currentid] && $currentid == $id} {
6961 make_secsel $row
6965 proc mktagcan {} {
6966 global mktagtop
6968 catch {destroy $mktagtop}
6969 unset mktagtop
6972 proc mktaggo {} {
6973 domktag
6974 mktagcan
6977 proc writecommit {} {
6978 global rowmenuid wrcomtop commitinfo wrcomcmd
6980 set top .writecommit
6981 set wrcomtop $top
6982 catch {destroy $top}
6983 toplevel $top
6984 label $top.title -text [mc "Write commit to file"]
6985 grid $top.title - -pady 10
6986 label $top.id -text [mc "ID:"]
6987 entry $top.sha1 -width 40 -relief flat
6988 $top.sha1 insert 0 $rowmenuid
6989 $top.sha1 conf -state readonly
6990 grid $top.id $top.sha1 -sticky w
6991 entry $top.head -width 60 -relief flat
6992 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6993 $top.head conf -state readonly
6994 grid x $top.head -sticky w
6995 label $top.clab -text [mc "Command:"]
6996 entry $top.cmd -width 60 -textvariable wrcomcmd
6997 grid $top.clab $top.cmd -sticky w -pady 10
6998 label $top.flab -text [mc "Output file:"]
6999 entry $top.fname -width 60
7000 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7001 grid $top.flab $top.fname -sticky w
7002 frame $top.buts
7003 button $top.buts.gen -text [mc "Write"] -command wrcomgo
7004 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7005 grid $top.buts.gen $top.buts.can
7006 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7007 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7008 grid $top.buts - -pady 10 -sticky ew
7009 focus $top.fname
7012 proc wrcomgo {} {
7013 global wrcomtop
7015 set id [$wrcomtop.sha1 get]
7016 set cmd "echo $id | [$wrcomtop.cmd get]"
7017 set fname [$wrcomtop.fname get]
7018 if {[catch {exec sh -c $cmd >$fname &} err]} {
7019 error_popup "[mc "Error writing commit:"] $err"
7021 catch {destroy $wrcomtop}
7022 unset wrcomtop
7025 proc wrcomcan {} {
7026 global wrcomtop
7028 catch {destroy $wrcomtop}
7029 unset wrcomtop
7032 proc mkbranch {} {
7033 global rowmenuid mkbrtop
7035 set top .makebranch
7036 catch {destroy $top}
7037 toplevel $top
7038 label $top.title -text [mc "Create new branch"]
7039 grid $top.title - -pady 10
7040 label $top.id -text [mc "ID:"]
7041 entry $top.sha1 -width 40 -relief flat
7042 $top.sha1 insert 0 $rowmenuid
7043 $top.sha1 conf -state readonly
7044 grid $top.id $top.sha1 -sticky w
7045 label $top.nlab -text [mc "Name:"]
7046 entry $top.name -width 40
7047 grid $top.nlab $top.name -sticky w
7048 frame $top.buts
7049 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7050 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7051 grid $top.buts.go $top.buts.can
7052 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7053 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7054 grid $top.buts - -pady 10 -sticky ew
7055 focus $top.name
7058 proc mkbrgo {top} {
7059 global headids idheads
7061 set name [$top.name get]
7062 set id [$top.sha1 get]
7063 if {$name eq {}} {
7064 error_popup [mc "Please specify a name for the new branch"]
7065 return
7067 catch {destroy $top}
7068 nowbusy newbranch
7069 update
7070 if {[catch {
7071 exec git branch $name $id
7072 } err]} {
7073 notbusy newbranch
7074 error_popup $err
7075 } else {
7076 set headids($name) $id
7077 lappend idheads($id) $name
7078 addedhead $id $name
7079 notbusy newbranch
7080 redrawtags $id
7081 dispneartags 0
7082 run refill_reflist
7086 proc cherrypick {} {
7087 global rowmenuid curview
7088 global mainhead mainheadid
7090 set oldhead [exec git rev-parse HEAD]
7091 set dheads [descheads $rowmenuid]
7092 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7093 set ok [confirm_popup [mc "Commit %s is already\
7094 included in branch %s -- really re-apply it?" \
7095 [string range $rowmenuid 0 7] $mainhead]]
7096 if {!$ok} return
7098 nowbusy cherrypick [mc "Cherry-picking"]
7099 update
7100 # Unfortunately git-cherry-pick writes stuff to stderr even when
7101 # no error occurs, and exec takes that as an indication of error...
7102 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7103 notbusy cherrypick
7104 error_popup $err
7105 return
7107 set newhead [exec git rev-parse HEAD]
7108 if {$newhead eq $oldhead} {
7109 notbusy cherrypick
7110 error_popup [mc "No changes committed"]
7111 return
7113 addnewchild $newhead $oldhead
7114 if {[commitinview $oldhead $curview]} {
7115 insertrow $newhead $oldhead $curview
7116 if {$mainhead ne {}} {
7117 movehead $newhead $mainhead
7118 movedhead $newhead $mainhead
7119 set mainheadid $newhead
7121 redrawtags $oldhead
7122 redrawtags $newhead
7123 selbyid $newhead
7125 notbusy cherrypick
7128 proc resethead {} {
7129 global mainhead rowmenuid confirm_ok resettype
7131 set confirm_ok 0
7132 set w ".confirmreset"
7133 toplevel $w
7134 wm transient $w .
7135 wm title $w [mc "Confirm reset"]
7136 message $w.m -text \
7137 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7138 -justify center -aspect 1000
7139 pack $w.m -side top -fill x -padx 20 -pady 20
7140 frame $w.f -relief sunken -border 2
7141 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7142 grid $w.f.rt -sticky w
7143 set resettype mixed
7144 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7145 -text [mc "Soft: Leave working tree and index untouched"]
7146 grid $w.f.soft -sticky w
7147 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7148 -text [mc "Mixed: Leave working tree untouched, reset index"]
7149 grid $w.f.mixed -sticky w
7150 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7151 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7152 grid $w.f.hard -sticky w
7153 pack $w.f -side top -fill x
7154 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7155 pack $w.ok -side left -fill x -padx 20 -pady 20
7156 button $w.cancel -text [mc Cancel] -command "destroy $w"
7157 pack $w.cancel -side right -fill x -padx 20 -pady 20
7158 bind $w <Visibility> "grab $w; focus $w"
7159 tkwait window $w
7160 if {!$confirm_ok} return
7161 if {[catch {set fd [open \
7162 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
7163 error_popup $err
7164 } else {
7165 dohidelocalchanges
7166 filerun $fd [list readresetstat $fd]
7167 nowbusy reset [mc "Resetting"]
7168 selbyid $rowmenuid
7172 proc readresetstat {fd} {
7173 global mainhead mainheadid showlocalchanges rprogcoord
7175 if {[gets $fd line] >= 0} {
7176 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7177 set rprogcoord [expr {1.0 * $m / $n}]
7178 adjustprogress
7180 return 1
7182 set rprogcoord 0
7183 adjustprogress
7184 notbusy reset
7185 if {[catch {close $fd} err]} {
7186 error_popup $err
7188 set oldhead $mainheadid
7189 set newhead [exec git rev-parse HEAD]
7190 if {$newhead ne $oldhead} {
7191 movehead $newhead $mainhead
7192 movedhead $newhead $mainhead
7193 set mainheadid $newhead
7194 redrawtags $oldhead
7195 redrawtags $newhead
7197 if {$showlocalchanges} {
7198 doshowlocalchanges
7200 return 0
7203 # context menu for a head
7204 proc headmenu {x y id head} {
7205 global headmenuid headmenuhead headctxmenu mainhead
7207 stopfinding
7208 set headmenuid $id
7209 set headmenuhead $head
7210 set state normal
7211 if {$head eq $mainhead} {
7212 set state disabled
7214 $headctxmenu entryconfigure 0 -state $state
7215 $headctxmenu entryconfigure 1 -state $state
7216 tk_popup $headctxmenu $x $y
7219 proc cobranch {} {
7220 global headmenuid headmenuhead mainhead headids
7221 global showlocalchanges mainheadid
7223 # check the tree is clean first??
7224 set oldmainhead $mainhead
7225 nowbusy checkout [mc "Checking out"]
7226 update
7227 dohidelocalchanges
7228 if {[catch {
7229 exec git checkout -q $headmenuhead
7230 } err]} {
7231 notbusy checkout
7232 error_popup $err
7233 } else {
7234 notbusy checkout
7235 set mainhead $headmenuhead
7236 set mainheadid $headmenuid
7237 if {[info exists headids($oldmainhead)]} {
7238 redrawtags $headids($oldmainhead)
7240 redrawtags $headmenuid
7241 selbyid $headmenuid
7243 if {$showlocalchanges} {
7244 dodiffindex
7248 proc rmbranch {} {
7249 global headmenuid headmenuhead mainhead
7250 global idheads
7252 set head $headmenuhead
7253 set id $headmenuid
7254 # this check shouldn't be needed any more...
7255 if {$head eq $mainhead} {
7256 error_popup [mc "Cannot delete the currently checked-out branch"]
7257 return
7259 set dheads [descheads $id]
7260 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7261 # the stuff on this branch isn't on any other branch
7262 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7263 branch.\nReally delete branch %s?" $head $head]]} return
7265 nowbusy rmbranch
7266 update
7267 if {[catch {exec git branch -D $head} err]} {
7268 notbusy rmbranch
7269 error_popup $err
7270 return
7272 removehead $id $head
7273 removedhead $id $head
7274 redrawtags $id
7275 notbusy rmbranch
7276 dispneartags 0
7277 run refill_reflist
7280 # Display a list of tags and heads
7281 proc showrefs {} {
7282 global showrefstop bgcolor fgcolor selectbgcolor
7283 global bglist fglist reflistfilter reflist maincursor
7285 set top .showrefs
7286 set showrefstop $top
7287 if {[winfo exists $top]} {
7288 raise $top
7289 refill_reflist
7290 return
7292 toplevel $top
7293 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7294 text $top.list -background $bgcolor -foreground $fgcolor \
7295 -selectbackground $selectbgcolor -font mainfont \
7296 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7297 -width 30 -height 20 -cursor $maincursor \
7298 -spacing1 1 -spacing3 1 -state disabled
7299 $top.list tag configure highlight -background $selectbgcolor
7300 lappend bglist $top.list
7301 lappend fglist $top.list
7302 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7303 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7304 grid $top.list $top.ysb -sticky nsew
7305 grid $top.xsb x -sticky ew
7306 frame $top.f
7307 label $top.f.l -text "[mc "Filter"]: "
7308 entry $top.f.e -width 20 -textvariable reflistfilter
7309 set reflistfilter "*"
7310 trace add variable reflistfilter write reflistfilter_change
7311 pack $top.f.e -side right -fill x -expand 1
7312 pack $top.f.l -side left
7313 grid $top.f - -sticky ew -pady 2
7314 button $top.close -command [list destroy $top] -text [mc "Close"]
7315 grid $top.close -
7316 grid columnconfigure $top 0 -weight 1
7317 grid rowconfigure $top 0 -weight 1
7318 bind $top.list <1> {break}
7319 bind $top.list <B1-Motion> {break}
7320 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7321 set reflist {}
7322 refill_reflist
7325 proc sel_reflist {w x y} {
7326 global showrefstop reflist headids tagids otherrefids
7328 if {![winfo exists $showrefstop]} return
7329 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7330 set ref [lindex $reflist [expr {$l-1}]]
7331 set n [lindex $ref 0]
7332 switch -- [lindex $ref 1] {
7333 "H" {selbyid $headids($n)}
7334 "T" {selbyid $tagids($n)}
7335 "o" {selbyid $otherrefids($n)}
7337 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7340 proc unsel_reflist {} {
7341 global showrefstop
7343 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7344 $showrefstop.list tag remove highlight 0.0 end
7347 proc reflistfilter_change {n1 n2 op} {
7348 global reflistfilter
7350 after cancel refill_reflist
7351 after 200 refill_reflist
7354 proc refill_reflist {} {
7355 global reflist reflistfilter showrefstop headids tagids otherrefids
7356 global curview commitinterest
7358 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7359 set refs {}
7360 foreach n [array names headids] {
7361 if {[string match $reflistfilter $n]} {
7362 if {[commitinview $headids($n) $curview]} {
7363 lappend refs [list $n H]
7364 } else {
7365 set commitinterest($headids($n)) {run refill_reflist}
7369 foreach n [array names tagids] {
7370 if {[string match $reflistfilter $n]} {
7371 if {[commitinview $tagids($n) $curview]} {
7372 lappend refs [list $n T]
7373 } else {
7374 set commitinterest($tagids($n)) {run refill_reflist}
7378 foreach n [array names otherrefids] {
7379 if {[string match $reflistfilter $n]} {
7380 if {[commitinview $otherrefids($n) $curview]} {
7381 lappend refs [list $n o]
7382 } else {
7383 set commitinterest($otherrefids($n)) {run refill_reflist}
7387 set refs [lsort -index 0 $refs]
7388 if {$refs eq $reflist} return
7390 # Update the contents of $showrefstop.list according to the
7391 # differences between $reflist (old) and $refs (new)
7392 $showrefstop.list conf -state normal
7393 $showrefstop.list insert end "\n"
7394 set i 0
7395 set j 0
7396 while {$i < [llength $reflist] || $j < [llength $refs]} {
7397 if {$i < [llength $reflist]} {
7398 if {$j < [llength $refs]} {
7399 set cmp [string compare [lindex $reflist $i 0] \
7400 [lindex $refs $j 0]]
7401 if {$cmp == 0} {
7402 set cmp [string compare [lindex $reflist $i 1] \
7403 [lindex $refs $j 1]]
7405 } else {
7406 set cmp -1
7408 } else {
7409 set cmp 1
7411 switch -- $cmp {
7412 -1 {
7413 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7414 incr i
7417 incr i
7418 incr j
7421 set l [expr {$j + 1}]
7422 $showrefstop.list image create $l.0 -align baseline \
7423 -image reficon-[lindex $refs $j 1] -padx 2
7424 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7425 incr j
7429 set reflist $refs
7430 # delete last newline
7431 $showrefstop.list delete end-2c end-1c
7432 $showrefstop.list conf -state disabled
7435 # Stuff for finding nearby tags
7436 proc getallcommits {} {
7437 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7438 global idheads idtags idotherrefs allparents tagobjid
7440 if {![info exists allcommits]} {
7441 set nextarc 0
7442 set allcommits 0
7443 set seeds {}
7444 set allcwait 0
7445 set cachedarcs 0
7446 set allccache [file join [gitdir] "gitk.cache"]
7447 if {![catch {
7448 set f [open $allccache r]
7449 set allcwait 1
7450 getcache $f
7451 }]} return
7454 if {$allcwait} {
7455 return
7457 set cmd [list | git rev-list --parents]
7458 set allcupdate [expr {$seeds ne {}}]
7459 if {!$allcupdate} {
7460 set ids "--all"
7461 } else {
7462 set refs [concat [array names idheads] [array names idtags] \
7463 [array names idotherrefs]]
7464 set ids {}
7465 set tagobjs {}
7466 foreach name [array names tagobjid] {
7467 lappend tagobjs $tagobjid($name)
7469 foreach id [lsort -unique $refs] {
7470 if {![info exists allparents($id)] &&
7471 [lsearch -exact $tagobjs $id] < 0} {
7472 lappend ids $id
7475 if {$ids ne {}} {
7476 foreach id $seeds {
7477 lappend ids "^$id"
7481 if {$ids ne {}} {
7482 set fd [open [concat $cmd $ids] r]
7483 fconfigure $fd -blocking 0
7484 incr allcommits
7485 nowbusy allcommits
7486 filerun $fd [list getallclines $fd]
7487 } else {
7488 dispneartags 0
7492 # Since most commits have 1 parent and 1 child, we group strings of
7493 # such commits into "arcs" joining branch/merge points (BMPs), which
7494 # are commits that either don't have 1 parent or don't have 1 child.
7496 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7497 # arcout(id) - outgoing arcs for BMP
7498 # arcids(a) - list of IDs on arc including end but not start
7499 # arcstart(a) - BMP ID at start of arc
7500 # arcend(a) - BMP ID at end of arc
7501 # growing(a) - arc a is still growing
7502 # arctags(a) - IDs out of arcids (excluding end) that have tags
7503 # archeads(a) - IDs out of arcids (excluding end) that have heads
7504 # The start of an arc is at the descendent end, so "incoming" means
7505 # coming from descendents, and "outgoing" means going towards ancestors.
7507 proc getallclines {fd} {
7508 global allparents allchildren idtags idheads nextarc
7509 global arcnos arcids arctags arcout arcend arcstart archeads growing
7510 global seeds allcommits cachedarcs allcupdate
7512 set nid 0
7513 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7514 set id [lindex $line 0]
7515 if {[info exists allparents($id)]} {
7516 # seen it already
7517 continue
7519 set cachedarcs 0
7520 set olds [lrange $line 1 end]
7521 set allparents($id) $olds
7522 if {![info exists allchildren($id)]} {
7523 set allchildren($id) {}
7524 set arcnos($id) {}
7525 lappend seeds $id
7526 } else {
7527 set a $arcnos($id)
7528 if {[llength $olds] == 1 && [llength $a] == 1} {
7529 lappend arcids($a) $id
7530 if {[info exists idtags($id)]} {
7531 lappend arctags($a) $id
7533 if {[info exists idheads($id)]} {
7534 lappend archeads($a) $id
7536 if {[info exists allparents($olds)]} {
7537 # seen parent already
7538 if {![info exists arcout($olds)]} {
7539 splitarc $olds
7541 lappend arcids($a) $olds
7542 set arcend($a) $olds
7543 unset growing($a)
7545 lappend allchildren($olds) $id
7546 lappend arcnos($olds) $a
7547 continue
7550 foreach a $arcnos($id) {
7551 lappend arcids($a) $id
7552 set arcend($a) $id
7553 unset growing($a)
7556 set ao {}
7557 foreach p $olds {
7558 lappend allchildren($p) $id
7559 set a [incr nextarc]
7560 set arcstart($a) $id
7561 set archeads($a) {}
7562 set arctags($a) {}
7563 set archeads($a) {}
7564 set arcids($a) {}
7565 lappend ao $a
7566 set growing($a) 1
7567 if {[info exists allparents($p)]} {
7568 # seen it already, may need to make a new branch
7569 if {![info exists arcout($p)]} {
7570 splitarc $p
7572 lappend arcids($a) $p
7573 set arcend($a) $p
7574 unset growing($a)
7576 lappend arcnos($p) $a
7578 set arcout($id) $ao
7580 if {$nid > 0} {
7581 global cached_dheads cached_dtags cached_atags
7582 catch {unset cached_dheads}
7583 catch {unset cached_dtags}
7584 catch {unset cached_atags}
7586 if {![eof $fd]} {
7587 return [expr {$nid >= 1000? 2: 1}]
7589 set cacheok 1
7590 if {[catch {
7591 fconfigure $fd -blocking 1
7592 close $fd
7593 } err]} {
7594 # got an error reading the list of commits
7595 # if we were updating, try rereading the whole thing again
7596 if {$allcupdate} {
7597 incr allcommits -1
7598 dropcache $err
7599 return
7601 error_popup "[mc "Error reading commit topology information;\
7602 branch and preceding/following tag information\
7603 will be incomplete."]\n($err)"
7604 set cacheok 0
7606 if {[incr allcommits -1] == 0} {
7607 notbusy allcommits
7608 if {$cacheok} {
7609 run savecache
7612 dispneartags 0
7613 return 0
7616 proc recalcarc {a} {
7617 global arctags archeads arcids idtags idheads
7619 set at {}
7620 set ah {}
7621 foreach id [lrange $arcids($a) 0 end-1] {
7622 if {[info exists idtags($id)]} {
7623 lappend at $id
7625 if {[info exists idheads($id)]} {
7626 lappend ah $id
7629 set arctags($a) $at
7630 set archeads($a) $ah
7633 proc splitarc {p} {
7634 global arcnos arcids nextarc arctags archeads idtags idheads
7635 global arcstart arcend arcout allparents growing
7637 set a $arcnos($p)
7638 if {[llength $a] != 1} {
7639 puts "oops splitarc called but [llength $a] arcs already"
7640 return
7642 set a [lindex $a 0]
7643 set i [lsearch -exact $arcids($a) $p]
7644 if {$i < 0} {
7645 puts "oops splitarc $p not in arc $a"
7646 return
7648 set na [incr nextarc]
7649 if {[info exists arcend($a)]} {
7650 set arcend($na) $arcend($a)
7651 } else {
7652 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7653 set j [lsearch -exact $arcnos($l) $a]
7654 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7656 set tail [lrange $arcids($a) [expr {$i+1}] end]
7657 set arcids($a) [lrange $arcids($a) 0 $i]
7658 set arcend($a) $p
7659 set arcstart($na) $p
7660 set arcout($p) $na
7661 set arcids($na) $tail
7662 if {[info exists growing($a)]} {
7663 set growing($na) 1
7664 unset growing($a)
7667 foreach id $tail {
7668 if {[llength $arcnos($id)] == 1} {
7669 set arcnos($id) $na
7670 } else {
7671 set j [lsearch -exact $arcnos($id) $a]
7672 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7676 # reconstruct tags and heads lists
7677 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7678 recalcarc $a
7679 recalcarc $na
7680 } else {
7681 set arctags($na) {}
7682 set archeads($na) {}
7686 # Update things for a new commit added that is a child of one
7687 # existing commit. Used when cherry-picking.
7688 proc addnewchild {id p} {
7689 global allparents allchildren idtags nextarc
7690 global arcnos arcids arctags arcout arcend arcstart archeads growing
7691 global seeds allcommits
7693 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7694 set allparents($id) [list $p]
7695 set allchildren($id) {}
7696 set arcnos($id) {}
7697 lappend seeds $id
7698 lappend allchildren($p) $id
7699 set a [incr nextarc]
7700 set arcstart($a) $id
7701 set archeads($a) {}
7702 set arctags($a) {}
7703 set arcids($a) [list $p]
7704 set arcend($a) $p
7705 if {![info exists arcout($p)]} {
7706 splitarc $p
7708 lappend arcnos($p) $a
7709 set arcout($id) [list $a]
7712 # This implements a cache for the topology information.
7713 # The cache saves, for each arc, the start and end of the arc,
7714 # the ids on the arc, and the outgoing arcs from the end.
7715 proc readcache {f} {
7716 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7717 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7718 global allcwait
7720 set a $nextarc
7721 set lim $cachedarcs
7722 if {$lim - $a > 500} {
7723 set lim [expr {$a + 500}]
7725 if {[catch {
7726 if {$a == $lim} {
7727 # finish reading the cache and setting up arctags, etc.
7728 set line [gets $f]
7729 if {$line ne "1"} {error "bad final version"}
7730 close $f
7731 foreach id [array names idtags] {
7732 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7733 [llength $allparents($id)] == 1} {
7734 set a [lindex $arcnos($id) 0]
7735 if {$arctags($a) eq {}} {
7736 recalcarc $a
7740 foreach id [array names idheads] {
7741 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7742 [llength $allparents($id)] == 1} {
7743 set a [lindex $arcnos($id) 0]
7744 if {$archeads($a) eq {}} {
7745 recalcarc $a
7749 foreach id [lsort -unique $possible_seeds] {
7750 if {$arcnos($id) eq {}} {
7751 lappend seeds $id
7754 set allcwait 0
7755 } else {
7756 while {[incr a] <= $lim} {
7757 set line [gets $f]
7758 if {[llength $line] != 3} {error "bad line"}
7759 set s [lindex $line 0]
7760 set arcstart($a) $s
7761 lappend arcout($s) $a
7762 if {![info exists arcnos($s)]} {
7763 lappend possible_seeds $s
7764 set arcnos($s) {}
7766 set e [lindex $line 1]
7767 if {$e eq {}} {
7768 set growing($a) 1
7769 } else {
7770 set arcend($a) $e
7771 if {![info exists arcout($e)]} {
7772 set arcout($e) {}
7775 set arcids($a) [lindex $line 2]
7776 foreach id $arcids($a) {
7777 lappend allparents($s) $id
7778 set s $id
7779 lappend arcnos($id) $a
7781 if {![info exists allparents($s)]} {
7782 set allparents($s) {}
7784 set arctags($a) {}
7785 set archeads($a) {}
7787 set nextarc [expr {$a - 1}]
7789 } err]} {
7790 dropcache $err
7791 return 0
7793 if {!$allcwait} {
7794 getallcommits
7796 return $allcwait
7799 proc getcache {f} {
7800 global nextarc cachedarcs possible_seeds
7802 if {[catch {
7803 set line [gets $f]
7804 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7805 # make sure it's an integer
7806 set cachedarcs [expr {int([lindex $line 1])}]
7807 if {$cachedarcs < 0} {error "bad number of arcs"}
7808 set nextarc 0
7809 set possible_seeds {}
7810 run readcache $f
7811 } err]} {
7812 dropcache $err
7814 return 0
7817 proc dropcache {err} {
7818 global allcwait nextarc cachedarcs seeds
7820 #puts "dropping cache ($err)"
7821 foreach v {arcnos arcout arcids arcstart arcend growing \
7822 arctags archeads allparents allchildren} {
7823 global $v
7824 catch {unset $v}
7826 set allcwait 0
7827 set nextarc 0
7828 set cachedarcs 0
7829 set seeds {}
7830 getallcommits
7833 proc writecache {f} {
7834 global cachearc cachedarcs allccache
7835 global arcstart arcend arcnos arcids arcout
7837 set a $cachearc
7838 set lim $cachedarcs
7839 if {$lim - $a > 1000} {
7840 set lim [expr {$a + 1000}]
7842 if {[catch {
7843 while {[incr a] <= $lim} {
7844 if {[info exists arcend($a)]} {
7845 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7846 } else {
7847 puts $f [list $arcstart($a) {} $arcids($a)]
7850 } err]} {
7851 catch {close $f}
7852 catch {file delete $allccache}
7853 #puts "writing cache failed ($err)"
7854 return 0
7856 set cachearc [expr {$a - 1}]
7857 if {$a > $cachedarcs} {
7858 puts $f "1"
7859 close $f
7860 return 0
7862 return 1
7865 proc savecache {} {
7866 global nextarc cachedarcs cachearc allccache
7868 if {$nextarc == $cachedarcs} return
7869 set cachearc 0
7870 set cachedarcs $nextarc
7871 catch {
7872 set f [open $allccache w]
7873 puts $f [list 1 $cachedarcs]
7874 run writecache $f
7878 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7879 # or 0 if neither is true.
7880 proc anc_or_desc {a b} {
7881 global arcout arcstart arcend arcnos cached_isanc
7883 if {$arcnos($a) eq $arcnos($b)} {
7884 # Both are on the same arc(s); either both are the same BMP,
7885 # or if one is not a BMP, the other is also not a BMP or is
7886 # the BMP at end of the arc (and it only has 1 incoming arc).
7887 # Or both can be BMPs with no incoming arcs.
7888 if {$a eq $b || $arcnos($a) eq {}} {
7889 return 0
7891 # assert {[llength $arcnos($a)] == 1}
7892 set arc [lindex $arcnos($a) 0]
7893 set i [lsearch -exact $arcids($arc) $a]
7894 set j [lsearch -exact $arcids($arc) $b]
7895 if {$i < 0 || $i > $j} {
7896 return 1
7897 } else {
7898 return -1
7902 if {![info exists arcout($a)]} {
7903 set arc [lindex $arcnos($a) 0]
7904 if {[info exists arcend($arc)]} {
7905 set aend $arcend($arc)
7906 } else {
7907 set aend {}
7909 set a $arcstart($arc)
7910 } else {
7911 set aend $a
7913 if {![info exists arcout($b)]} {
7914 set arc [lindex $arcnos($b) 0]
7915 if {[info exists arcend($arc)]} {
7916 set bend $arcend($arc)
7917 } else {
7918 set bend {}
7920 set b $arcstart($arc)
7921 } else {
7922 set bend $b
7924 if {$a eq $bend} {
7925 return 1
7927 if {$b eq $aend} {
7928 return -1
7930 if {[info exists cached_isanc($a,$bend)]} {
7931 if {$cached_isanc($a,$bend)} {
7932 return 1
7935 if {[info exists cached_isanc($b,$aend)]} {
7936 if {$cached_isanc($b,$aend)} {
7937 return -1
7939 if {[info exists cached_isanc($a,$bend)]} {
7940 return 0
7944 set todo [list $a $b]
7945 set anc($a) a
7946 set anc($b) b
7947 for {set i 0} {$i < [llength $todo]} {incr i} {
7948 set x [lindex $todo $i]
7949 if {$anc($x) eq {}} {
7950 continue
7952 foreach arc $arcnos($x) {
7953 set xd $arcstart($arc)
7954 if {$xd eq $bend} {
7955 set cached_isanc($a,$bend) 1
7956 set cached_isanc($b,$aend) 0
7957 return 1
7958 } elseif {$xd eq $aend} {
7959 set cached_isanc($b,$aend) 1
7960 set cached_isanc($a,$bend) 0
7961 return -1
7963 if {![info exists anc($xd)]} {
7964 set anc($xd) $anc($x)
7965 lappend todo $xd
7966 } elseif {$anc($xd) ne $anc($x)} {
7967 set anc($xd) {}
7971 set cached_isanc($a,$bend) 0
7972 set cached_isanc($b,$aend) 0
7973 return 0
7976 # This identifies whether $desc has an ancestor that is
7977 # a growing tip of the graph and which is not an ancestor of $anc
7978 # and returns 0 if so and 1 if not.
7979 # If we subsequently discover a tag on such a growing tip, and that
7980 # turns out to be a descendent of $anc (which it could, since we
7981 # don't necessarily see children before parents), then $desc
7982 # isn't a good choice to display as a descendent tag of
7983 # $anc (since it is the descendent of another tag which is
7984 # a descendent of $anc). Similarly, $anc isn't a good choice to
7985 # display as a ancestor tag of $desc.
7987 proc is_certain {desc anc} {
7988 global arcnos arcout arcstart arcend growing problems
7990 set certain {}
7991 if {[llength $arcnos($anc)] == 1} {
7992 # tags on the same arc are certain
7993 if {$arcnos($desc) eq $arcnos($anc)} {
7994 return 1
7996 if {![info exists arcout($anc)]} {
7997 # if $anc is partway along an arc, use the start of the arc instead
7998 set a [lindex $arcnos($anc) 0]
7999 set anc $arcstart($a)
8002 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8003 set x $desc
8004 } else {
8005 set a [lindex $arcnos($desc) 0]
8006 set x $arcend($a)
8008 if {$x == $anc} {
8009 return 1
8011 set anclist [list $x]
8012 set dl($x) 1
8013 set nnh 1
8014 set ngrowanc 0
8015 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8016 set x [lindex $anclist $i]
8017 if {$dl($x)} {
8018 incr nnh -1
8020 set done($x) 1
8021 foreach a $arcout($x) {
8022 if {[info exists growing($a)]} {
8023 if {![info exists growanc($x)] && $dl($x)} {
8024 set growanc($x) 1
8025 incr ngrowanc
8027 } else {
8028 set y $arcend($a)
8029 if {[info exists dl($y)]} {
8030 if {$dl($y)} {
8031 if {!$dl($x)} {
8032 set dl($y) 0
8033 if {![info exists done($y)]} {
8034 incr nnh -1
8036 if {[info exists growanc($x)]} {
8037 incr ngrowanc -1
8039 set xl [list $y]
8040 for {set k 0} {$k < [llength $xl]} {incr k} {
8041 set z [lindex $xl $k]
8042 foreach c $arcout($z) {
8043 if {[info exists arcend($c)]} {
8044 set v $arcend($c)
8045 if {[info exists dl($v)] && $dl($v)} {
8046 set dl($v) 0
8047 if {![info exists done($v)]} {
8048 incr nnh -1
8050 if {[info exists growanc($v)]} {
8051 incr ngrowanc -1
8053 lappend xl $v
8060 } elseif {$y eq $anc || !$dl($x)} {
8061 set dl($y) 0
8062 lappend anclist $y
8063 } else {
8064 set dl($y) 1
8065 lappend anclist $y
8066 incr nnh
8071 foreach x [array names growanc] {
8072 if {$dl($x)} {
8073 return 0
8075 return 0
8077 return 1
8080 proc validate_arctags {a} {
8081 global arctags idtags
8083 set i -1
8084 set na $arctags($a)
8085 foreach id $arctags($a) {
8086 incr i
8087 if {![info exists idtags($id)]} {
8088 set na [lreplace $na $i $i]
8089 incr i -1
8092 set arctags($a) $na
8095 proc validate_archeads {a} {
8096 global archeads idheads
8098 set i -1
8099 set na $archeads($a)
8100 foreach id $archeads($a) {
8101 incr i
8102 if {![info exists idheads($id)]} {
8103 set na [lreplace $na $i $i]
8104 incr i -1
8107 set archeads($a) $na
8110 # Return the list of IDs that have tags that are descendents of id,
8111 # ignoring IDs that are descendents of IDs already reported.
8112 proc desctags {id} {
8113 global arcnos arcstart arcids arctags idtags allparents
8114 global growing cached_dtags
8116 if {![info exists allparents($id)]} {
8117 return {}
8119 set t1 [clock clicks -milliseconds]
8120 set argid $id
8121 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8122 # part-way along an arc; check that arc first
8123 set a [lindex $arcnos($id) 0]
8124 if {$arctags($a) ne {}} {
8125 validate_arctags $a
8126 set i [lsearch -exact $arcids($a) $id]
8127 set tid {}
8128 foreach t $arctags($a) {
8129 set j [lsearch -exact $arcids($a) $t]
8130 if {$j >= $i} break
8131 set tid $t
8133 if {$tid ne {}} {
8134 return $tid
8137 set id $arcstart($a)
8138 if {[info exists idtags($id)]} {
8139 return $id
8142 if {[info exists cached_dtags($id)]} {
8143 return $cached_dtags($id)
8146 set origid $id
8147 set todo [list $id]
8148 set queued($id) 1
8149 set nc 1
8150 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8151 set id [lindex $todo $i]
8152 set done($id) 1
8153 set ta [info exists hastaggedancestor($id)]
8154 if {!$ta} {
8155 incr nc -1
8157 # ignore tags on starting node
8158 if {!$ta && $i > 0} {
8159 if {[info exists idtags($id)]} {
8160 set tagloc($id) $id
8161 set ta 1
8162 } elseif {[info exists cached_dtags($id)]} {
8163 set tagloc($id) $cached_dtags($id)
8164 set ta 1
8167 foreach a $arcnos($id) {
8168 set d $arcstart($a)
8169 if {!$ta && $arctags($a) ne {}} {
8170 validate_arctags $a
8171 if {$arctags($a) ne {}} {
8172 lappend tagloc($id) [lindex $arctags($a) end]
8175 if {$ta || $arctags($a) ne {}} {
8176 set tomark [list $d]
8177 for {set j 0} {$j < [llength $tomark]} {incr j} {
8178 set dd [lindex $tomark $j]
8179 if {![info exists hastaggedancestor($dd)]} {
8180 if {[info exists done($dd)]} {
8181 foreach b $arcnos($dd) {
8182 lappend tomark $arcstart($b)
8184 if {[info exists tagloc($dd)]} {
8185 unset tagloc($dd)
8187 } elseif {[info exists queued($dd)]} {
8188 incr nc -1
8190 set hastaggedancestor($dd) 1
8194 if {![info exists queued($d)]} {
8195 lappend todo $d
8196 set queued($d) 1
8197 if {![info exists hastaggedancestor($d)]} {
8198 incr nc
8203 set tags {}
8204 foreach id [array names tagloc] {
8205 if {![info exists hastaggedancestor($id)]} {
8206 foreach t $tagloc($id) {
8207 if {[lsearch -exact $tags $t] < 0} {
8208 lappend tags $t
8213 set t2 [clock clicks -milliseconds]
8214 set loopix $i
8216 # remove tags that are descendents of other tags
8217 for {set i 0} {$i < [llength $tags]} {incr i} {
8218 set a [lindex $tags $i]
8219 for {set j 0} {$j < $i} {incr j} {
8220 set b [lindex $tags $j]
8221 set r [anc_or_desc $a $b]
8222 if {$r == 1} {
8223 set tags [lreplace $tags $j $j]
8224 incr j -1
8225 incr i -1
8226 } elseif {$r == -1} {
8227 set tags [lreplace $tags $i $i]
8228 incr i -1
8229 break
8234 if {[array names growing] ne {}} {
8235 # graph isn't finished, need to check if any tag could get
8236 # eclipsed by another tag coming later. Simply ignore any
8237 # tags that could later get eclipsed.
8238 set ctags {}
8239 foreach t $tags {
8240 if {[is_certain $t $origid]} {
8241 lappend ctags $t
8244 if {$tags eq $ctags} {
8245 set cached_dtags($origid) $tags
8246 } else {
8247 set tags $ctags
8249 } else {
8250 set cached_dtags($origid) $tags
8252 set t3 [clock clicks -milliseconds]
8253 if {0 && $t3 - $t1 >= 100} {
8254 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8255 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8257 return $tags
8260 proc anctags {id} {
8261 global arcnos arcids arcout arcend arctags idtags allparents
8262 global growing cached_atags
8264 if {![info exists allparents($id)]} {
8265 return {}
8267 set t1 [clock clicks -milliseconds]
8268 set argid $id
8269 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8270 # part-way along an arc; check that arc first
8271 set a [lindex $arcnos($id) 0]
8272 if {$arctags($a) ne {}} {
8273 validate_arctags $a
8274 set i [lsearch -exact $arcids($a) $id]
8275 foreach t $arctags($a) {
8276 set j [lsearch -exact $arcids($a) $t]
8277 if {$j > $i} {
8278 return $t
8282 if {![info exists arcend($a)]} {
8283 return {}
8285 set id $arcend($a)
8286 if {[info exists idtags($id)]} {
8287 return $id
8290 if {[info exists cached_atags($id)]} {
8291 return $cached_atags($id)
8294 set origid $id
8295 set todo [list $id]
8296 set queued($id) 1
8297 set taglist {}
8298 set nc 1
8299 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8300 set id [lindex $todo $i]
8301 set done($id) 1
8302 set td [info exists hastaggeddescendent($id)]
8303 if {!$td} {
8304 incr nc -1
8306 # ignore tags on starting node
8307 if {!$td && $i > 0} {
8308 if {[info exists idtags($id)]} {
8309 set tagloc($id) $id
8310 set td 1
8311 } elseif {[info exists cached_atags($id)]} {
8312 set tagloc($id) $cached_atags($id)
8313 set td 1
8316 foreach a $arcout($id) {
8317 if {!$td && $arctags($a) ne {}} {
8318 validate_arctags $a
8319 if {$arctags($a) ne {}} {
8320 lappend tagloc($id) [lindex $arctags($a) 0]
8323 if {![info exists arcend($a)]} continue
8324 set d $arcend($a)
8325 if {$td || $arctags($a) ne {}} {
8326 set tomark [list $d]
8327 for {set j 0} {$j < [llength $tomark]} {incr j} {
8328 set dd [lindex $tomark $j]
8329 if {![info exists hastaggeddescendent($dd)]} {
8330 if {[info exists done($dd)]} {
8331 foreach b $arcout($dd) {
8332 if {[info exists arcend($b)]} {
8333 lappend tomark $arcend($b)
8336 if {[info exists tagloc($dd)]} {
8337 unset tagloc($dd)
8339 } elseif {[info exists queued($dd)]} {
8340 incr nc -1
8342 set hastaggeddescendent($dd) 1
8346 if {![info exists queued($d)]} {
8347 lappend todo $d
8348 set queued($d) 1
8349 if {![info exists hastaggeddescendent($d)]} {
8350 incr nc
8355 set t2 [clock clicks -milliseconds]
8356 set loopix $i
8357 set tags {}
8358 foreach id [array names tagloc] {
8359 if {![info exists hastaggeddescendent($id)]} {
8360 foreach t $tagloc($id) {
8361 if {[lsearch -exact $tags $t] < 0} {
8362 lappend tags $t
8368 # remove tags that are ancestors of other tags
8369 for {set i 0} {$i < [llength $tags]} {incr i} {
8370 set a [lindex $tags $i]
8371 for {set j 0} {$j < $i} {incr j} {
8372 set b [lindex $tags $j]
8373 set r [anc_or_desc $a $b]
8374 if {$r == -1} {
8375 set tags [lreplace $tags $j $j]
8376 incr j -1
8377 incr i -1
8378 } elseif {$r == 1} {
8379 set tags [lreplace $tags $i $i]
8380 incr i -1
8381 break
8386 if {[array names growing] ne {}} {
8387 # graph isn't finished, need to check if any tag could get
8388 # eclipsed by another tag coming later. Simply ignore any
8389 # tags that could later get eclipsed.
8390 set ctags {}
8391 foreach t $tags {
8392 if {[is_certain $origid $t]} {
8393 lappend ctags $t
8396 if {$tags eq $ctags} {
8397 set cached_atags($origid) $tags
8398 } else {
8399 set tags $ctags
8401 } else {
8402 set cached_atags($origid) $tags
8404 set t3 [clock clicks -milliseconds]
8405 if {0 && $t3 - $t1 >= 100} {
8406 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8407 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8409 return $tags
8412 # Return the list of IDs that have heads that are descendents of id,
8413 # including id itself if it has a head.
8414 proc descheads {id} {
8415 global arcnos arcstart arcids archeads idheads cached_dheads
8416 global allparents
8418 if {![info exists allparents($id)]} {
8419 return {}
8421 set aret {}
8422 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8423 # part-way along an arc; check it first
8424 set a [lindex $arcnos($id) 0]
8425 if {$archeads($a) ne {}} {
8426 validate_archeads $a
8427 set i [lsearch -exact $arcids($a) $id]
8428 foreach t $archeads($a) {
8429 set j [lsearch -exact $arcids($a) $t]
8430 if {$j > $i} break
8431 lappend aret $t
8434 set id $arcstart($a)
8436 set origid $id
8437 set todo [list $id]
8438 set seen($id) 1
8439 set ret {}
8440 for {set i 0} {$i < [llength $todo]} {incr i} {
8441 set id [lindex $todo $i]
8442 if {[info exists cached_dheads($id)]} {
8443 set ret [concat $ret $cached_dheads($id)]
8444 } else {
8445 if {[info exists idheads($id)]} {
8446 lappend ret $id
8448 foreach a $arcnos($id) {
8449 if {$archeads($a) ne {}} {
8450 validate_archeads $a
8451 if {$archeads($a) ne {}} {
8452 set ret [concat $ret $archeads($a)]
8455 set d $arcstart($a)
8456 if {![info exists seen($d)]} {
8457 lappend todo $d
8458 set seen($d) 1
8463 set ret [lsort -unique $ret]
8464 set cached_dheads($origid) $ret
8465 return [concat $ret $aret]
8468 proc addedtag {id} {
8469 global arcnos arcout cached_dtags cached_atags
8471 if {![info exists arcnos($id)]} return
8472 if {![info exists arcout($id)]} {
8473 recalcarc [lindex $arcnos($id) 0]
8475 catch {unset cached_dtags}
8476 catch {unset cached_atags}
8479 proc addedhead {hid head} {
8480 global arcnos arcout cached_dheads
8482 if {![info exists arcnos($hid)]} return
8483 if {![info exists arcout($hid)]} {
8484 recalcarc [lindex $arcnos($hid) 0]
8486 catch {unset cached_dheads}
8489 proc removedhead {hid head} {
8490 global cached_dheads
8492 catch {unset cached_dheads}
8495 proc movedhead {hid head} {
8496 global arcnos arcout cached_dheads
8498 if {![info exists arcnos($hid)]} return
8499 if {![info exists arcout($hid)]} {
8500 recalcarc [lindex $arcnos($hid) 0]
8502 catch {unset cached_dheads}
8505 proc changedrefs {} {
8506 global cached_dheads cached_dtags cached_atags
8507 global arctags archeads arcnos arcout idheads idtags
8509 foreach id [concat [array names idheads] [array names idtags]] {
8510 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8511 set a [lindex $arcnos($id) 0]
8512 if {![info exists donearc($a)]} {
8513 recalcarc $a
8514 set donearc($a) 1
8518 catch {unset cached_dtags}
8519 catch {unset cached_atags}
8520 catch {unset cached_dheads}
8523 proc rereadrefs {} {
8524 global idtags idheads idotherrefs mainheadid
8526 set refids [concat [array names idtags] \
8527 [array names idheads] [array names idotherrefs]]
8528 foreach id $refids {
8529 if {![info exists ref($id)]} {
8530 set ref($id) [listrefs $id]
8533 set oldmainhead $mainheadid
8534 readrefs
8535 changedrefs
8536 set refids [lsort -unique [concat $refids [array names idtags] \
8537 [array names idheads] [array names idotherrefs]]]
8538 foreach id $refids {
8539 set v [listrefs $id]
8540 if {![info exists ref($id)] || $ref($id) != $v ||
8541 ($id eq $oldmainhead && $id ne $mainheadid) ||
8542 ($id eq $mainheadid && $id ne $oldmainhead)} {
8543 redrawtags $id
8546 run refill_reflist
8549 proc listrefs {id} {
8550 global idtags idheads idotherrefs
8552 set x {}
8553 if {[info exists idtags($id)]} {
8554 set x $idtags($id)
8556 set y {}
8557 if {[info exists idheads($id)]} {
8558 set y $idheads($id)
8560 set z {}
8561 if {[info exists idotherrefs($id)]} {
8562 set z $idotherrefs($id)
8564 return [list $x $y $z]
8567 proc showtag {tag isnew} {
8568 global ctext tagcontents tagids linknum tagobjid
8570 if {$isnew} {
8571 addtohistory [list showtag $tag 0]
8573 $ctext conf -state normal
8574 clear_ctext
8575 settabs 0
8576 set linknum 0
8577 if {![info exists tagcontents($tag)]} {
8578 catch {
8579 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8582 if {[info exists tagcontents($tag)]} {
8583 set text $tagcontents($tag)
8584 } else {
8585 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
8587 appendwithlinks $text {}
8588 $ctext conf -state disabled
8589 init_flist {}
8592 proc doquit {} {
8593 global stopped
8594 set stopped 100
8595 savestuff .
8596 destroy .
8599 proc mkfontdisp {font top which} {
8600 global fontattr fontpref $font
8602 set fontpref($font) [set $font]
8603 button $top.${font}but -text $which -font optionfont \
8604 -command [list choosefont $font $which]
8605 label $top.$font -relief flat -font $font \
8606 -text $fontattr($font,family) -justify left
8607 grid x $top.${font}but $top.$font -sticky w
8610 proc choosefont {font which} {
8611 global fontparam fontlist fonttop fontattr
8613 set fontparam(which) $which
8614 set fontparam(font) $font
8615 set fontparam(family) [font actual $font -family]
8616 set fontparam(size) $fontattr($font,size)
8617 set fontparam(weight) $fontattr($font,weight)
8618 set fontparam(slant) $fontattr($font,slant)
8619 set top .gitkfont
8620 set fonttop $top
8621 if {![winfo exists $top]} {
8622 font create sample
8623 eval font config sample [font actual $font]
8624 toplevel $top
8625 wm title $top [mc "Gitk font chooser"]
8626 label $top.l -textvariable fontparam(which)
8627 pack $top.l -side top
8628 set fontlist [lsort [font families]]
8629 frame $top.f
8630 listbox $top.f.fam -listvariable fontlist \
8631 -yscrollcommand [list $top.f.sb set]
8632 bind $top.f.fam <<ListboxSelect>> selfontfam
8633 scrollbar $top.f.sb -command [list $top.f.fam yview]
8634 pack $top.f.sb -side right -fill y
8635 pack $top.f.fam -side left -fill both -expand 1
8636 pack $top.f -side top -fill both -expand 1
8637 frame $top.g
8638 spinbox $top.g.size -from 4 -to 40 -width 4 \
8639 -textvariable fontparam(size) \
8640 -validatecommand {string is integer -strict %s}
8641 checkbutton $top.g.bold -padx 5 \
8642 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8643 -variable fontparam(weight) -onvalue bold -offvalue normal
8644 checkbutton $top.g.ital -padx 5 \
8645 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8646 -variable fontparam(slant) -onvalue italic -offvalue roman
8647 pack $top.g.size $top.g.bold $top.g.ital -side left
8648 pack $top.g -side top
8649 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8650 -background white
8651 $top.c create text 100 25 -anchor center -text $which -font sample \
8652 -fill black -tags text
8653 bind $top.c <Configure> [list centertext $top.c]
8654 pack $top.c -side top -fill x
8655 frame $top.buts
8656 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8657 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8658 grid $top.buts.ok $top.buts.can
8659 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8660 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8661 pack $top.buts -side bottom -fill x
8662 trace add variable fontparam write chg_fontparam
8663 } else {
8664 raise $top
8665 $top.c itemconf text -text $which
8667 set i [lsearch -exact $fontlist $fontparam(family)]
8668 if {$i >= 0} {
8669 $top.f.fam selection set $i
8670 $top.f.fam see $i
8674 proc centertext {w} {
8675 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8678 proc fontok {} {
8679 global fontparam fontpref prefstop
8681 set f $fontparam(font)
8682 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8683 if {$fontparam(weight) eq "bold"} {
8684 lappend fontpref($f) "bold"
8686 if {$fontparam(slant) eq "italic"} {
8687 lappend fontpref($f) "italic"
8689 set w $prefstop.$f
8690 $w conf -text $fontparam(family) -font $fontpref($f)
8692 fontcan
8695 proc fontcan {} {
8696 global fonttop fontparam
8698 if {[info exists fonttop]} {
8699 catch {destroy $fonttop}
8700 catch {font delete sample}
8701 unset fonttop
8702 unset fontparam
8706 proc selfontfam {} {
8707 global fonttop fontparam
8709 set i [$fonttop.f.fam curselection]
8710 if {$i ne {}} {
8711 set fontparam(family) [$fonttop.f.fam get $i]
8715 proc chg_fontparam {v sub op} {
8716 global fontparam
8718 font config sample -$sub $fontparam($sub)
8721 proc doprefs {} {
8722 global maxwidth maxgraphpct
8723 global oldprefs prefstop showneartags showlocalchanges
8724 global bgcolor fgcolor ctext diffcolors selectbgcolor
8725 global tabstop limitdiffs
8727 set top .gitkprefs
8728 set prefstop $top
8729 if {[winfo exists $top]} {
8730 raise $top
8731 return
8733 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8734 limitdiffs tabstop} {
8735 set oldprefs($v) [set $v]
8737 toplevel $top
8738 wm title $top [mc "Gitk preferences"]
8739 label $top.ldisp -text [mc "Commit list display options"]
8740 grid $top.ldisp - -sticky w -pady 10
8741 label $top.spacer -text " "
8742 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8743 -font optionfont
8744 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8745 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8746 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8747 -font optionfont
8748 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8749 grid x $top.maxpctl $top.maxpct -sticky w
8750 frame $top.showlocal
8751 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8752 checkbutton $top.showlocal.b -variable showlocalchanges
8753 pack $top.showlocal.b $top.showlocal.l -side left
8754 grid x $top.showlocal -sticky w
8756 label $top.ddisp -text [mc "Diff display options"]
8757 grid $top.ddisp - -sticky w -pady 10
8758 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8759 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8760 grid x $top.tabstopl $top.tabstop -sticky w
8761 frame $top.ntag
8762 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8763 checkbutton $top.ntag.b -variable showneartags
8764 pack $top.ntag.b $top.ntag.l -side left
8765 grid x $top.ntag -sticky w
8766 frame $top.ldiff
8767 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8768 checkbutton $top.ldiff.b -variable limitdiffs
8769 pack $top.ldiff.b $top.ldiff.l -side left
8770 grid x $top.ldiff -sticky w
8772 label $top.cdisp -text [mc "Colors: press to choose"]
8773 grid $top.cdisp - -sticky w -pady 10
8774 label $top.bg -padx 40 -relief sunk -background $bgcolor
8775 button $top.bgbut -text [mc "Background"] -font optionfont \
8776 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8777 grid x $top.bgbut $top.bg -sticky w
8778 label $top.fg -padx 40 -relief sunk -background $fgcolor
8779 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8780 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8781 grid x $top.fgbut $top.fg -sticky w
8782 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8783 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8784 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8785 [list $ctext tag conf d0 -foreground]]
8786 grid x $top.diffoldbut $top.diffold -sticky w
8787 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8788 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8789 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8790 [list $ctext tag conf d1 -foreground]]
8791 grid x $top.diffnewbut $top.diffnew -sticky w
8792 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8793 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8794 -command [list choosecolor diffcolors 2 $top.hunksep \
8795 "diff hunk header" \
8796 [list $ctext tag conf hunksep -foreground]]
8797 grid x $top.hunksepbut $top.hunksep -sticky w
8798 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8799 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8800 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8801 grid x $top.selbgbut $top.selbgsep -sticky w
8803 label $top.cfont -text [mc "Fonts: press to choose"]
8804 grid $top.cfont - -sticky w -pady 10
8805 mkfontdisp mainfont $top [mc "Main font"]
8806 mkfontdisp textfont $top [mc "Diff display font"]
8807 mkfontdisp uifont $top [mc "User interface font"]
8809 frame $top.buts
8810 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8811 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8812 grid $top.buts.ok $top.buts.can
8813 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8814 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8815 grid $top.buts - - -pady 10 -sticky ew
8816 bind $top <Visibility> "focus $top.buts.ok"
8819 proc choosecolor {v vi w x cmd} {
8820 global $v
8822 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8823 -title [mc "Gitk: choose color for %s" $x]]
8824 if {$c eq {}} return
8825 $w conf -background $c
8826 lset $v $vi $c
8827 eval $cmd $c
8830 proc setselbg {c} {
8831 global bglist cflist
8832 foreach w $bglist {
8833 $w configure -selectbackground $c
8835 $cflist tag configure highlight \
8836 -background [$cflist cget -selectbackground]
8837 allcanvs itemconf secsel -fill $c
8840 proc setbg {c} {
8841 global bglist
8843 foreach w $bglist {
8844 $w conf -background $c
8848 proc setfg {c} {
8849 global fglist canv
8851 foreach w $fglist {
8852 $w conf -foreground $c
8854 allcanvs itemconf text -fill $c
8855 $canv itemconf circle -outline $c
8858 proc prefscan {} {
8859 global oldprefs prefstop
8861 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8862 limitdiffs tabstop} {
8863 global $v
8864 set $v $oldprefs($v)
8866 catch {destroy $prefstop}
8867 unset prefstop
8868 fontcan
8871 proc prefsok {} {
8872 global maxwidth maxgraphpct
8873 global oldprefs prefstop showneartags showlocalchanges
8874 global fontpref mainfont textfont uifont
8875 global limitdiffs treediffs
8877 catch {destroy $prefstop}
8878 unset prefstop
8879 fontcan
8880 set fontchanged 0
8881 if {$mainfont ne $fontpref(mainfont)} {
8882 set mainfont $fontpref(mainfont)
8883 parsefont mainfont $mainfont
8884 eval font configure mainfont [fontflags mainfont]
8885 eval font configure mainfontbold [fontflags mainfont 1]
8886 setcoords
8887 set fontchanged 1
8889 if {$textfont ne $fontpref(textfont)} {
8890 set textfont $fontpref(textfont)
8891 parsefont textfont $textfont
8892 eval font configure textfont [fontflags textfont]
8893 eval font configure textfontbold [fontflags textfont 1]
8895 if {$uifont ne $fontpref(uifont)} {
8896 set uifont $fontpref(uifont)
8897 parsefont uifont $uifont
8898 eval font configure uifont [fontflags uifont]
8900 settabs
8901 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8902 if {$showlocalchanges} {
8903 doshowlocalchanges
8904 } else {
8905 dohidelocalchanges
8908 if {$limitdiffs != $oldprefs(limitdiffs)} {
8909 # treediffs elements are limited by path
8910 catch {unset treediffs}
8912 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8913 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8914 redisplay
8915 } elseif {$showneartags != $oldprefs(showneartags) ||
8916 $limitdiffs != $oldprefs(limitdiffs)} {
8917 reselectline
8921 proc formatdate {d} {
8922 global datetimeformat
8923 if {$d ne {}} {
8924 set d [clock format $d -format $datetimeformat]
8926 return $d
8929 # This list of encoding names and aliases is distilled from
8930 # http://www.iana.org/assignments/character-sets.
8931 # Not all of them are supported by Tcl.
8932 set encoding_aliases {
8933 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8934 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8935 { ISO-10646-UTF-1 csISO10646UTF1 }
8936 { ISO_646.basic:1983 ref csISO646basic1983 }
8937 { INVARIANT csINVARIANT }
8938 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8939 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8940 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8941 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8942 { NATS-DANO iso-ir-9-1 csNATSDANO }
8943 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8944 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8945 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8946 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8947 { ISO-2022-KR csISO2022KR }
8948 { EUC-KR csEUCKR }
8949 { ISO-2022-JP csISO2022JP }
8950 { ISO-2022-JP-2 csISO2022JP2 }
8951 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8952 csISO13JISC6220jp }
8953 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8954 { IT iso-ir-15 ISO646-IT csISO15Italian }
8955 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8956 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8957 { greek7-old iso-ir-18 csISO18Greek7Old }
8958 { latin-greek iso-ir-19 csISO19LatinGreek }
8959 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8960 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8961 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8962 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8963 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8964 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8965 { INIS iso-ir-49 csISO49INIS }
8966 { INIS-8 iso-ir-50 csISO50INIS8 }
8967 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8968 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8969 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8970 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8971 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8972 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8973 csISO60Norwegian1 }
8974 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8975 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8976 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8977 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8978 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8979 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8980 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8981 { greek7 iso-ir-88 csISO88Greek7 }
8982 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8983 { iso-ir-90 csISO90 }
8984 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8985 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8986 csISO92JISC62991984b }
8987 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8988 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8989 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8990 csISO95JIS62291984handadd }
8991 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8992 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8993 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8994 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8995 CP819 csISOLatin1 }
8996 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8997 { T.61-7bit iso-ir-102 csISO102T617bit }
8998 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8999 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9000 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9001 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9002 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9003 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9004 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9005 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9006 arabic csISOLatinArabic }
9007 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9008 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9009 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9010 greek greek8 csISOLatinGreek }
9011 { T.101-G2 iso-ir-128 csISO128T101G2 }
9012 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9013 csISOLatinHebrew }
9014 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9015 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9016 { CSN_369103 iso-ir-139 csISO139CSN369103 }
9017 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9018 { ISO_6937-2-add iso-ir-142 csISOTextComm }
9019 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9020 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9021 csISOLatinCyrillic }
9022 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9023 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9024 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9025 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9026 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9027 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9028 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9029 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9030 { ISO_10367-box iso-ir-155 csISO10367Box }
9031 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9032 { latin-lap lap iso-ir-158 csISO158Lap }
9033 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9034 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9035 { us-dk csUSDK }
9036 { dk-us csDKUS }
9037 { JIS_X0201 X0201 csHalfWidthKatakana }
9038 { KSC5636 ISO646-KR csKSC5636 }
9039 { ISO-10646-UCS-2 csUnicode }
9040 { ISO-10646-UCS-4 csUCS4 }
9041 { DEC-MCS dec csDECMCS }
9042 { hp-roman8 roman8 r8 csHPRoman8 }
9043 { macintosh mac csMacintosh }
9044 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9045 csIBM037 }
9046 { IBM038 EBCDIC-INT cp038 csIBM038 }
9047 { IBM273 CP273 csIBM273 }
9048 { IBM274 EBCDIC-BE CP274 csIBM274 }
9049 { IBM275 EBCDIC-BR cp275 csIBM275 }
9050 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9051 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9052 { IBM280 CP280 ebcdic-cp-it csIBM280 }
9053 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9054 { IBM284 CP284 ebcdic-cp-es csIBM284 }
9055 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9056 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9057 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9058 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9059 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9060 { IBM424 cp424 ebcdic-cp-he csIBM424 }
9061 { IBM437 cp437 437 csPC8CodePage437 }
9062 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9063 { IBM775 cp775 csPC775Baltic }
9064 { IBM850 cp850 850 csPC850Multilingual }
9065 { IBM851 cp851 851 csIBM851 }
9066 { IBM852 cp852 852 csPCp852 }
9067 { IBM855 cp855 855 csIBM855 }
9068 { IBM857 cp857 857 csIBM857 }
9069 { IBM860 cp860 860 csIBM860 }
9070 { IBM861 cp861 861 cp-is csIBM861 }
9071 { IBM862 cp862 862 csPC862LatinHebrew }
9072 { IBM863 cp863 863 csIBM863 }
9073 { IBM864 cp864 csIBM864 }
9074 { IBM865 cp865 865 csIBM865 }
9075 { IBM866 cp866 866 csIBM866 }
9076 { IBM868 CP868 cp-ar csIBM868 }
9077 { IBM869 cp869 869 cp-gr csIBM869 }
9078 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9079 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9080 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9081 { IBM891 cp891 csIBM891 }
9082 { IBM903 cp903 csIBM903 }
9083 { IBM904 cp904 904 csIBBM904 }
9084 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9085 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9086 { IBM1026 CP1026 csIBM1026 }
9087 { EBCDIC-AT-DE csIBMEBCDICATDE }
9088 { EBCDIC-AT-DE-A csEBCDICATDEA }
9089 { EBCDIC-CA-FR csEBCDICCAFR }
9090 { EBCDIC-DK-NO csEBCDICDKNO }
9091 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9092 { EBCDIC-FI-SE csEBCDICFISE }
9093 { EBCDIC-FI-SE-A csEBCDICFISEA }
9094 { EBCDIC-FR csEBCDICFR }
9095 { EBCDIC-IT csEBCDICIT }
9096 { EBCDIC-PT csEBCDICPT }
9097 { EBCDIC-ES csEBCDICES }
9098 { EBCDIC-ES-A csEBCDICESA }
9099 { EBCDIC-ES-S csEBCDICESS }
9100 { EBCDIC-UK csEBCDICUK }
9101 { EBCDIC-US csEBCDICUS }
9102 { UNKNOWN-8BIT csUnknown8BiT }
9103 { MNEMONIC csMnemonic }
9104 { MNEM csMnem }
9105 { VISCII csVISCII }
9106 { VIQR csVIQR }
9107 { KOI8-R csKOI8R }
9108 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9109 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9110 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9111 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9112 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9113 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9114 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9115 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9116 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9117 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9118 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9119 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9120 { IBM1047 IBM-1047 }
9121 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9122 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9123 { UNICODE-1-1 csUnicode11 }
9124 { CESU-8 csCESU-8 }
9125 { BOCU-1 csBOCU-1 }
9126 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9127 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9128 l8 }
9129 { ISO-8859-15 ISO_8859-15 Latin-9 }
9130 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9131 { GBK CP936 MS936 windows-936 }
9132 { JIS_Encoding csJISEncoding }
9133 { Shift_JIS MS_Kanji csShiftJIS }
9134 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9135 EUC-JP }
9136 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9137 { ISO-10646-UCS-Basic csUnicodeASCII }
9138 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9139 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9140 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9141 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9142 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9143 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9144 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9145 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9146 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9147 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9148 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9149 { Ventura-US csVenturaUS }
9150 { Ventura-International csVenturaInternational }
9151 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9152 { PC8-Turkish csPC8Turkish }
9153 { IBM-Symbols csIBMSymbols }
9154 { IBM-Thai csIBMThai }
9155 { HP-Legal csHPLegal }
9156 { HP-Pi-font csHPPiFont }
9157 { HP-Math8 csHPMath8 }
9158 { Adobe-Symbol-Encoding csHPPSMath }
9159 { HP-DeskTop csHPDesktop }
9160 { Ventura-Math csVenturaMath }
9161 { Microsoft-Publishing csMicrosoftPublishing }
9162 { Windows-31J csWindows31J }
9163 { GB2312 csGB2312 }
9164 { Big5 csBig5 }
9167 proc tcl_encoding {enc} {
9168 global encoding_aliases
9169 set names [encoding names]
9170 set lcnames [string tolower $names]
9171 set enc [string tolower $enc]
9172 set i [lsearch -exact $lcnames $enc]
9173 if {$i < 0} {
9174 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9175 if {[regsub {^iso[-_]} $enc iso encx]} {
9176 set i [lsearch -exact $lcnames $encx]
9179 if {$i < 0} {
9180 foreach l $encoding_aliases {
9181 set ll [string tolower $l]
9182 if {[lsearch -exact $ll $enc] < 0} continue
9183 # look through the aliases for one that tcl knows about
9184 foreach e $ll {
9185 set i [lsearch -exact $lcnames $e]
9186 if {$i < 0} {
9187 if {[regsub {^iso[-_]} $e iso ex]} {
9188 set i [lsearch -exact $lcnames $ex]
9191 if {$i >= 0} break
9193 break
9196 if {$i >= 0} {
9197 return [lindex $names $i]
9199 return {}
9202 # First check that Tcl/Tk is recent enough
9203 if {[catch {package require Tk 8.4} err]} {
9204 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9205 Gitk requires at least Tcl/Tk 8.4."]
9206 exit 1
9209 # defaults...
9210 set datemode 0
9211 set wrcomcmd "git diff-tree --stdin -p --pretty"
9213 set gitencoding {}
9214 catch {
9215 set gitencoding [exec git config --get i18n.commitencoding]
9217 if {$gitencoding == ""} {
9218 set gitencoding "utf-8"
9220 set tclencoding [tcl_encoding $gitencoding]
9221 if {$tclencoding == {}} {
9222 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9225 set mainfont {Helvetica 9}
9226 set textfont {Courier 9}
9227 set uifont {Helvetica 9 bold}
9228 set tabstop 8
9229 set findmergefiles 0
9230 set maxgraphpct 50
9231 set maxwidth 16
9232 set revlistorder 0
9233 set fastdate 0
9234 set uparrowlen 5
9235 set downarrowlen 5
9236 set mingaplen 100
9237 set cmitmode "patch"
9238 set wrapcomment "none"
9239 set showneartags 1
9240 set maxrefs 20
9241 set maxlinelen 200
9242 set showlocalchanges 1
9243 set limitdiffs 1
9244 set datetimeformat "%Y-%m-%d %H:%M:%S"
9246 set colors {green red blue magenta darkgrey brown orange}
9247 set bgcolor white
9248 set fgcolor black
9249 set diffcolors {red "#00a000" blue}
9250 set diffcontext 3
9251 set ignorespace 0
9252 set selectbgcolor gray85
9254 ## For msgcat loading, first locate the installation location.
9255 if { [info exists ::env(GITK_MSGSDIR)] } {
9256 ## Msgsdir was manually set in the environment.
9257 set gitk_msgsdir $::env(GITK_MSGSDIR)
9258 } else {
9259 ## Let's guess the prefix from argv0.
9260 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9261 set gitk_libdir [file join $gitk_prefix share gitk lib]
9262 set gitk_msgsdir [file join $gitk_libdir msgs]
9263 unset gitk_prefix
9266 ## Internationalization (i18n) through msgcat and gettext. See
9267 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9268 package require msgcat
9269 namespace import ::msgcat::mc
9270 ## And eventually load the actual message catalog
9271 ::msgcat::mcload $gitk_msgsdir
9273 catch {source ~/.gitk}
9275 font create optionfont -family sans-serif -size -12
9277 parsefont mainfont $mainfont
9278 eval font create mainfont [fontflags mainfont]
9279 eval font create mainfontbold [fontflags mainfont 1]
9281 parsefont textfont $textfont
9282 eval font create textfont [fontflags textfont]
9283 eval font create textfontbold [fontflags textfont 1]
9285 parsefont uifont $uifont
9286 eval font create uifont [fontflags uifont]
9288 setoptions
9290 # check that we can find a .git directory somewhere...
9291 if {[catch {set gitdir [gitdir]}]} {
9292 show_error {} . [mc "Cannot find a git repository here."]
9293 exit 1
9295 if {![file isdirectory $gitdir]} {
9296 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9297 exit 1
9300 set mergeonly 0
9301 set revtreeargs {}
9302 set cmdline_files {}
9303 set i 0
9304 foreach arg $argv {
9305 switch -- $arg {
9306 "" { }
9307 "-d" { set datemode 1 }
9308 "--merge" {
9309 set mergeonly 1
9310 lappend revtreeargs $arg
9312 "--" {
9313 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9314 break
9316 default {
9317 lappend revtreeargs $arg
9320 incr i
9323 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9324 # no -- on command line, but some arguments (other than -d)
9325 if {[catch {
9326 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9327 set cmdline_files [split $f "\n"]
9328 set n [llength $cmdline_files]
9329 set revtreeargs [lrange $revtreeargs 0 end-$n]
9330 # Unfortunately git rev-parse doesn't produce an error when
9331 # something is both a revision and a filename. To be consistent
9332 # with git log and git rev-list, check revtreeargs for filenames.
9333 foreach arg $revtreeargs {
9334 if {[file exists $arg]} {
9335 show_error {} . [mc "Ambiguous argument '%s': both revision\
9336 and filename" $arg]
9337 exit 1
9340 } err]} {
9341 # unfortunately we get both stdout and stderr in $err,
9342 # so look for "fatal:".
9343 set i [string first "fatal:" $err]
9344 if {$i > 0} {
9345 set err [string range $err [expr {$i + 6}] end]
9347 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9348 exit 1
9352 if {$mergeonly} {
9353 # find the list of unmerged files
9354 set mlist {}
9355 set nr_unmerged 0
9356 if {[catch {
9357 set fd [open "| git ls-files -u" r]
9358 } err]} {
9359 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9360 exit 1
9362 while {[gets $fd line] >= 0} {
9363 set i [string first "\t" $line]
9364 if {$i < 0} continue
9365 set fname [string range $line [expr {$i+1}] end]
9366 if {[lsearch -exact $mlist $fname] >= 0} continue
9367 incr nr_unmerged
9368 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9369 lappend mlist $fname
9372 catch {close $fd}
9373 if {$mlist eq {}} {
9374 if {$nr_unmerged == 0} {
9375 show_error {} . [mc "No files selected: --merge specified but\
9376 no files are unmerged."]
9377 } else {
9378 show_error {} . [mc "No files selected: --merge specified but\
9379 no unmerged files are within file limit."]
9381 exit 1
9383 set cmdline_files $mlist
9386 set nullid "0000000000000000000000000000000000000000"
9387 set nullid2 "0000000000000000000000000000000000000001"
9389 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9391 set runq {}
9392 set history {}
9393 set historyindex 0
9394 set fh_serial 0
9395 set nhl_names {}
9396 set highlight_paths {}
9397 set findpattern {}
9398 set searchdirn -forwards
9399 set boldrows {}
9400 set boldnamerows {}
9401 set diffelide {0 0}
9402 set markingmatches 0
9403 set linkentercount 0
9404 set need_redisplay 0
9405 set nrows_drawn 0
9406 set firsttabstop 0
9408 set nextviewnum 1
9409 set curview 0
9410 set selectedview 0
9411 set selectedhlview [mc "None"]
9412 set highlight_related [mc "None"]
9413 set highlight_files {}
9414 set viewfiles(0) {}
9415 set viewperm(0) 0
9416 set viewargs(0) {}
9418 set loginstance 0
9419 set cmdlineok 0
9420 set stopped 0
9421 set stuffsaved 0
9422 set patchnum 0
9423 set lserial 0
9424 setcoords
9425 makewindow
9426 # wait for the window to become visible
9427 tkwait visibility .
9428 wm title . "[file tail $argv0]: [file tail [pwd]]"
9429 readrefs
9431 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9432 # create a view for the files/dirs specified on the command line
9433 set curview 1
9434 set selectedview 1
9435 set nextviewnum 2
9436 set viewname(1) [mc "Command line"]
9437 set viewfiles(1) $cmdline_files
9438 set viewargs(1) $revtreeargs
9439 set viewperm(1) 0
9440 addviewmenu 1
9441 .bar.view entryconf [mc "Edit view..."] -state normal
9442 .bar.view entryconf [mc "Delete view"] -state normal
9445 if {[info exists permviews]} {
9446 foreach v $permviews {
9447 set n $nextviewnum
9448 incr nextviewnum
9449 set viewname($n) [lindex $v 0]
9450 set viewfiles($n) [lindex $v 1]
9451 set viewargs($n) [lindex $v 2]
9452 set viewperm($n) 1
9453 addviewmenu $n
9456 getcommits