gitk: Fix potential bug with fake commit IDs in renumbervarc
[alt-git.git] / gitk
blobfda06186b4dcf7d42560cd1ac6cf25d06e295925
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq
43 fileevent $fd readable {}
44 if {$runq eq {}} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc nukefile {fd} {
51 global runq
53 for {set i 0} {$i < [llength $runq]} {} {
54 if {[lindex $runq $i 0] eq $fd} {
55 set runq [lreplace $runq $i $i]
56 } else {
57 incr i
62 proc dorunq {} {
63 global isonrunq runq
65 set tstart [clock clicks -milliseconds]
66 set t0 $tstart
67 while {[llength $runq] > 0} {
68 set fd [lindex $runq 0 0]
69 set script [lindex $runq 0 1]
70 set repeat [eval $script]
71 set t1 [clock clicks -milliseconds]
72 set t [expr {$t1 - $t0}]
73 set runq [lrange $runq 1 end]
74 if {$repeat ne {} && $repeat} {
75 if {$fd eq {} || $repeat == 2} {
76 # script returns 1 if it wants to be readded
77 # file readers return 2 if they could do more straight away
78 lappend runq [list $fd $script]
79 } else {
80 fileevent $fd readable [list filereadable $fd $script]
82 } elseif {$fd eq {}} {
83 unset isonrunq($script)
85 set t0 $t1
86 if {$t1 - $tstart >= 80} break
88 if {$runq ne {}} {
89 after idle dorunq
93 # Start off a git rev-list process and arrange to read its output
94 proc start_rev_list {view} {
95 global startmsecs
96 global commfd leftover tclencoding datemode
97 global viewargs viewfiles commitidx viewcomplete vnextroot
98 global showlocalchanges commitinterest mainheadid
99 global progressdirn progresscoords proglastnc curview
100 global viewincl viewactive loginstance viewinstances
102 set startmsecs [clock clicks -milliseconds]
103 set commitidx($view) 0
104 set viewcomplete($view) 0
105 set viewactive($view) 1
106 set vnextroot($view) 0
107 varcinit $view
109 set commits [eval exec git rev-parse --default HEAD --revs-only \
110 $viewargs($view)]
111 set viewincl($view) {}
112 foreach c $commits {
113 if {![string match "^*" $c]} {
114 lappend viewincl($view) $c
117 if {[catch {
118 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
119 --boundary $commits "--" $viewfiles($view)] r]
120 } err]} {
121 error_popup "[mc "Error executing git log:"] $err"
122 exit 1
124 set i [incr loginstance]
125 set viewinstances($view) [list $i]
126 set commfd($i) $fd
127 set leftover($i) {}
128 if {$showlocalchanges} {
129 lappend commitinterest($mainheadid) {dodiffindex}
131 fconfigure $fd -blocking 0 -translation lf -eofchar {}
132 if {$tclencoding != {}} {
133 fconfigure $fd -encoding $tclencoding
135 filerun $fd [list getcommitlines $fd $i $view]
136 nowbusy $view [mc "Reading"]
137 if {$view == $curview} {
138 set progressdirn 1
139 set progresscoords {0 0}
140 set proglastnc 0
144 proc stop_rev_list {view} {
145 global commfd viewinstances leftover
147 foreach inst $viewinstances($view) {
148 set fd $commfd($inst)
149 catch {
150 set pid [pid $fd]
151 exec kill $pid
153 catch {close $fd}
154 nukefile $fd
155 unset commfd($inst)
156 unset leftover($inst)
158 set viewinstances($view) {}
161 proc getcommits {} {
162 global canv curview
164 initlayout
165 start_rev_list $curview
166 show_status [mc "Reading commits..."]
169 proc updatecommits {} {
170 global curview viewargs viewfiles viewincl viewinstances
171 global viewactive viewcomplete loginstance tclencoding mainheadid
172 global varcid startmsecs commfd showneartags showlocalchanges leftover
173 global mainheadid
175 set oldmainid $mainheadid
176 rereadrefs
177 if {$showlocalchanges} {
178 if {$mainheadid ne $oldmainid} {
179 dohidelocalchanges
181 if {[commitinview $mainheadid $curview]} {
182 dodiffindex
185 set view $curview
186 set commits [exec git rev-parse --default HEAD --revs-only \
187 $viewargs($view)]
188 set pos {}
189 set neg {}
190 foreach c $commits {
191 if {[string match "^*" $c]} {
192 lappend neg $c
193 } else {
194 if {!([info exists varcid($view,$c)] ||
195 [lsearch -exact $viewincl($view) $c] >= 0)} {
196 lappend pos $c
200 if {$pos eq {}} {
201 return
203 foreach id $viewincl($view) {
204 lappend neg "^$id"
206 set viewincl($view) [concat $viewincl($view) $pos]
207 if {[catch {
208 set fd [open [concat | git log --no-color -z --pretty=raw --parents \
209 --boundary $pos $neg "--" $viewfiles($view)] r]
210 } err]} {
211 error_popup "Error executing git log: $err"
212 exit 1
214 if {$viewactive($view) == 0} {
215 set startmsecs [clock clicks -milliseconds]
217 set i [incr loginstance]
218 lappend viewinstances($view) $i
219 set commfd($i) $fd
220 set leftover($i) {}
221 fconfigure $fd -blocking 0 -translation lf -eofchar {}
222 if {$tclencoding != {}} {
223 fconfigure $fd -encoding $tclencoding
225 filerun $fd [list getcommitlines $fd $i $view]
226 incr viewactive($view)
227 set viewcomplete($view) 0
228 nowbusy $view "Reading"
229 if {$showneartags} {
230 getallcommits
234 proc reloadcommits {} {
235 global curview viewcomplete selectedline currentid thickerline
236 global showneartags treediffs commitinterest cached_commitrow
237 global progresscoords targetid
239 if {!$viewcomplete($curview)} {
240 stop_rev_list $curview
241 set progresscoords {0 0}
242 adjustprogress
244 resetvarcs $curview
245 catch {unset selectedline}
246 catch {unset currentid}
247 catch {unset thickerline}
248 catch {unset treediffs}
249 readrefs
250 changedrefs
251 if {$showneartags} {
252 getallcommits
254 clear_display
255 catch {unset commitinterest}
256 catch {unset cached_commitrow}
257 catch {unset targetid}
258 setcanvscroll
259 getcommits
262 # This makes a string representation of a positive integer which
263 # sorts as a string in numerical order
264 proc strrep {n} {
265 if {$n < 16} {
266 return [format "%x" $n]
267 } elseif {$n < 256} {
268 return [format "x%.2x" $n]
269 } elseif {$n < 65536} {
270 return [format "y%.4x" $n]
272 return [format "z%.8x" $n]
275 # Procedures used in reordering commits from git log (without
276 # --topo-order) into the order for display.
278 proc varcinit {view} {
279 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
280 global vtokmod varcmod vrowmod varcix vlastins
282 set varcstart($view) {{}}
283 set vupptr($view) {0}
284 set vdownptr($view) {0}
285 set vleftptr($view) {0}
286 set vbackptr($view) {0}
287 set varctok($view) {{}}
288 set varcrow($view) {{}}
289 set vtokmod($view) {}
290 set varcmod($view) 0
291 set vrowmod($view) 0
292 set varcix($view) {{}}
293 set vlastins($view) {0}
296 proc resetvarcs {view} {
297 global varcid varccommits parents children vseedcount ordertok
299 foreach vid [array names varcid $view,*] {
300 unset varcid($vid)
301 unset children($vid)
302 unset parents($vid)
304 # some commits might have children but haven't been seen yet
305 foreach vid [array names children $view,*] {
306 unset children($vid)
308 foreach va [array names varccommits $view,*] {
309 unset varccommits($va)
311 foreach vd [array names vseedcount $view,*] {
312 unset vseedcount($vd)
314 catch {unset ordertok}
317 proc newvarc {view id} {
318 global varcid varctok parents children datemode
319 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
320 global commitdata commitinfo vseedcount varccommits vlastins
322 set a [llength $varctok($view)]
323 set vid $view,$id
324 if {[llength $children($vid)] == 0 || $datemode} {
325 if {![info exists commitinfo($id)]} {
326 parsecommit $id $commitdata($id) 1
328 set cdate [lindex $commitinfo($id) 4]
329 if {![string is integer -strict $cdate]} {
330 set cdate 0
332 if {![info exists vseedcount($view,$cdate)]} {
333 set vseedcount($view,$cdate) -1
335 set c [incr vseedcount($view,$cdate)]
336 set cdate [expr {$cdate ^ 0xffffffff}]
337 set tok "s[strrep $cdate][strrep $c]"
338 } else {
339 set tok {}
341 set ka 0
342 if {[llength $children($vid)] > 0} {
343 set kid [lindex $children($vid) end]
344 set k $varcid($view,$kid)
345 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
346 set ki $kid
347 set ka $k
348 set tok [lindex $varctok($view) $k]
351 if {$ka != 0} {
352 set i [lsearch -exact $parents($view,$ki) $id]
353 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
354 append tok [strrep $j]
356 set c [lindex $vlastins($view) $ka]
357 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
358 set c $ka
359 set b [lindex $vdownptr($view) $ka]
360 } else {
361 set b [lindex $vleftptr($view) $c]
363 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
364 set c $b
365 set b [lindex $vleftptr($view) $c]
367 if {$c == $ka} {
368 lset vdownptr($view) $ka $a
369 lappend vbackptr($view) 0
370 } else {
371 lset vleftptr($view) $c $a
372 lappend vbackptr($view) $c
374 lset vlastins($view) $ka $a
375 lappend vupptr($view) $ka
376 lappend vleftptr($view) $b
377 if {$b != 0} {
378 lset vbackptr($view) $b $a
380 lappend varctok($view) $tok
381 lappend varcstart($view) $id
382 lappend vdownptr($view) 0
383 lappend varcrow($view) {}
384 lappend varcix($view) {}
385 set varccommits($view,$a) {}
386 lappend vlastins($view) 0
387 return $a
390 proc splitvarc {p v} {
391 global varcid varcstart varccommits varctok
392 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
394 set oa $varcid($v,$p)
395 set ac $varccommits($v,$oa)
396 set i [lsearch -exact $varccommits($v,$oa) $p]
397 if {$i <= 0} return
398 set na [llength $varctok($v)]
399 # "%" sorts before "0"...
400 set tok "[lindex $varctok($v) $oa]%[strrep $i]"
401 lappend varctok($v) $tok
402 lappend varcrow($v) {}
403 lappend varcix($v) {}
404 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
405 set varccommits($v,$na) [lrange $ac $i end]
406 lappend varcstart($v) $p
407 foreach id $varccommits($v,$na) {
408 set varcid($v,$id) $na
410 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
411 lset vdownptr($v) $oa $na
412 lappend vupptr($v) $oa
413 lappend vleftptr($v) 0
414 lappend vbackptr($v) 0
415 lappend vlastins($v) 0
416 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
417 lset vupptr($v) $b $na
421 proc renumbervarc {a v} {
422 global parents children varctok varcstart varccommits
423 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod datemode
425 set t1 [clock clicks -milliseconds]
426 set todo {}
427 set isrelated($a) 1
428 set kidchanged($a) 1
429 set ntot 0
430 while {$a != 0} {
431 if {[info exists isrelated($a)]} {
432 lappend todo $a
433 set id [lindex $varccommits($v,$a) end]
434 foreach p $parents($v,$id) {
435 if {[info exists varcid($v,$p)]} {
436 set isrelated($varcid($v,$p)) 1
440 incr ntot
441 set b [lindex $vdownptr($v) $a]
442 if {$b == 0} {
443 while {$a != 0} {
444 set b [lindex $vleftptr($v) $a]
445 if {$b != 0} break
446 set a [lindex $vupptr($v) $a]
449 set a $b
451 foreach a $todo {
452 if {![info exists kidchanged($a)]} continue
453 set id [lindex $varcstart($v) $a]
454 if {[llength $children($v,$id)] > 1} {
455 set children($v,$id) [lsort -command [list vtokcmp $v] \
456 $children($v,$id)]
458 set oldtok [lindex $varctok($v) $a]
459 if {!$datemode} {
460 set tok {}
461 } else {
462 set tok $oldtok
464 set ka 0
465 set kid [last_real_child $v,$id]
466 if {$kid ne {}} {
467 set k $varcid($v,$kid)
468 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
469 set ki $kid
470 set ka $k
471 set tok [lindex $varctok($v) $k]
474 if {$ka != 0} {
475 set i [lsearch -exact $parents($v,$ki) $id]
476 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
477 append tok [strrep $j]
479 if {$tok eq $oldtok} {
480 continue
482 set id [lindex $varccommits($v,$a) end]
483 foreach p $parents($v,$id) {
484 if {[info exists varcid($v,$p)]} {
485 set kidchanged($varcid($v,$p)) 1
486 } else {
487 set sortkids($p) 1
490 lset varctok($v) $a $tok
491 set b [lindex $vupptr($v) $a]
492 if {$b != $ka} {
493 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
494 modify_arc $v $ka
496 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
497 modify_arc $v $b
499 set c [lindex $vbackptr($v) $a]
500 set d [lindex $vleftptr($v) $a]
501 if {$c == 0} {
502 lset vdownptr($v) $b $d
503 } else {
504 lset vleftptr($v) $c $d
506 if {$d != 0} {
507 lset vbackptr($v) $d $c
509 lset vupptr($v) $a $ka
510 set c [lindex $vlastins($v) $ka]
511 if {$c == 0 || \
512 [string compare $tok [lindex $varctok($v) $c]] < 0} {
513 set c $ka
514 set b [lindex $vdownptr($v) $ka]
515 } else {
516 set b [lindex $vleftptr($v) $c]
518 while {$b != 0 && \
519 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
520 set c $b
521 set b [lindex $vleftptr($v) $c]
523 if {$c == $ka} {
524 lset vdownptr($v) $ka $a
525 lset vbackptr($v) $a 0
526 } else {
527 lset vleftptr($v) $c $a
528 lset vbackptr($v) $a $c
530 lset vleftptr($v) $a $b
531 if {$b != 0} {
532 lset vbackptr($v) $b $a
534 lset vlastins($v) $ka $a
537 foreach id [array names sortkids] {
538 if {[llength $children($v,$id)] > 1} {
539 set children($v,$id) [lsort -command [list vtokcmp $v] \
540 $children($v,$id)]
543 set t2 [clock clicks -milliseconds]
544 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
547 proc fix_reversal {p a v} {
548 global varcid varcstart varctok vupptr
550 set pa $varcid($v,$p)
551 if {$p ne [lindex $varcstart($v) $pa]} {
552 splitvarc $p $v
553 set pa $varcid($v,$p)
555 # seeds always need to be renumbered
556 if {[lindex $vupptr($v) $pa] == 0 ||
557 [string compare [lindex $varctok($v) $a] \
558 [lindex $varctok($v) $pa]] > 0} {
559 renumbervarc $pa $v
563 proc insertrow {id p v} {
564 global varcid varccommits parents children cmitlisted
565 global commitidx varctok vtokmod targetid targetrow
567 set a $varcid($v,$p)
568 set i [lsearch -exact $varccommits($v,$a) $p]
569 if {$i < 0} {
570 puts "oops: insertrow can't find [shortids $p] on arc $a"
571 return
573 set children($v,$id) {}
574 set parents($v,$id) [list $p]
575 set varcid($v,$id) $a
576 lappend children($v,$p) $id
577 set cmitlisted($v,$id) 1
578 incr commitidx($v)
579 # note we deliberately don't update varcstart($v) even if $i == 0
580 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
581 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
582 modify_arc $v $a $i
584 if {[info exists targetid]} {
585 if {![comes_before $targetid $p]} {
586 incr targetrow
589 drawvisible
592 proc removerow {id v} {
593 global varcid varccommits parents children commitidx
594 global varctok vtokmod cmitlisted currentid selectedline
595 global targetid
597 if {[llength $parents($v,$id)] != 1} {
598 puts "oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
599 return
601 set p [lindex $parents($v,$id) 0]
602 set a $varcid($v,$id)
603 set i [lsearch -exact $varccommits($v,$a) $id]
604 if {$i < 0} {
605 puts "oops: removerow can't find [shortids $id] on arc $a"
606 return
608 unset varcid($v,$id)
609 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
610 unset parents($v,$id)
611 unset children($v,$id)
612 unset cmitlisted($v,$id)
613 incr commitidx($v) -1
614 set j [lsearch -exact $children($v,$p) $id]
615 if {$j >= 0} {
616 set children($v,$p) [lreplace $children($v,$p) $j $j]
618 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
619 modify_arc $v $a $i
621 if {[info exist currentid] && $id eq $currentid} {
622 unset currentid
623 unset selectedline
625 if {[info exists targetid] && $targetid eq $id} {
626 set targetid $p
628 drawvisible
631 proc first_real_child {vp} {
632 global children nullid nullid2
634 foreach id $children($vp) {
635 if {$id ne $nullid && $id ne $nullid2} {
636 return $id
639 return {}
642 proc last_real_child {vp} {
643 global children nullid nullid2
645 set kids $children($vp)
646 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
647 set id [lindex $kids $i]
648 if {$id ne $nullid && $id ne $nullid2} {
649 return $id
652 return {}
655 proc vtokcmp {v a b} {
656 global varctok varcid
658 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
659 [lindex $varctok($v) $varcid($v,$b)]]
662 proc modify_arc {v a {lim {}}} {
663 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
664 global vhighlights nhighlights fhighlights rhighlights
666 set vtokmod($v) [lindex $varctok($v) $a]
667 set varcmod($v) $a
668 if {$v == $curview} {
669 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
670 set a [lindex $vupptr($v) $a]
671 set lim {}
673 set r 0
674 if {$a != 0} {
675 if {$lim eq {}} {
676 set lim [llength $varccommits($v,$a)]
678 set r [expr {[lindex $varcrow($v) $a] + $lim}]
680 set vrowmod($v) $r
681 undolayout $r
683 catch {unset nhighlights}
684 catch {unset fhighlights}
685 catch {unset vhighlights}
686 catch {unset rhighlights}
689 proc update_arcrows {v} {
690 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
691 global varcid vrownum varcorder varcix varccommits
692 global vupptr vdownptr vleftptr varctok
693 global displayorder parentlist curview cached_commitrow
695 set narctot [expr {[llength $varctok($v)] - 1}]
696 set a $varcmod($v)
697 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
698 # go up the tree until we find something that has a row number,
699 # or we get to a seed
700 set a [lindex $vupptr($v) $a]
702 if {$a == 0} {
703 set a [lindex $vdownptr($v) 0]
704 if {$a == 0} return
705 set vrownum($v) {0}
706 set varcorder($v) [list $a]
707 lset varcix($v) $a 0
708 lset varcrow($v) $a 0
709 set arcn 0
710 set row 0
711 } else {
712 set arcn [lindex $varcix($v) $a]
713 # see if a is the last arc; if so, nothing to do
714 if {$arcn == $narctot - 1} {
715 return
717 if {[llength $vrownum($v)] > $arcn + 1} {
718 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
719 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
721 set row [lindex $varcrow($v) $a]
723 if {$v == $curview} {
724 if {[llength $displayorder] > $vrowmod($v)} {
725 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
726 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
728 catch {unset cached_commitrow}
730 while {1} {
731 set p $a
732 incr row [llength $varccommits($v,$a)]
733 # go down if possible
734 set b [lindex $vdownptr($v) $a]
735 if {$b == 0} {
736 # if not, go left, or go up until we can go left
737 while {$a != 0} {
738 set b [lindex $vleftptr($v) $a]
739 if {$b != 0} break
740 set a [lindex $vupptr($v) $a]
742 if {$a == 0} break
744 set a $b
745 incr arcn
746 lappend vrownum($v) $row
747 lappend varcorder($v) $a
748 lset varcix($v) $a $arcn
749 lset varcrow($v) $a $row
751 set vtokmod($v) [lindex $varctok($v) $p]
752 set varcmod($v) $p
753 set vrowmod($v) $row
754 if {[info exists currentid]} {
755 set selectedline [rowofcommit $currentid]
759 # Test whether view $v contains commit $id
760 proc commitinview {id v} {
761 global varcid
763 return [info exists varcid($v,$id)]
766 # Return the row number for commit $id in the current view
767 proc rowofcommit {id} {
768 global varcid varccommits varcrow curview cached_commitrow
769 global varctok vtokmod
771 set v $curview
772 if {![info exists varcid($v,$id)]} {
773 puts "oops rowofcommit no arc for [shortids $id]"
774 return {}
776 set a $varcid($v,$id)
777 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
778 update_arcrows $v
780 if {[info exists cached_commitrow($id)]} {
781 return $cached_commitrow($id)
783 set i [lsearch -exact $varccommits($v,$a) $id]
784 if {$i < 0} {
785 puts "oops didn't find commit [shortids $id] in arc $a"
786 return {}
788 incr i [lindex $varcrow($v) $a]
789 set cached_commitrow($id) $i
790 return $i
793 # Returns 1 if a is on an earlier row than b, otherwise 0
794 proc comes_before {a b} {
795 global varcid varctok curview
797 set v $curview
798 if {$a eq $b || ![info exists varcid($v,$a)] || \
799 ![info exists varcid($v,$b)]} {
800 return 0
802 if {$varcid($v,$a) != $varcid($v,$b)} {
803 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
804 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
806 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
809 proc bsearch {l elt} {
810 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
811 return 0
813 set lo 0
814 set hi [llength $l]
815 while {$hi - $lo > 1} {
816 set mid [expr {int(($lo + $hi) / 2)}]
817 set t [lindex $l $mid]
818 if {$elt < $t} {
819 set hi $mid
820 } elseif {$elt > $t} {
821 set lo $mid
822 } else {
823 return $mid
826 return $lo
829 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
830 proc make_disporder {start end} {
831 global vrownum curview commitidx displayorder parentlist
832 global varccommits varcorder parents vrowmod varcrow
833 global d_valid_start d_valid_end
835 if {$end > $vrowmod($curview)} {
836 update_arcrows $curview
838 set ai [bsearch $vrownum($curview) $start]
839 set start [lindex $vrownum($curview) $ai]
840 set narc [llength $vrownum($curview)]
841 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
842 set a [lindex $varcorder($curview) $ai]
843 set l [llength $displayorder]
844 set al [llength $varccommits($curview,$a)]
845 if {$l < $r + $al} {
846 if {$l < $r} {
847 set pad [ntimes [expr {$r - $l}] {}]
848 set displayorder [concat $displayorder $pad]
849 set parentlist [concat $parentlist $pad]
850 } elseif {$l > $r} {
851 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
852 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
854 foreach id $varccommits($curview,$a) {
855 lappend displayorder $id
856 lappend parentlist $parents($curview,$id)
858 } elseif {[lindex $displayorder $r] eq {}} {
859 set i $r
860 foreach id $varccommits($curview,$a) {
861 lset displayorder $i $id
862 lset parentlist $i $parents($curview,$id)
863 incr i
866 incr r $al
870 proc commitonrow {row} {
871 global displayorder
873 set id [lindex $displayorder $row]
874 if {$id eq {}} {
875 make_disporder $row [expr {$row + 1}]
876 set id [lindex $displayorder $row]
878 return $id
881 proc closevarcs {v} {
882 global varctok varccommits varcid parents children
883 global cmitlisted commitidx commitinterest vtokmod
885 set missing_parents 0
886 set scripts {}
887 set narcs [llength $varctok($v)]
888 for {set a 1} {$a < $narcs} {incr a} {
889 set id [lindex $varccommits($v,$a) end]
890 foreach p $parents($v,$id) {
891 if {[info exists varcid($v,$p)]} continue
892 # add p as a new commit
893 incr missing_parents
894 set cmitlisted($v,$p) 0
895 set parents($v,$p) {}
896 if {[llength $children($v,$p)] == 1 &&
897 [llength $parents($v,$id)] == 1} {
898 set b $a
899 } else {
900 set b [newvarc $v $p]
902 set varcid($v,$p) $b
903 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
904 modify_arc $v $b
906 lappend varccommits($v,$b) $p
907 incr commitidx($v)
908 if {[info exists commitinterest($p)]} {
909 foreach script $commitinterest($p) {
910 lappend scripts [string map [list "%I" $p] $script]
912 unset commitinterest($id)
916 if {$missing_parents > 0} {
917 foreach s $scripts {
918 eval $s
923 proc getcommitlines {fd inst view} {
924 global cmitlisted commitinterest leftover
925 global commitidx commitdata datemode
926 global parents children curview hlview
927 global vnextroot idpending ordertok
928 global varccommits varcid varctok vtokmod
930 set stuff [read $fd 500000]
931 # git log doesn't terminate the last commit with a null...
932 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
933 set stuff "\0"
935 if {$stuff == {}} {
936 if {![eof $fd]} {
937 return 1
939 global commfd viewcomplete viewactive viewname progresscoords
940 global viewinstances
941 unset commfd($inst)
942 set i [lsearch -exact $viewinstances($view) $inst]
943 if {$i >= 0} {
944 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
946 # set it blocking so we wait for the process to terminate
947 fconfigure $fd -blocking 1
948 if {[catch {close $fd} err]} {
949 set fv {}
950 if {$view != $curview} {
951 set fv " for the \"$viewname($view)\" view"
953 if {[string range $err 0 4] == "usage"} {
954 set err "Gitk: error reading commits$fv:\
955 bad arguments to git rev-list."
956 if {$viewname($view) eq "Command line"} {
957 append err \
958 " (Note: arguments to gitk are passed to git rev-list\
959 to allow selection of commits to be displayed.)"
961 } else {
962 set err "Error reading commits$fv: $err"
964 error_popup $err
966 if {[incr viewactive($view) -1] <= 0} {
967 set viewcomplete($view) 1
968 # Check if we have seen any ids listed as parents that haven't
969 # appeared in the list
970 closevarcs $view
971 notbusy $view
972 set progresscoords {0 0}
973 adjustprogress
975 if {$view == $curview} {
976 run chewcommits $view
978 return 0
980 set start 0
981 set gotsome 0
982 set scripts {}
983 while 1 {
984 set i [string first "\0" $stuff $start]
985 if {$i < 0} {
986 append leftover($inst) [string range $stuff $start end]
987 break
989 if {$start == 0} {
990 set cmit $leftover($inst)
991 append cmit [string range $stuff 0 [expr {$i - 1}]]
992 set leftover($inst) {}
993 } else {
994 set cmit [string range $stuff $start [expr {$i - 1}]]
996 set start [expr {$i + 1}]
997 set j [string first "\n" $cmit]
998 set ok 0
999 set listed 1
1000 if {$j >= 0 && [string match "commit *" $cmit]} {
1001 set ids [string range $cmit 7 [expr {$j - 1}]]
1002 if {[string match {[-<>]*} $ids]} {
1003 switch -- [string index $ids 0] {
1004 "-" {set listed 0}
1005 "<" {set listed 2}
1006 ">" {set listed 3}
1008 set ids [string range $ids 1 end]
1010 set ok 1
1011 foreach id $ids {
1012 if {[string length $id] != 40} {
1013 set ok 0
1014 break
1018 if {!$ok} {
1019 set shortcmit $cmit
1020 if {[string length $shortcmit] > 80} {
1021 set shortcmit "[string range $shortcmit 0 80]..."
1023 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1024 exit 1
1026 set id [lindex $ids 0]
1027 set vid $view,$id
1028 if {!$listed && [info exists parents($vid)]} continue
1029 if {$listed} {
1030 set olds [lrange $ids 1 end]
1031 } else {
1032 set olds {}
1034 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1035 set cmitlisted($vid) $listed
1036 set parents($vid) $olds
1037 set a 0
1038 if {![info exists children($vid)]} {
1039 set children($vid) {}
1040 } elseif {[llength $children($vid)] == 1} {
1041 set k [lindex $children($vid) 0]
1042 if {[llength $parents($view,$k)] == 1 &&
1043 (!$datemode ||
1044 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1045 set a $varcid($view,$k)
1048 if {$a == 0} {
1049 # new arc
1050 set a [newvarc $view $id]
1052 set varcid($vid) $a
1053 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1054 modify_arc $view $a
1056 lappend varccommits($view,$a) $id
1058 set i 0
1059 foreach p $olds {
1060 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1061 set vp $view,$p
1062 if {[llength [lappend children($vp) $id]] > 1 &&
1063 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1064 set children($vp) [lsort -command [list vtokcmp $view] \
1065 $children($vp)]
1066 catch {unset ordertok}
1068 if {[info exists varcid($view,$p)]} {
1069 fix_reversal $p $a $view
1072 incr i
1075 incr commitidx($view)
1076 if {[info exists commitinterest($id)]} {
1077 foreach script $commitinterest($id) {
1078 lappend scripts [string map [list "%I" $id] $script]
1080 unset commitinterest($id)
1082 set gotsome 1
1084 if {$gotsome} {
1085 run chewcommits $view
1086 foreach s $scripts {
1087 eval $s
1089 if {$view == $curview} {
1090 # update progress bar
1091 global progressdirn progresscoords proglastnc
1092 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1093 set proglastnc $commitidx($view)
1094 set l [lindex $progresscoords 0]
1095 set r [lindex $progresscoords 1]
1096 if {$progressdirn} {
1097 set r [expr {$r + $inc}]
1098 if {$r >= 1.0} {
1099 set r 1.0
1100 set progressdirn 0
1102 if {$r > 0.2} {
1103 set l [expr {$r - 0.2}]
1105 } else {
1106 set l [expr {$l - $inc}]
1107 if {$l <= 0.0} {
1108 set l 0.0
1109 set progressdirn 1
1111 set r [expr {$l + 0.2}]
1113 set progresscoords [list $l $r]
1114 adjustprogress
1117 return 2
1120 proc chewcommits {view} {
1121 global curview hlview viewcomplete
1122 global pending_select
1124 if {$view == $curview} {
1125 layoutmore
1126 if {$viewcomplete($view)} {
1127 global commitidx varctok
1128 global numcommits startmsecs
1129 global mainheadid commitinfo nullid
1131 if {[info exists pending_select]} {
1132 set row [first_real_row]
1133 selectline $row 1
1135 if {$commitidx($curview) > 0} {
1136 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1137 #puts "overall $ms ms for $numcommits commits"
1138 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1139 } else {
1140 show_status [mc "No commits selected"]
1142 notbusy layout
1145 if {[info exists hlview] && $view == $hlview} {
1146 vhighlightmore
1148 return 0
1151 proc readcommit {id} {
1152 if {[catch {set contents [exec git cat-file commit $id]}]} return
1153 parsecommit $id $contents 0
1156 proc parsecommit {id contents listed} {
1157 global commitinfo cdate
1159 set inhdr 1
1160 set comment {}
1161 set headline {}
1162 set auname {}
1163 set audate {}
1164 set comname {}
1165 set comdate {}
1166 set hdrend [string first "\n\n" $contents]
1167 if {$hdrend < 0} {
1168 # should never happen...
1169 set hdrend [string length $contents]
1171 set header [string range $contents 0 [expr {$hdrend - 1}]]
1172 set comment [string range $contents [expr {$hdrend + 2}] end]
1173 foreach line [split $header "\n"] {
1174 set tag [lindex $line 0]
1175 if {$tag == "author"} {
1176 set audate [lindex $line end-1]
1177 set auname [lrange $line 1 end-2]
1178 } elseif {$tag == "committer"} {
1179 set comdate [lindex $line end-1]
1180 set comname [lrange $line 1 end-2]
1183 set headline {}
1184 # take the first non-blank line of the comment as the headline
1185 set headline [string trimleft $comment]
1186 set i [string first "\n" $headline]
1187 if {$i >= 0} {
1188 set headline [string range $headline 0 $i]
1190 set headline [string trimright $headline]
1191 set i [string first "\r" $headline]
1192 if {$i >= 0} {
1193 set headline [string trimright [string range $headline 0 $i]]
1195 if {!$listed} {
1196 # git rev-list indents the comment by 4 spaces;
1197 # if we got this via git cat-file, add the indentation
1198 set newcomment {}
1199 foreach line [split $comment "\n"] {
1200 append newcomment " "
1201 append newcomment $line
1202 append newcomment "\n"
1204 set comment $newcomment
1206 if {$comdate != {}} {
1207 set cdate($id) $comdate
1209 set commitinfo($id) [list $headline $auname $audate \
1210 $comname $comdate $comment]
1213 proc getcommit {id} {
1214 global commitdata commitinfo
1216 if {[info exists commitdata($id)]} {
1217 parsecommit $id $commitdata($id) 1
1218 } else {
1219 readcommit $id
1220 if {![info exists commitinfo($id)]} {
1221 set commitinfo($id) [list [mc "No commit information available"]]
1224 return 1
1227 proc readrefs {} {
1228 global tagids idtags headids idheads tagobjid
1229 global otherrefids idotherrefs mainhead mainheadid
1231 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1232 catch {unset $v}
1234 set refd [open [list | git show-ref -d] r]
1235 while {[gets $refd line] >= 0} {
1236 if {[string index $line 40] ne " "} continue
1237 set id [string range $line 0 39]
1238 set ref [string range $line 41 end]
1239 if {![string match "refs/*" $ref]} continue
1240 set name [string range $ref 5 end]
1241 if {[string match "remotes/*" $name]} {
1242 if {![string match "*/HEAD" $name]} {
1243 set headids($name) $id
1244 lappend idheads($id) $name
1246 } elseif {[string match "heads/*" $name]} {
1247 set name [string range $name 6 end]
1248 set headids($name) $id
1249 lappend idheads($id) $name
1250 } elseif {[string match "tags/*" $name]} {
1251 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1252 # which is what we want since the former is the commit ID
1253 set name [string range $name 5 end]
1254 if {[string match "*^{}" $name]} {
1255 set name [string range $name 0 end-3]
1256 } else {
1257 set tagobjid($name) $id
1259 set tagids($name) $id
1260 lappend idtags($id) $name
1261 } else {
1262 set otherrefids($name) $id
1263 lappend idotherrefs($id) $name
1266 catch {close $refd}
1267 set mainhead {}
1268 set mainheadid {}
1269 catch {
1270 set thehead [exec git symbolic-ref HEAD]
1271 if {[string match "refs/heads/*" $thehead]} {
1272 set mainhead [string range $thehead 11 end]
1273 if {[info exists headids($mainhead)]} {
1274 set mainheadid $headids($mainhead)
1280 # skip over fake commits
1281 proc first_real_row {} {
1282 global nullid nullid2 numcommits
1284 for {set row 0} {$row < $numcommits} {incr row} {
1285 set id [commitonrow $row]
1286 if {$id ne $nullid && $id ne $nullid2} {
1287 break
1290 return $row
1293 # update things for a head moved to a child of its previous location
1294 proc movehead {id name} {
1295 global headids idheads
1297 removehead $headids($name) $name
1298 set headids($name) $id
1299 lappend idheads($id) $name
1302 # update things when a head has been removed
1303 proc removehead {id name} {
1304 global headids idheads
1306 if {$idheads($id) eq $name} {
1307 unset idheads($id)
1308 } else {
1309 set i [lsearch -exact $idheads($id) $name]
1310 if {$i >= 0} {
1311 set idheads($id) [lreplace $idheads($id) $i $i]
1314 unset headids($name)
1317 proc show_error {w top msg} {
1318 message $w.m -text $msg -justify center -aspect 400
1319 pack $w.m -side top -fill x -padx 20 -pady 20
1320 button $w.ok -text [mc OK] -command "destroy $top"
1321 pack $w.ok -side bottom -fill x
1322 bind $top <Visibility> "grab $top; focus $top"
1323 bind $top <Key-Return> "destroy $top"
1324 tkwait window $top
1327 proc error_popup msg {
1328 set w .error
1329 toplevel $w
1330 wm transient $w .
1331 show_error $w $w $msg
1334 proc confirm_popup msg {
1335 global confirm_ok
1336 set confirm_ok 0
1337 set w .confirm
1338 toplevel $w
1339 wm transient $w .
1340 message $w.m -text $msg -justify center -aspect 400
1341 pack $w.m -side top -fill x -padx 20 -pady 20
1342 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1343 pack $w.ok -side left -fill x
1344 button $w.cancel -text [mc Cancel] -command "destroy $w"
1345 pack $w.cancel -side right -fill x
1346 bind $w <Visibility> "grab $w; focus $w"
1347 tkwait window $w
1348 return $confirm_ok
1351 proc makewindow {} {
1352 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1353 global tabstop
1354 global findtype findtypemenu findloc findstring fstring geometry
1355 global entries sha1entry sha1string sha1but
1356 global diffcontextstring diffcontext
1357 global maincursor textcursor curtextcursor
1358 global rowctxmenu fakerowmenu mergemax wrapcomment
1359 global highlight_files gdttype
1360 global searchstring sstring
1361 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1362 global headctxmenu progresscanv progressitem progresscoords statusw
1363 global fprogitem fprogcoord lastprogupdate progupdatepending
1364 global rprogitem rprogcoord
1365 global have_tk85
1367 menu .bar
1368 .bar add cascade -label [mc "File"] -menu .bar.file
1369 .bar configure -font uifont
1370 menu .bar.file
1371 .bar.file add command -label [mc "Update"] -command updatecommits
1372 .bar.file add command -label [mc "Reload"] -command reloadcommits
1373 .bar.file add command -label [mc "Reread references"] -command rereadrefs
1374 .bar.file add command -label [mc "List references"] -command showrefs
1375 .bar.file add command -label [mc "Quit"] -command doquit
1376 .bar.file configure -font uifont
1377 menu .bar.edit
1378 .bar add cascade -label [mc "Edit"] -menu .bar.edit
1379 .bar.edit add command -label [mc "Preferences"] -command doprefs
1380 .bar.edit configure -font uifont
1382 menu .bar.view -font uifont
1383 .bar add cascade -label [mc "View"] -menu .bar.view
1384 .bar.view add command -label [mc "New view..."] -command {newview 0}
1385 .bar.view add command -label [mc "Edit view..."] -command editview \
1386 -state disabled
1387 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1388 .bar.view add separator
1389 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1390 -variable selectedview -value 0
1392 menu .bar.help
1393 .bar add cascade -label [mc "Help"] -menu .bar.help
1394 .bar.help add command -label [mc "About gitk"] -command about
1395 .bar.help add command -label [mc "Key bindings"] -command keys
1396 .bar.help configure -font uifont
1397 . configure -menu .bar
1399 # the gui has upper and lower half, parts of a paned window.
1400 panedwindow .ctop -orient vertical
1402 # possibly use assumed geometry
1403 if {![info exists geometry(pwsash0)]} {
1404 set geometry(topheight) [expr {15 * $linespc}]
1405 set geometry(topwidth) [expr {80 * $charspc}]
1406 set geometry(botheight) [expr {15 * $linespc}]
1407 set geometry(botwidth) [expr {50 * $charspc}]
1408 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1409 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1412 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1413 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1414 frame .tf.histframe
1415 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1417 # create three canvases
1418 set cscroll .tf.histframe.csb
1419 set canv .tf.histframe.pwclist.canv
1420 canvas $canv \
1421 -selectbackground $selectbgcolor \
1422 -background $bgcolor -bd 0 \
1423 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1424 .tf.histframe.pwclist add $canv
1425 set canv2 .tf.histframe.pwclist.canv2
1426 canvas $canv2 \
1427 -selectbackground $selectbgcolor \
1428 -background $bgcolor -bd 0 -yscrollincr $linespc
1429 .tf.histframe.pwclist add $canv2
1430 set canv3 .tf.histframe.pwclist.canv3
1431 canvas $canv3 \
1432 -selectbackground $selectbgcolor \
1433 -background $bgcolor -bd 0 -yscrollincr $linespc
1434 .tf.histframe.pwclist add $canv3
1435 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1436 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1438 # a scroll bar to rule them
1439 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1440 pack $cscroll -side right -fill y
1441 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1442 lappend bglist $canv $canv2 $canv3
1443 pack .tf.histframe.pwclist -fill both -expand 1 -side left
1445 # we have two button bars at bottom of top frame. Bar 1
1446 frame .tf.bar
1447 frame .tf.lbar -height 15
1449 set sha1entry .tf.bar.sha1
1450 set entries $sha1entry
1451 set sha1but .tf.bar.sha1label
1452 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1453 -command gotocommit -width 8 -font uifont
1454 $sha1but conf -disabledforeground [$sha1but cget -foreground]
1455 pack .tf.bar.sha1label -side left
1456 entry $sha1entry -width 40 -font textfont -textvariable sha1string
1457 trace add variable sha1string write sha1change
1458 pack $sha1entry -side left -pady 2
1460 image create bitmap bm-left -data {
1461 #define left_width 16
1462 #define left_height 16
1463 static unsigned char left_bits[] = {
1464 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1465 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1466 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1468 image create bitmap bm-right -data {
1469 #define right_width 16
1470 #define right_height 16
1471 static unsigned char right_bits[] = {
1472 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1473 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1474 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1476 button .tf.bar.leftbut -image bm-left -command goback \
1477 -state disabled -width 26
1478 pack .tf.bar.leftbut -side left -fill y
1479 button .tf.bar.rightbut -image bm-right -command goforw \
1480 -state disabled -width 26
1481 pack .tf.bar.rightbut -side left -fill y
1483 # Status label and progress bar
1484 set statusw .tf.bar.status
1485 label $statusw -width 15 -relief sunken -font uifont
1486 pack $statusw -side left -padx 5
1487 set h [expr {[font metrics uifont -linespace] + 2}]
1488 set progresscanv .tf.bar.progress
1489 canvas $progresscanv -relief sunken -height $h -borderwidth 2
1490 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1491 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1492 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1493 pack $progresscanv -side right -expand 1 -fill x
1494 set progresscoords {0 0}
1495 set fprogcoord 0
1496 set rprogcoord 0
1497 bind $progresscanv <Configure> adjustprogress
1498 set lastprogupdate [clock clicks -milliseconds]
1499 set progupdatepending 0
1501 # build up the bottom bar of upper window
1502 label .tf.lbar.flabel -text "[mc "Find"] " -font uifont
1503 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1} -font uifont
1504 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1} -font uifont
1505 label .tf.lbar.flab2 -text " [mc "commit"] " -font uifont
1506 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1507 -side left -fill y
1508 set gdttype [mc "containing:"]
1509 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1510 [mc "containing:"] \
1511 [mc "touching paths:"] \
1512 [mc "adding/removing string:"]]
1513 trace add variable gdttype write gdttype_change
1514 $gm conf -font uifont
1515 .tf.lbar.gdttype conf -font uifont
1516 pack .tf.lbar.gdttype -side left -fill y
1518 set findstring {}
1519 set fstring .tf.lbar.findstring
1520 lappend entries $fstring
1521 entry $fstring -width 30 -font textfont -textvariable findstring
1522 trace add variable findstring write find_change
1523 set findtype [mc "Exact"]
1524 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1525 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1526 trace add variable findtype write findcom_change
1527 .tf.lbar.findtype configure -font uifont
1528 .tf.lbar.findtype.menu configure -font uifont
1529 set findloc [mc "All fields"]
1530 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1531 [mc "Comments"] [mc "Author"] [mc "Committer"]
1532 trace add variable findloc write find_change
1533 .tf.lbar.findloc configure -font uifont
1534 .tf.lbar.findloc.menu configure -font uifont
1535 pack .tf.lbar.findloc -side right
1536 pack .tf.lbar.findtype -side right
1537 pack $fstring -side left -expand 1 -fill x
1539 # Finish putting the upper half of the viewer together
1540 pack .tf.lbar -in .tf -side bottom -fill x
1541 pack .tf.bar -in .tf -side bottom -fill x
1542 pack .tf.histframe -fill both -side top -expand 1
1543 .ctop add .tf
1544 .ctop paneconfigure .tf -height $geometry(topheight)
1545 .ctop paneconfigure .tf -width $geometry(topwidth)
1547 # now build up the bottom
1548 panedwindow .pwbottom -orient horizontal
1550 # lower left, a text box over search bar, scroll bar to the right
1551 # if we know window height, then that will set the lower text height, otherwise
1552 # we set lower text height which will drive window height
1553 if {[info exists geometry(main)]} {
1554 frame .bleft -width $geometry(botwidth)
1555 } else {
1556 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1558 frame .bleft.top
1559 frame .bleft.mid
1561 button .bleft.top.search -text [mc "Search"] -command dosearch \
1562 -font uifont
1563 pack .bleft.top.search -side left -padx 5
1564 set sstring .bleft.top.sstring
1565 entry $sstring -width 20 -font textfont -textvariable searchstring
1566 lappend entries $sstring
1567 trace add variable searchstring write incrsearch
1568 pack $sstring -side left -expand 1 -fill x
1569 radiobutton .bleft.mid.diff -text [mc "Diff"] -font uifont \
1570 -command changediffdisp -variable diffelide -value {0 0}
1571 radiobutton .bleft.mid.old -text [mc "Old version"] -font uifont \
1572 -command changediffdisp -variable diffelide -value {0 1}
1573 radiobutton .bleft.mid.new -text [mc "New version"] -font uifont \
1574 -command changediffdisp -variable diffelide -value {1 0}
1575 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: " \
1576 -font uifont
1577 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1578 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1579 -from 1 -increment 1 -to 10000000 \
1580 -validate all -validatecommand "diffcontextvalidate %P" \
1581 -textvariable diffcontextstring
1582 .bleft.mid.diffcontext set $diffcontext
1583 trace add variable diffcontextstring write diffcontextchange
1584 lappend entries .bleft.mid.diffcontext
1585 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1586 set ctext .bleft.ctext
1587 text $ctext -background $bgcolor -foreground $fgcolor \
1588 -state disabled -font textfont \
1589 -yscrollcommand scrolltext -wrap none
1590 if {$have_tk85} {
1591 $ctext conf -tabstyle wordprocessor
1593 scrollbar .bleft.sb -command "$ctext yview"
1594 pack .bleft.top -side top -fill x
1595 pack .bleft.mid -side top -fill x
1596 pack .bleft.sb -side right -fill y
1597 pack $ctext -side left -fill both -expand 1
1598 lappend bglist $ctext
1599 lappend fglist $ctext
1601 $ctext tag conf comment -wrap $wrapcomment
1602 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1603 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1604 $ctext tag conf d0 -fore [lindex $diffcolors 0]
1605 $ctext tag conf d1 -fore [lindex $diffcolors 1]
1606 $ctext tag conf m0 -fore red
1607 $ctext tag conf m1 -fore blue
1608 $ctext tag conf m2 -fore green
1609 $ctext tag conf m3 -fore purple
1610 $ctext tag conf m4 -fore brown
1611 $ctext tag conf m5 -fore "#009090"
1612 $ctext tag conf m6 -fore magenta
1613 $ctext tag conf m7 -fore "#808000"
1614 $ctext tag conf m8 -fore "#009000"
1615 $ctext tag conf m9 -fore "#ff0080"
1616 $ctext tag conf m10 -fore cyan
1617 $ctext tag conf m11 -fore "#b07070"
1618 $ctext tag conf m12 -fore "#70b0f0"
1619 $ctext tag conf m13 -fore "#70f0b0"
1620 $ctext tag conf m14 -fore "#f0b070"
1621 $ctext tag conf m15 -fore "#ff70b0"
1622 $ctext tag conf mmax -fore darkgrey
1623 set mergemax 16
1624 $ctext tag conf mresult -font textfontbold
1625 $ctext tag conf msep -font textfontbold
1626 $ctext tag conf found -back yellow
1628 .pwbottom add .bleft
1629 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1631 # lower right
1632 frame .bright
1633 frame .bright.mode
1634 radiobutton .bright.mode.patch -text [mc "Patch"] \
1635 -command reselectline -variable cmitmode -value "patch"
1636 .bright.mode.patch configure -font uifont
1637 radiobutton .bright.mode.tree -text [mc "Tree"] \
1638 -command reselectline -variable cmitmode -value "tree"
1639 .bright.mode.tree configure -font uifont
1640 grid .bright.mode.patch .bright.mode.tree -sticky ew
1641 pack .bright.mode -side top -fill x
1642 set cflist .bright.cfiles
1643 set indent [font measure mainfont "nn"]
1644 text $cflist \
1645 -selectbackground $selectbgcolor \
1646 -background $bgcolor -foreground $fgcolor \
1647 -font mainfont \
1648 -tabs [list $indent [expr {2 * $indent}]] \
1649 -yscrollcommand ".bright.sb set" \
1650 -cursor [. cget -cursor] \
1651 -spacing1 1 -spacing3 1
1652 lappend bglist $cflist
1653 lappend fglist $cflist
1654 scrollbar .bright.sb -command "$cflist yview"
1655 pack .bright.sb -side right -fill y
1656 pack $cflist -side left -fill both -expand 1
1657 $cflist tag configure highlight \
1658 -background [$cflist cget -selectbackground]
1659 $cflist tag configure bold -font mainfontbold
1661 .pwbottom add .bright
1662 .ctop add .pwbottom
1664 # restore window position if known
1665 if {[info exists geometry(main)]} {
1666 wm geometry . "$geometry(main)"
1669 if {[tk windowingsystem] eq {aqua}} {
1670 set M1B M1
1671 } else {
1672 set M1B Control
1675 bind .pwbottom <Configure> {resizecdetpanes %W %w}
1676 pack .ctop -fill both -expand 1
1677 bindall <1> {selcanvline %W %x %y}
1678 #bindall <B1-Motion> {selcanvline %W %x %y}
1679 if {[tk windowingsystem] == "win32"} {
1680 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1681 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1682 } else {
1683 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1684 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1685 if {[tk windowingsystem] eq "aqua"} {
1686 bindall <MouseWheel> {
1687 set delta [expr {- (%D)}]
1688 allcanvs yview scroll $delta units
1692 bindall <2> "canvscan mark %W %x %y"
1693 bindall <B2-Motion> "canvscan dragto %W %x %y"
1694 bindkey <Home> selfirstline
1695 bindkey <End> sellastline
1696 bind . <Key-Up> "selnextline -1"
1697 bind . <Key-Down> "selnextline 1"
1698 bind . <Shift-Key-Up> "dofind -1 0"
1699 bind . <Shift-Key-Down> "dofind 1 0"
1700 bindkey <Key-Right> "goforw"
1701 bindkey <Key-Left> "goback"
1702 bind . <Key-Prior> "selnextpage -1"
1703 bind . <Key-Next> "selnextpage 1"
1704 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1705 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1706 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1707 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1708 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1709 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1710 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1711 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1712 bindkey <Key-space> "$ctext yview scroll 1 pages"
1713 bindkey p "selnextline -1"
1714 bindkey n "selnextline 1"
1715 bindkey z "goback"
1716 bindkey x "goforw"
1717 bindkey i "selnextline -1"
1718 bindkey k "selnextline 1"
1719 bindkey j "goback"
1720 bindkey l "goforw"
1721 bindkey b "$ctext yview scroll -1 pages"
1722 bindkey d "$ctext yview scroll 18 units"
1723 bindkey u "$ctext yview scroll -18 units"
1724 bindkey / {dofind 1 1}
1725 bindkey <Key-Return> {dofind 1 1}
1726 bindkey ? {dofind -1 1}
1727 bindkey f nextfile
1728 bindkey <F5> updatecommits
1729 bind . <$M1B-q> doquit
1730 bind . <$M1B-f> {dofind 1 1}
1731 bind . <$M1B-g> {dofind 1 0}
1732 bind . <$M1B-r> dosearchback
1733 bind . <$M1B-s> dosearch
1734 bind . <$M1B-equal> {incrfont 1}
1735 bind . <$M1B-KP_Add> {incrfont 1}
1736 bind . <$M1B-minus> {incrfont -1}
1737 bind . <$M1B-KP_Subtract> {incrfont -1}
1738 wm protocol . WM_DELETE_WINDOW doquit
1739 bind . <Button-1> "click %W"
1740 bind $fstring <Key-Return> {dofind 1 1}
1741 bind $sha1entry <Key-Return> gotocommit
1742 bind $sha1entry <<PasteSelection>> clearsha1
1743 bind $cflist <1> {sel_flist %W %x %y; break}
1744 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1745 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1746 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1748 set maincursor [. cget -cursor]
1749 set textcursor [$ctext cget -cursor]
1750 set curtextcursor $textcursor
1752 set rowctxmenu .rowctxmenu
1753 menu $rowctxmenu -tearoff 0
1754 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1755 -command {diffvssel 0}
1756 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1757 -command {diffvssel 1}
1758 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1759 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1760 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1761 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1762 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1763 -command cherrypick
1764 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1765 -command resethead
1767 set fakerowmenu .fakerowmenu
1768 menu $fakerowmenu -tearoff 0
1769 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1770 -command {diffvssel 0}
1771 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1772 -command {diffvssel 1}
1773 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1774 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1775 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1776 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1778 set headctxmenu .headctxmenu
1779 menu $headctxmenu -tearoff 0
1780 $headctxmenu add command -label [mc "Check out this branch"] \
1781 -command cobranch
1782 $headctxmenu add command -label [mc "Remove this branch"] \
1783 -command rmbranch
1785 global flist_menu
1786 set flist_menu .flistctxmenu
1787 menu $flist_menu -tearoff 0
1788 $flist_menu add command -label [mc "Highlight this too"] \
1789 -command {flist_hl 0}
1790 $flist_menu add command -label [mc "Highlight this only"] \
1791 -command {flist_hl 1}
1794 # Windows sends all mouse wheel events to the current focused window, not
1795 # the one where the mouse hovers, so bind those events here and redirect
1796 # to the correct window
1797 proc windows_mousewheel_redirector {W X Y D} {
1798 global canv canv2 canv3
1799 set w [winfo containing -displayof $W $X $Y]
1800 if {$w ne ""} {
1801 set u [expr {$D < 0 ? 5 : -5}]
1802 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1803 allcanvs yview scroll $u units
1804 } else {
1805 catch {
1806 $w yview scroll $u units
1812 # mouse-2 makes all windows scan vertically, but only the one
1813 # the cursor is in scans horizontally
1814 proc canvscan {op w x y} {
1815 global canv canv2 canv3
1816 foreach c [list $canv $canv2 $canv3] {
1817 if {$c == $w} {
1818 $c scan $op $x $y
1819 } else {
1820 $c scan $op 0 $y
1825 proc scrollcanv {cscroll f0 f1} {
1826 $cscroll set $f0 $f1
1827 drawvisible
1828 flushhighlights
1831 # when we make a key binding for the toplevel, make sure
1832 # it doesn't get triggered when that key is pressed in the
1833 # find string entry widget.
1834 proc bindkey {ev script} {
1835 global entries
1836 bind . $ev $script
1837 set escript [bind Entry $ev]
1838 if {$escript == {}} {
1839 set escript [bind Entry <Key>]
1841 foreach e $entries {
1842 bind $e $ev "$escript; break"
1846 # set the focus back to the toplevel for any click outside
1847 # the entry widgets
1848 proc click {w} {
1849 global ctext entries
1850 foreach e [concat $entries $ctext] {
1851 if {$w == $e} return
1853 focus .
1856 # Adjust the progress bar for a change in requested extent or canvas size
1857 proc adjustprogress {} {
1858 global progresscanv progressitem progresscoords
1859 global fprogitem fprogcoord lastprogupdate progupdatepending
1860 global rprogitem rprogcoord
1862 set w [expr {[winfo width $progresscanv] - 4}]
1863 set x0 [expr {$w * [lindex $progresscoords 0]}]
1864 set x1 [expr {$w * [lindex $progresscoords 1]}]
1865 set h [winfo height $progresscanv]
1866 $progresscanv coords $progressitem $x0 0 $x1 $h
1867 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1868 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1869 set now [clock clicks -milliseconds]
1870 if {$now >= $lastprogupdate + 100} {
1871 set progupdatepending 0
1872 update
1873 } elseif {!$progupdatepending} {
1874 set progupdatepending 1
1875 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1879 proc doprogupdate {} {
1880 global lastprogupdate progupdatepending
1882 if {$progupdatepending} {
1883 set progupdatepending 0
1884 set lastprogupdate [clock clicks -milliseconds]
1885 update
1889 proc savestuff {w} {
1890 global canv canv2 canv3 mainfont textfont uifont tabstop
1891 global stuffsaved findmergefiles maxgraphpct
1892 global maxwidth showneartags showlocalchanges
1893 global viewname viewfiles viewargs viewperm nextviewnum
1894 global cmitmode wrapcomment datetimeformat limitdiffs
1895 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1897 if {$stuffsaved} return
1898 if {![winfo viewable .]} return
1899 catch {
1900 set f [open "~/.gitk-new" w]
1901 puts $f [list set mainfont $mainfont]
1902 puts $f [list set textfont $textfont]
1903 puts $f [list set uifont $uifont]
1904 puts $f [list set tabstop $tabstop]
1905 puts $f [list set findmergefiles $findmergefiles]
1906 puts $f [list set maxgraphpct $maxgraphpct]
1907 puts $f [list set maxwidth $maxwidth]
1908 puts $f [list set cmitmode $cmitmode]
1909 puts $f [list set wrapcomment $wrapcomment]
1910 puts $f [list set showneartags $showneartags]
1911 puts $f [list set showlocalchanges $showlocalchanges]
1912 puts $f [list set datetimeformat $datetimeformat]
1913 puts $f [list set limitdiffs $limitdiffs]
1914 puts $f [list set bgcolor $bgcolor]
1915 puts $f [list set fgcolor $fgcolor]
1916 puts $f [list set colors $colors]
1917 puts $f [list set diffcolors $diffcolors]
1918 puts $f [list set diffcontext $diffcontext]
1919 puts $f [list set selectbgcolor $selectbgcolor]
1921 puts $f "set geometry(main) [wm geometry .]"
1922 puts $f "set geometry(topwidth) [winfo width .tf]"
1923 puts $f "set geometry(topheight) [winfo height .tf]"
1924 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1925 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1926 puts $f "set geometry(botwidth) [winfo width .bleft]"
1927 puts $f "set geometry(botheight) [winfo height .bleft]"
1929 puts -nonewline $f "set permviews {"
1930 for {set v 0} {$v < $nextviewnum} {incr v} {
1931 if {$viewperm($v)} {
1932 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1935 puts $f "}"
1936 close $f
1937 file rename -force "~/.gitk-new" "~/.gitk"
1939 set stuffsaved 1
1942 proc resizeclistpanes {win w} {
1943 global oldwidth
1944 if {[info exists oldwidth($win)]} {
1945 set s0 [$win sash coord 0]
1946 set s1 [$win sash coord 1]
1947 if {$w < 60} {
1948 set sash0 [expr {int($w/2 - 2)}]
1949 set sash1 [expr {int($w*5/6 - 2)}]
1950 } else {
1951 set factor [expr {1.0 * $w / $oldwidth($win)}]
1952 set sash0 [expr {int($factor * [lindex $s0 0])}]
1953 set sash1 [expr {int($factor * [lindex $s1 0])}]
1954 if {$sash0 < 30} {
1955 set sash0 30
1957 if {$sash1 < $sash0 + 20} {
1958 set sash1 [expr {$sash0 + 20}]
1960 if {$sash1 > $w - 10} {
1961 set sash1 [expr {$w - 10}]
1962 if {$sash0 > $sash1 - 20} {
1963 set sash0 [expr {$sash1 - 20}]
1967 $win sash place 0 $sash0 [lindex $s0 1]
1968 $win sash place 1 $sash1 [lindex $s1 1]
1970 set oldwidth($win) $w
1973 proc resizecdetpanes {win w} {
1974 global oldwidth
1975 if {[info exists oldwidth($win)]} {
1976 set s0 [$win sash coord 0]
1977 if {$w < 60} {
1978 set sash0 [expr {int($w*3/4 - 2)}]
1979 } else {
1980 set factor [expr {1.0 * $w / $oldwidth($win)}]
1981 set sash0 [expr {int($factor * [lindex $s0 0])}]
1982 if {$sash0 < 45} {
1983 set sash0 45
1985 if {$sash0 > $w - 15} {
1986 set sash0 [expr {$w - 15}]
1989 $win sash place 0 $sash0 [lindex $s0 1]
1991 set oldwidth($win) $w
1994 proc allcanvs args {
1995 global canv canv2 canv3
1996 eval $canv $args
1997 eval $canv2 $args
1998 eval $canv3 $args
2001 proc bindall {event action} {
2002 global canv canv2 canv3
2003 bind $canv $event $action
2004 bind $canv2 $event $action
2005 bind $canv3 $event $action
2008 proc about {} {
2009 global uifont
2010 set w .about
2011 if {[winfo exists $w]} {
2012 raise $w
2013 return
2015 toplevel $w
2016 wm title $w [mc "About gitk"]
2017 message $w.m -text [mc "
2018 Gitk - a commit viewer for git
2020 Copyright © 2005-2006 Paul Mackerras
2022 Use and redistribute under the terms of the GNU General Public License"] \
2023 -justify center -aspect 400 -border 2 -bg white -relief groove
2024 pack $w.m -side top -fill x -padx 2 -pady 2
2025 $w.m configure -font uifont
2026 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2027 pack $w.ok -side bottom
2028 $w.ok configure -font uifont
2029 bind $w <Visibility> "focus $w.ok"
2030 bind $w <Key-Escape> "destroy $w"
2031 bind $w <Key-Return> "destroy $w"
2034 proc keys {} {
2035 global uifont
2036 set w .keys
2037 if {[winfo exists $w]} {
2038 raise $w
2039 return
2041 if {[tk windowingsystem] eq {aqua}} {
2042 set M1T Cmd
2043 } else {
2044 set M1T Ctrl
2046 toplevel $w
2047 wm title $w [mc "Gitk key bindings"]
2048 message $w.m -text [mc "
2049 Gitk key bindings:
2051 <$M1T-Q> Quit
2052 <Home> Move to first commit
2053 <End> Move to last commit
2054 <Up>, p, i Move up one commit
2055 <Down>, n, k Move down one commit
2056 <Left>, z, j Go back in history list
2057 <Right>, x, l Go forward in history list
2058 <PageUp> Move up one page in commit list
2059 <PageDown> Move down one page in commit list
2060 <$M1T-Home> Scroll to top of commit list
2061 <$M1T-End> Scroll to bottom of commit list
2062 <$M1T-Up> Scroll commit list up one line
2063 <$M1T-Down> Scroll commit list down one line
2064 <$M1T-PageUp> Scroll commit list up one page
2065 <$M1T-PageDown> Scroll commit list down one page
2066 <Shift-Up> Find backwards (upwards, later commits)
2067 <Shift-Down> Find forwards (downwards, earlier commits)
2068 <Delete>, b Scroll diff view up one page
2069 <Backspace> Scroll diff view up one page
2070 <Space> Scroll diff view down one page
2071 u Scroll diff view up 18 lines
2072 d Scroll diff view down 18 lines
2073 <$M1T-F> Find
2074 <$M1T-G> Move to next find hit
2075 <Return> Move to next find hit
2076 / Move to next find hit, or redo find
2077 ? Move to previous find hit
2078 f Scroll diff view to next file
2079 <$M1T-S> Search for next hit in diff view
2080 <$M1T-R> Search for previous hit in diff view
2081 <$M1T-KP+> Increase font size
2082 <$M1T-plus> Increase font size
2083 <$M1T-KP-> Decrease font size
2084 <$M1T-minus> Decrease font size
2085 <F5> Update
2086 "] \
2087 -justify left -bg white -border 2 -relief groove
2088 pack $w.m -side top -fill both -padx 2 -pady 2
2089 $w.m configure -font uifont
2090 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2091 pack $w.ok -side bottom
2092 $w.ok configure -font uifont
2093 bind $w <Visibility> "focus $w.ok"
2094 bind $w <Key-Escape> "destroy $w"
2095 bind $w <Key-Return> "destroy $w"
2098 # Procedures for manipulating the file list window at the
2099 # bottom right of the overall window.
2101 proc treeview {w l openlevs} {
2102 global treecontents treediropen treeheight treeparent treeindex
2104 set ix 0
2105 set treeindex() 0
2106 set lev 0
2107 set prefix {}
2108 set prefixend -1
2109 set prefendstack {}
2110 set htstack {}
2111 set ht 0
2112 set treecontents() {}
2113 $w conf -state normal
2114 foreach f $l {
2115 while {[string range $f 0 $prefixend] ne $prefix} {
2116 if {$lev <= $openlevs} {
2117 $w mark set e:$treeindex($prefix) "end -1c"
2118 $w mark gravity e:$treeindex($prefix) left
2120 set treeheight($prefix) $ht
2121 incr ht [lindex $htstack end]
2122 set htstack [lreplace $htstack end end]
2123 set prefixend [lindex $prefendstack end]
2124 set prefendstack [lreplace $prefendstack end end]
2125 set prefix [string range $prefix 0 $prefixend]
2126 incr lev -1
2128 set tail [string range $f [expr {$prefixend+1}] end]
2129 while {[set slash [string first "/" $tail]] >= 0} {
2130 lappend htstack $ht
2131 set ht 0
2132 lappend prefendstack $prefixend
2133 incr prefixend [expr {$slash + 1}]
2134 set d [string range $tail 0 $slash]
2135 lappend treecontents($prefix) $d
2136 set oldprefix $prefix
2137 append prefix $d
2138 set treecontents($prefix) {}
2139 set treeindex($prefix) [incr ix]
2140 set treeparent($prefix) $oldprefix
2141 set tail [string range $tail [expr {$slash+1}] end]
2142 if {$lev <= $openlevs} {
2143 set ht 1
2144 set treediropen($prefix) [expr {$lev < $openlevs}]
2145 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2146 $w mark set d:$ix "end -1c"
2147 $w mark gravity d:$ix left
2148 set str "\n"
2149 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2150 $w insert end $str
2151 $w image create end -align center -image $bm -padx 1 \
2152 -name a:$ix
2153 $w insert end $d [highlight_tag $prefix]
2154 $w mark set s:$ix "end -1c"
2155 $w mark gravity s:$ix left
2157 incr lev
2159 if {$tail ne {}} {
2160 if {$lev <= $openlevs} {
2161 incr ht
2162 set str "\n"
2163 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2164 $w insert end $str
2165 $w insert end $tail [highlight_tag $f]
2167 lappend treecontents($prefix) $tail
2170 while {$htstack ne {}} {
2171 set treeheight($prefix) $ht
2172 incr ht [lindex $htstack end]
2173 set htstack [lreplace $htstack end end]
2174 set prefixend [lindex $prefendstack end]
2175 set prefendstack [lreplace $prefendstack end end]
2176 set prefix [string range $prefix 0 $prefixend]
2178 $w conf -state disabled
2181 proc linetoelt {l} {
2182 global treeheight treecontents
2184 set y 2
2185 set prefix {}
2186 while {1} {
2187 foreach e $treecontents($prefix) {
2188 if {$y == $l} {
2189 return "$prefix$e"
2191 set n 1
2192 if {[string index $e end] eq "/"} {
2193 set n $treeheight($prefix$e)
2194 if {$y + $n > $l} {
2195 append prefix $e
2196 incr y
2197 break
2200 incr y $n
2205 proc highlight_tree {y prefix} {
2206 global treeheight treecontents cflist
2208 foreach e $treecontents($prefix) {
2209 set path $prefix$e
2210 if {[highlight_tag $path] ne {}} {
2211 $cflist tag add bold $y.0 "$y.0 lineend"
2213 incr y
2214 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2215 set y [highlight_tree $y $path]
2218 return $y
2221 proc treeclosedir {w dir} {
2222 global treediropen treeheight treeparent treeindex
2224 set ix $treeindex($dir)
2225 $w conf -state normal
2226 $w delete s:$ix e:$ix
2227 set treediropen($dir) 0
2228 $w image configure a:$ix -image tri-rt
2229 $w conf -state disabled
2230 set n [expr {1 - $treeheight($dir)}]
2231 while {$dir ne {}} {
2232 incr treeheight($dir) $n
2233 set dir $treeparent($dir)
2237 proc treeopendir {w dir} {
2238 global treediropen treeheight treeparent treecontents treeindex
2240 set ix $treeindex($dir)
2241 $w conf -state normal
2242 $w image configure a:$ix -image tri-dn
2243 $w mark set e:$ix s:$ix
2244 $w mark gravity e:$ix right
2245 set lev 0
2246 set str "\n"
2247 set n [llength $treecontents($dir)]
2248 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2249 incr lev
2250 append str "\t"
2251 incr treeheight($x) $n
2253 foreach e $treecontents($dir) {
2254 set de $dir$e
2255 if {[string index $e end] eq "/"} {
2256 set iy $treeindex($de)
2257 $w mark set d:$iy e:$ix
2258 $w mark gravity d:$iy left
2259 $w insert e:$ix $str
2260 set treediropen($de) 0
2261 $w image create e:$ix -align center -image tri-rt -padx 1 \
2262 -name a:$iy
2263 $w insert e:$ix $e [highlight_tag $de]
2264 $w mark set s:$iy e:$ix
2265 $w mark gravity s:$iy left
2266 set treeheight($de) 1
2267 } else {
2268 $w insert e:$ix $str
2269 $w insert e:$ix $e [highlight_tag $de]
2272 $w mark gravity e:$ix left
2273 $w conf -state disabled
2274 set treediropen($dir) 1
2275 set top [lindex [split [$w index @0,0] .] 0]
2276 set ht [$w cget -height]
2277 set l [lindex [split [$w index s:$ix] .] 0]
2278 if {$l < $top} {
2279 $w yview $l.0
2280 } elseif {$l + $n + 1 > $top + $ht} {
2281 set top [expr {$l + $n + 2 - $ht}]
2282 if {$l < $top} {
2283 set top $l
2285 $w yview $top.0
2289 proc treeclick {w x y} {
2290 global treediropen cmitmode ctext cflist cflist_top
2292 if {$cmitmode ne "tree"} return
2293 if {![info exists cflist_top]} return
2294 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2295 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2296 $cflist tag add highlight $l.0 "$l.0 lineend"
2297 set cflist_top $l
2298 if {$l == 1} {
2299 $ctext yview 1.0
2300 return
2302 set e [linetoelt $l]
2303 if {[string index $e end] ne "/"} {
2304 showfile $e
2305 } elseif {$treediropen($e)} {
2306 treeclosedir $w $e
2307 } else {
2308 treeopendir $w $e
2312 proc setfilelist {id} {
2313 global treefilelist cflist
2315 treeview $cflist $treefilelist($id) 0
2318 image create bitmap tri-rt -background black -foreground blue -data {
2319 #define tri-rt_width 13
2320 #define tri-rt_height 13
2321 static unsigned char tri-rt_bits[] = {
2322 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2323 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2324 0x00, 0x00};
2325 } -maskdata {
2326 #define tri-rt-mask_width 13
2327 #define tri-rt-mask_height 13
2328 static unsigned char tri-rt-mask_bits[] = {
2329 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2330 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2331 0x08, 0x00};
2333 image create bitmap tri-dn -background black -foreground blue -data {
2334 #define tri-dn_width 13
2335 #define tri-dn_height 13
2336 static unsigned char tri-dn_bits[] = {
2337 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2338 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2339 0x00, 0x00};
2340 } -maskdata {
2341 #define tri-dn-mask_width 13
2342 #define tri-dn-mask_height 13
2343 static unsigned char tri-dn-mask_bits[] = {
2344 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2345 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2346 0x00, 0x00};
2349 image create bitmap reficon-T -background black -foreground yellow -data {
2350 #define tagicon_width 13
2351 #define tagicon_height 9
2352 static unsigned char tagicon_bits[] = {
2353 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2354 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2355 } -maskdata {
2356 #define tagicon-mask_width 13
2357 #define tagicon-mask_height 9
2358 static unsigned char tagicon-mask_bits[] = {
2359 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2360 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2362 set rectdata {
2363 #define headicon_width 13
2364 #define headicon_height 9
2365 static unsigned char headicon_bits[] = {
2366 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2367 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2369 set rectmask {
2370 #define headicon-mask_width 13
2371 #define headicon-mask_height 9
2372 static unsigned char headicon-mask_bits[] = {
2373 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2374 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2376 image create bitmap reficon-H -background black -foreground green \
2377 -data $rectdata -maskdata $rectmask
2378 image create bitmap reficon-o -background black -foreground "#ddddff" \
2379 -data $rectdata -maskdata $rectmask
2381 proc init_flist {first} {
2382 global cflist cflist_top difffilestart
2384 $cflist conf -state normal
2385 $cflist delete 0.0 end
2386 if {$first ne {}} {
2387 $cflist insert end $first
2388 set cflist_top 1
2389 $cflist tag add highlight 1.0 "1.0 lineend"
2390 } else {
2391 catch {unset cflist_top}
2393 $cflist conf -state disabled
2394 set difffilestart {}
2397 proc highlight_tag {f} {
2398 global highlight_paths
2400 foreach p $highlight_paths {
2401 if {[string match $p $f]} {
2402 return "bold"
2405 return {}
2408 proc highlight_filelist {} {
2409 global cmitmode cflist
2411 $cflist conf -state normal
2412 if {$cmitmode ne "tree"} {
2413 set end [lindex [split [$cflist index end] .] 0]
2414 for {set l 2} {$l < $end} {incr l} {
2415 set line [$cflist get $l.0 "$l.0 lineend"]
2416 if {[highlight_tag $line] ne {}} {
2417 $cflist tag add bold $l.0 "$l.0 lineend"
2420 } else {
2421 highlight_tree 2 {}
2423 $cflist conf -state disabled
2426 proc unhighlight_filelist {} {
2427 global cflist
2429 $cflist conf -state normal
2430 $cflist tag remove bold 1.0 end
2431 $cflist conf -state disabled
2434 proc add_flist {fl} {
2435 global cflist
2437 $cflist conf -state normal
2438 foreach f $fl {
2439 $cflist insert end "\n"
2440 $cflist insert end $f [highlight_tag $f]
2442 $cflist conf -state disabled
2445 proc sel_flist {w x y} {
2446 global ctext difffilestart cflist cflist_top cmitmode
2448 if {$cmitmode eq "tree"} return
2449 if {![info exists cflist_top]} return
2450 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2451 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2452 $cflist tag add highlight $l.0 "$l.0 lineend"
2453 set cflist_top $l
2454 if {$l == 1} {
2455 $ctext yview 1.0
2456 } else {
2457 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2461 proc pop_flist_menu {w X Y x y} {
2462 global ctext cflist cmitmode flist_menu flist_menu_file
2463 global treediffs diffids
2465 stopfinding
2466 set l [lindex [split [$w index "@$x,$y"] "."] 0]
2467 if {$l <= 1} return
2468 if {$cmitmode eq "tree"} {
2469 set e [linetoelt $l]
2470 if {[string index $e end] eq "/"} return
2471 } else {
2472 set e [lindex $treediffs($diffids) [expr {$l-2}]]
2474 set flist_menu_file $e
2475 tk_popup $flist_menu $X $Y
2478 proc flist_hl {only} {
2479 global flist_menu_file findstring gdttype
2481 set x [shellquote $flist_menu_file]
2482 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2483 set findstring $x
2484 } else {
2485 append findstring " " $x
2487 set gdttype [mc "touching paths:"]
2490 # Functions for adding and removing shell-type quoting
2492 proc shellquote {str} {
2493 if {![string match "*\['\"\\ \t]*" $str]} {
2494 return $str
2496 if {![string match "*\['\"\\]*" $str]} {
2497 return "\"$str\""
2499 if {![string match "*'*" $str]} {
2500 return "'$str'"
2502 return "\"[string map {\" \\\" \\ \\\\} $str]\""
2505 proc shellarglist {l} {
2506 set str {}
2507 foreach a $l {
2508 if {$str ne {}} {
2509 append str " "
2511 append str [shellquote $a]
2513 return $str
2516 proc shelldequote {str} {
2517 set ret {}
2518 set used -1
2519 while {1} {
2520 incr used
2521 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2522 append ret [string range $str $used end]
2523 set used [string length $str]
2524 break
2526 set first [lindex $first 0]
2527 set ch [string index $str $first]
2528 if {$first > $used} {
2529 append ret [string range $str $used [expr {$first - 1}]]
2530 set used $first
2532 if {$ch eq " " || $ch eq "\t"} break
2533 incr used
2534 if {$ch eq "'"} {
2535 set first [string first "'" $str $used]
2536 if {$first < 0} {
2537 error "unmatched single-quote"
2539 append ret [string range $str $used [expr {$first - 1}]]
2540 set used $first
2541 continue
2543 if {$ch eq "\\"} {
2544 if {$used >= [string length $str]} {
2545 error "trailing backslash"
2547 append ret [string index $str $used]
2548 continue
2550 # here ch == "\""
2551 while {1} {
2552 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2553 error "unmatched double-quote"
2555 set first [lindex $first 0]
2556 set ch [string index $str $first]
2557 if {$first > $used} {
2558 append ret [string range $str $used [expr {$first - 1}]]
2559 set used $first
2561 if {$ch eq "\""} break
2562 incr used
2563 append ret [string index $str $used]
2564 incr used
2567 return [list $used $ret]
2570 proc shellsplit {str} {
2571 set l {}
2572 while {1} {
2573 set str [string trimleft $str]
2574 if {$str eq {}} break
2575 set dq [shelldequote $str]
2576 set n [lindex $dq 0]
2577 set word [lindex $dq 1]
2578 set str [string range $str $n end]
2579 lappend l $word
2581 return $l
2584 # Code to implement multiple views
2586 proc newview {ishighlight} {
2587 global nextviewnum newviewname newviewperm uifont newishighlight
2588 global newviewargs revtreeargs
2590 set newishighlight $ishighlight
2591 set top .gitkview
2592 if {[winfo exists $top]} {
2593 raise $top
2594 return
2596 set newviewname($nextviewnum) "View $nextviewnum"
2597 set newviewperm($nextviewnum) 0
2598 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2599 vieweditor $top $nextviewnum [mc "Gitk view definition"]
2602 proc editview {} {
2603 global curview
2604 global viewname viewperm newviewname newviewperm
2605 global viewargs newviewargs
2607 set top .gitkvedit-$curview
2608 if {[winfo exists $top]} {
2609 raise $top
2610 return
2612 set newviewname($curview) $viewname($curview)
2613 set newviewperm($curview) $viewperm($curview)
2614 set newviewargs($curview) [shellarglist $viewargs($curview)]
2615 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2618 proc vieweditor {top n title} {
2619 global newviewname newviewperm viewfiles
2620 global uifont
2622 toplevel $top
2623 wm title $top $title
2624 label $top.nl -text [mc "Name"] -font uifont
2625 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
2626 grid $top.nl $top.name -sticky w -pady 5
2627 checkbutton $top.perm -text [mc "Remember this view"] -variable newviewperm($n) \
2628 -font uifont
2629 grid $top.perm - -pady 5 -sticky w
2630 message $top.al -aspect 1000 -font uifont \
2631 -text [mc "Commits to include (arguments to git rev-list):"]
2632 grid $top.al - -sticky w -pady 5
2633 entry $top.args -width 50 -textvariable newviewargs($n) \
2634 -background white -font uifont
2635 grid $top.args - -sticky ew -padx 5
2636 message $top.l -aspect 1000 -font uifont \
2637 -text [mc "Enter files and directories to include, one per line:"]
2638 grid $top.l - -sticky w
2639 text $top.t -width 40 -height 10 -background white -font uifont
2640 if {[info exists viewfiles($n)]} {
2641 foreach f $viewfiles($n) {
2642 $top.t insert end $f
2643 $top.t insert end "\n"
2645 $top.t delete {end - 1c} end
2646 $top.t mark set insert 0.0
2648 grid $top.t - -sticky ew -padx 5
2649 frame $top.buts
2650 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n] \
2651 -font uifont
2652 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top] \
2653 -font uifont
2654 grid $top.buts.ok $top.buts.can
2655 grid columnconfigure $top.buts 0 -weight 1 -uniform a
2656 grid columnconfigure $top.buts 1 -weight 1 -uniform a
2657 grid $top.buts - -pady 10 -sticky ew
2658 focus $top.t
2661 proc doviewmenu {m first cmd op argv} {
2662 set nmenu [$m index end]
2663 for {set i $first} {$i <= $nmenu} {incr i} {
2664 if {[$m entrycget $i -command] eq $cmd} {
2665 eval $m $op $i $argv
2666 break
2671 proc allviewmenus {n op args} {
2672 # global viewhlmenu
2674 doviewmenu .bar.view 5 [list showview $n] $op $args
2675 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2678 proc newviewok {top n} {
2679 global nextviewnum newviewperm newviewname newishighlight
2680 global viewname viewfiles viewperm selectedview curview
2681 global viewargs newviewargs viewhlmenu
2683 if {[catch {
2684 set newargs [shellsplit $newviewargs($n)]
2685 } err]} {
2686 error_popup "[mc "Error in commit selection arguments:"] $err"
2687 wm raise $top
2688 focus $top
2689 return
2691 set files {}
2692 foreach f [split [$top.t get 0.0 end] "\n"] {
2693 set ft [string trim $f]
2694 if {$ft ne {}} {
2695 lappend files $ft
2698 if {![info exists viewfiles($n)]} {
2699 # creating a new view
2700 incr nextviewnum
2701 set viewname($n) $newviewname($n)
2702 set viewperm($n) $newviewperm($n)
2703 set viewfiles($n) $files
2704 set viewargs($n) $newargs
2705 addviewmenu $n
2706 if {!$newishighlight} {
2707 run showview $n
2708 } else {
2709 run addvhighlight $n
2711 } else {
2712 # editing an existing view
2713 set viewperm($n) $newviewperm($n)
2714 if {$newviewname($n) ne $viewname($n)} {
2715 set viewname($n) $newviewname($n)
2716 doviewmenu .bar.view 5 [list showview $n] \
2717 entryconf [list -label $viewname($n)]
2718 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2719 # entryconf [list -label $viewname($n) -value $viewname($n)]
2721 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2722 set viewfiles($n) $files
2723 set viewargs($n) $newargs
2724 if {$curview == $n} {
2725 run reloadcommits
2729 catch {destroy $top}
2732 proc delview {} {
2733 global curview viewperm hlview selectedhlview
2735 if {$curview == 0} return
2736 if {[info exists hlview] && $hlview == $curview} {
2737 set selectedhlview [mc "None"]
2738 unset hlview
2740 allviewmenus $curview delete
2741 set viewperm($curview) 0
2742 showview 0
2745 proc addviewmenu {n} {
2746 global viewname viewhlmenu
2748 .bar.view add radiobutton -label $viewname($n) \
2749 -command [list showview $n] -variable selectedview -value $n
2750 #$viewhlmenu add radiobutton -label $viewname($n) \
2751 # -command [list addvhighlight $n] -variable selectedhlview
2754 proc showview {n} {
2755 global curview viewfiles cached_commitrow ordertok
2756 global displayorder parentlist rowidlist rowisopt rowfinal
2757 global colormap rowtextx nextcolor canvxmax
2758 global numcommits viewcomplete
2759 global selectedline currentid canv canvy0
2760 global treediffs
2761 global pending_select
2762 global commitidx
2763 global selectedview selectfirst
2764 global hlview selectedhlview commitinterest
2766 if {$n == $curview} return
2767 set selid {}
2768 set ymax [lindex [$canv cget -scrollregion] 3]
2769 set span [$canv yview]
2770 set ytop [expr {[lindex $span 0] * $ymax}]
2771 set ybot [expr {[lindex $span 1] * $ymax}]
2772 set yscreen [expr {($ybot - $ytop) / 2}]
2773 if {[info exists selectedline]} {
2774 set selid $currentid
2775 set y [yc $selectedline]
2776 if {$ytop < $y && $y < $ybot} {
2777 set yscreen [expr {$y - $ytop}]
2779 } elseif {[info exists pending_select]} {
2780 set selid $pending_select
2781 unset pending_select
2783 unselectline
2784 normalline
2785 catch {unset treediffs}
2786 clear_display
2787 if {[info exists hlview] && $hlview == $n} {
2788 unset hlview
2789 set selectedhlview [mc "None"]
2791 catch {unset commitinterest}
2792 catch {unset cached_commitrow}
2793 catch {unset ordertok}
2795 set curview $n
2796 set selectedview $n
2797 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
2798 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
2800 run refill_reflist
2801 if {![info exists viewcomplete($n)]} {
2802 if {$selid ne {}} {
2803 set pending_select $selid
2805 getcommits
2806 return
2809 set displayorder {}
2810 set parentlist {}
2811 set rowidlist {}
2812 set rowisopt {}
2813 set rowfinal {}
2814 set numcommits $commitidx($n)
2816 catch {unset colormap}
2817 catch {unset rowtextx}
2818 set nextcolor 0
2819 set canvxmax [$canv cget -width]
2820 set curview $n
2821 set row 0
2822 setcanvscroll
2823 set yf 0
2824 set row {}
2825 set selectfirst 0
2826 if {$selid ne {} && [commitinview $selid $n]} {
2827 set row [rowofcommit $selid]
2828 # try to get the selected row in the same position on the screen
2829 set ymax [lindex [$canv cget -scrollregion] 3]
2830 set ytop [expr {[yc $row] - $yscreen}]
2831 if {$ytop < 0} {
2832 set ytop 0
2834 set yf [expr {$ytop * 1.0 / $ymax}]
2836 allcanvs yview moveto $yf
2837 drawvisible
2838 if {$row ne {}} {
2839 selectline $row 0
2840 } elseif {$selid ne {}} {
2841 set pending_select $selid
2842 } else {
2843 set row [first_real_row]
2844 if {$row < $numcommits} {
2845 selectline $row 0
2846 } else {
2847 set selectfirst 1
2850 if {!$viewcomplete($n)} {
2851 if {$numcommits == 0} {
2852 show_status [mc "Reading commits..."]
2854 } elseif {$numcommits == 0} {
2855 show_status [mc "No commits selected"]
2859 # Stuff relating to the highlighting facility
2861 proc ishighlighted {row} {
2862 global vhighlights fhighlights nhighlights rhighlights
2864 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2865 return $nhighlights($row)
2867 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2868 return $vhighlights($row)
2870 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2871 return $fhighlights($row)
2873 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2874 return $rhighlights($row)
2876 return 0
2879 proc bolden {row font} {
2880 global canv linehtag selectedline boldrows
2882 lappend boldrows $row
2883 $canv itemconf $linehtag($row) -font $font
2884 if {[info exists selectedline] && $row == $selectedline} {
2885 $canv delete secsel
2886 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2887 -outline {{}} -tags secsel \
2888 -fill [$canv cget -selectbackground]]
2889 $canv lower $t
2893 proc bolden_name {row font} {
2894 global canv2 linentag selectedline boldnamerows
2896 lappend boldnamerows $row
2897 $canv2 itemconf $linentag($row) -font $font
2898 if {[info exists selectedline] && $row == $selectedline} {
2899 $canv2 delete secsel
2900 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2901 -outline {{}} -tags secsel \
2902 -fill [$canv2 cget -selectbackground]]
2903 $canv2 lower $t
2907 proc unbolden {} {
2908 global boldrows
2910 set stillbold {}
2911 foreach row $boldrows {
2912 if {![ishighlighted $row]} {
2913 bolden $row mainfont
2914 } else {
2915 lappend stillbold $row
2918 set boldrows $stillbold
2921 proc addvhighlight {n} {
2922 global hlview viewcomplete curview vhl_done vhighlights commitidx
2924 if {[info exists hlview]} {
2925 delvhighlight
2927 set hlview $n
2928 if {$n != $curview && ![info exists viewcomplete($n)]} {
2929 start_rev_list $n
2931 set vhl_done $commitidx($hlview)
2932 if {$vhl_done > 0} {
2933 drawvisible
2937 proc delvhighlight {} {
2938 global hlview vhighlights
2940 if {![info exists hlview]} return
2941 unset hlview
2942 catch {unset vhighlights}
2943 unbolden
2946 proc vhighlightmore {} {
2947 global hlview vhl_done commitidx vhighlights curview
2949 set max $commitidx($hlview)
2950 set vr [visiblerows]
2951 set r0 [lindex $vr 0]
2952 set r1 [lindex $vr 1]
2953 for {set i $vhl_done} {$i < $max} {incr i} {
2954 set id [commitonrow $i $hlview]
2955 if {[commitinview $id $curview]} {
2956 set row [rowofcommit $id]
2957 if {$r0 <= $row && $row <= $r1} {
2958 if {![highlighted $row]} {
2959 bolden $row mainfontbold
2961 set vhighlights($row) 1
2965 set vhl_done $max
2968 proc askvhighlight {row id} {
2969 global hlview vhighlights iddrawn
2971 if {[commitinview $id $hlview]} {
2972 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2973 bolden $row mainfontbold
2975 set vhighlights($row) 1
2976 } else {
2977 set vhighlights($row) 0
2981 proc hfiles_change {} {
2982 global highlight_files filehighlight fhighlights fh_serial
2983 global highlight_paths gdttype
2985 if {[info exists filehighlight]} {
2986 # delete previous highlights
2987 catch {close $filehighlight}
2988 unset filehighlight
2989 catch {unset fhighlights}
2990 unbolden
2991 unhighlight_filelist
2993 set highlight_paths {}
2994 after cancel do_file_hl $fh_serial
2995 incr fh_serial
2996 if {$highlight_files ne {}} {
2997 after 300 do_file_hl $fh_serial
3001 proc gdttype_change {name ix op} {
3002 global gdttype highlight_files findstring findpattern
3004 stopfinding
3005 if {$findstring ne {}} {
3006 if {$gdttype eq [mc "containing:"]} {
3007 if {$highlight_files ne {}} {
3008 set highlight_files {}
3009 hfiles_change
3011 findcom_change
3012 } else {
3013 if {$findpattern ne {}} {
3014 set findpattern {}
3015 findcom_change
3017 set highlight_files $findstring
3018 hfiles_change
3020 drawvisible
3022 # enable/disable findtype/findloc menus too
3025 proc find_change {name ix op} {
3026 global gdttype findstring highlight_files
3028 stopfinding
3029 if {$gdttype eq [mc "containing:"]} {
3030 findcom_change
3031 } else {
3032 if {$highlight_files ne $findstring} {
3033 set highlight_files $findstring
3034 hfiles_change
3037 drawvisible
3040 proc findcom_change args {
3041 global nhighlights boldnamerows
3042 global findpattern findtype findstring gdttype
3044 stopfinding
3045 # delete previous highlights, if any
3046 foreach row $boldnamerows {
3047 bolden_name $row mainfont
3049 set boldnamerows {}
3050 catch {unset nhighlights}
3051 unbolden
3052 unmarkmatches
3053 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3054 set findpattern {}
3055 } elseif {$findtype eq [mc "Regexp"]} {
3056 set findpattern $findstring
3057 } else {
3058 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3059 $findstring]
3060 set findpattern "*$e*"
3064 proc makepatterns {l} {
3065 set ret {}
3066 foreach e $l {
3067 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3068 if {[string index $ee end] eq "/"} {
3069 lappend ret "$ee*"
3070 } else {
3071 lappend ret $ee
3072 lappend ret "$ee/*"
3075 return $ret
3078 proc do_file_hl {serial} {
3079 global highlight_files filehighlight highlight_paths gdttype fhl_list
3081 if {$gdttype eq [mc "touching paths:"]} {
3082 if {[catch {set paths [shellsplit $highlight_files]}]} return
3083 set highlight_paths [makepatterns $paths]
3084 highlight_filelist
3085 set gdtargs [concat -- $paths]
3086 } elseif {$gdttype eq [mc "adding/removing string:"]} {
3087 set gdtargs [list "-S$highlight_files"]
3088 } else {
3089 # must be "containing:", i.e. we're searching commit info
3090 return
3092 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3093 set filehighlight [open $cmd r+]
3094 fconfigure $filehighlight -blocking 0
3095 filerun $filehighlight readfhighlight
3096 set fhl_list {}
3097 drawvisible
3098 flushhighlights
3101 proc flushhighlights {} {
3102 global filehighlight fhl_list
3104 if {[info exists filehighlight]} {
3105 lappend fhl_list {}
3106 puts $filehighlight ""
3107 flush $filehighlight
3111 proc askfilehighlight {row id} {
3112 global filehighlight fhighlights fhl_list
3114 lappend fhl_list $id
3115 set fhighlights($row) -1
3116 puts $filehighlight $id
3119 proc readfhighlight {} {
3120 global filehighlight fhighlights curview iddrawn
3121 global fhl_list find_dirn
3123 if {![info exists filehighlight]} {
3124 return 0
3126 set nr 0
3127 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3128 set line [string trim $line]
3129 set i [lsearch -exact $fhl_list $line]
3130 if {$i < 0} continue
3131 for {set j 0} {$j < $i} {incr j} {
3132 set id [lindex $fhl_list $j]
3133 if {[commitinview $id $curview]} {
3134 set fhighlights([rowofcommit $id]) 0
3137 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3138 if {$line eq {}} continue
3139 if {![commitinview $line $curview]} continue
3140 set row [rowofcommit $line]
3141 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
3142 bolden $row mainfontbold
3144 set fhighlights($row) 1
3146 if {[eof $filehighlight]} {
3147 # strange...
3148 puts "oops, git diff-tree died"
3149 catch {close $filehighlight}
3150 unset filehighlight
3151 return 0
3153 if {[info exists find_dirn]} {
3154 run findmore
3156 return 1
3159 proc doesmatch {f} {
3160 global findtype findpattern
3162 if {$findtype eq [mc "Regexp"]} {
3163 return [regexp $findpattern $f]
3164 } elseif {$findtype eq [mc "IgnCase"]} {
3165 return [string match -nocase $findpattern $f]
3166 } else {
3167 return [string match $findpattern $f]
3171 proc askfindhighlight {row id} {
3172 global nhighlights commitinfo iddrawn
3173 global findloc
3174 global markingmatches
3176 if {![info exists commitinfo($id)]} {
3177 getcommit $id
3179 set info $commitinfo($id)
3180 set isbold 0
3181 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3182 foreach f $info ty $fldtypes {
3183 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3184 [doesmatch $f]} {
3185 if {$ty eq [mc "Author"]} {
3186 set isbold 2
3187 break
3189 set isbold 1
3192 if {$isbold && [info exists iddrawn($id)]} {
3193 if {![ishighlighted $row]} {
3194 bolden $row mainfontbold
3195 if {$isbold > 1} {
3196 bolden_name $row mainfontbold
3199 if {$markingmatches} {
3200 markrowmatches $row $id
3203 set nhighlights($row) $isbold
3206 proc markrowmatches {row id} {
3207 global canv canv2 linehtag linentag commitinfo findloc
3209 set headline [lindex $commitinfo($id) 0]
3210 set author [lindex $commitinfo($id) 1]
3211 $canv delete match$row
3212 $canv2 delete match$row
3213 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3214 set m [findmatches $headline]
3215 if {$m ne {}} {
3216 markmatches $canv $row $headline $linehtag($row) $m \
3217 [$canv itemcget $linehtag($row) -font] $row
3220 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3221 set m [findmatches $author]
3222 if {$m ne {}} {
3223 markmatches $canv2 $row $author $linentag($row) $m \
3224 [$canv2 itemcget $linentag($row) -font] $row
3229 proc vrel_change {name ix op} {
3230 global highlight_related
3232 rhighlight_none
3233 if {$highlight_related ne [mc "None"]} {
3234 run drawvisible
3238 # prepare for testing whether commits are descendents or ancestors of a
3239 proc rhighlight_sel {a} {
3240 global descendent desc_todo ancestor anc_todo
3241 global highlight_related rhighlights
3243 catch {unset descendent}
3244 set desc_todo [list $a]
3245 catch {unset ancestor}
3246 set anc_todo [list $a]
3247 if {$highlight_related ne [mc "None"]} {
3248 rhighlight_none
3249 run drawvisible
3253 proc rhighlight_none {} {
3254 global rhighlights
3256 catch {unset rhighlights}
3257 unbolden
3260 proc is_descendent {a} {
3261 global curview children descendent desc_todo
3263 set v $curview
3264 set la [rowofcommit $a]
3265 set todo $desc_todo
3266 set leftover {}
3267 set done 0
3268 for {set i 0} {$i < [llength $todo]} {incr i} {
3269 set do [lindex $todo $i]
3270 if {[rowofcommit $do] < $la} {
3271 lappend leftover $do
3272 continue
3274 foreach nk $children($v,$do) {
3275 if {![info exists descendent($nk)]} {
3276 set descendent($nk) 1
3277 lappend todo $nk
3278 if {$nk eq $a} {
3279 set done 1
3283 if {$done} {
3284 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3285 return
3288 set descendent($a) 0
3289 set desc_todo $leftover
3292 proc is_ancestor {a} {
3293 global curview parents ancestor anc_todo
3295 set v $curview
3296 set la [rowofcommit $a]
3297 set todo $anc_todo
3298 set leftover {}
3299 set done 0
3300 for {set i 0} {$i < [llength $todo]} {incr i} {
3301 set do [lindex $todo $i]
3302 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3303 lappend leftover $do
3304 continue
3306 foreach np $parents($v,$do) {
3307 if {![info exists ancestor($np)]} {
3308 set ancestor($np) 1
3309 lappend todo $np
3310 if {$np eq $a} {
3311 set done 1
3315 if {$done} {
3316 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3317 return
3320 set ancestor($a) 0
3321 set anc_todo $leftover
3324 proc askrelhighlight {row id} {
3325 global descendent highlight_related iddrawn rhighlights
3326 global selectedline ancestor
3328 if {![info exists selectedline]} return
3329 set isbold 0
3330 if {$highlight_related eq [mc "Descendent"] ||
3331 $highlight_related eq [mc "Not descendent"]} {
3332 if {![info exists descendent($id)]} {
3333 is_descendent $id
3335 if {$descendent($id) == ($highlight_related eq [mc "Descendent"])} {
3336 set isbold 1
3338 } elseif {$highlight_related eq [mc "Ancestor"] ||
3339 $highlight_related eq [mc "Not ancestor"]} {
3340 if {![info exists ancestor($id)]} {
3341 is_ancestor $id
3343 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3344 set isbold 1
3347 if {[info exists iddrawn($id)]} {
3348 if {$isbold && ![ishighlighted $row]} {
3349 bolden $row mainfontbold
3352 set rhighlights($row) $isbold
3355 # Graph layout functions
3357 proc shortids {ids} {
3358 set res {}
3359 foreach id $ids {
3360 if {[llength $id] > 1} {
3361 lappend res [shortids $id]
3362 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3363 lappend res [string range $id 0 7]
3364 } else {
3365 lappend res $id
3368 return $res
3371 proc ntimes {n o} {
3372 set ret {}
3373 set o [list $o]
3374 for {set mask 1} {$mask <= $n} {incr mask $mask} {
3375 if {($n & $mask) != 0} {
3376 set ret [concat $ret $o]
3378 set o [concat $o $o]
3380 return $ret
3383 proc ordertoken {id} {
3384 global ordertok curview varcid varcstart varctok curview parents children
3385 global nullid nullid2
3387 if {[info exists ordertok($id)]} {
3388 return $ordertok($id)
3390 set origid $id
3391 set todo {}
3392 while {1} {
3393 if {[info exists varcid($curview,$id)]} {
3394 set a $varcid($curview,$id)
3395 set p [lindex $varcstart($curview) $a]
3396 } else {
3397 set p [lindex $children($curview,$id) 0]
3399 if {[info exists ordertok($p)]} {
3400 set tok $ordertok($p)
3401 break
3403 set id [first_real_child $curview,$p]
3404 if {$id eq {}} {
3405 # it's a root
3406 set tok [lindex $varctok($curview) $a]
3407 break
3409 if {[llength $parents($curview,$id)] == 1} {
3410 lappend todo [list $p {}]
3411 } else {
3412 set j [lsearch -exact $parents($curview,$id) $p]
3413 if {$j < 0} {
3414 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3416 lappend todo [list $p [strrep $j]]
3419 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3420 set p [lindex $todo $i 0]
3421 append tok [lindex $todo $i 1]
3422 set ordertok($p) $tok
3424 set ordertok($origid) $tok
3425 return $tok
3428 # Work out where id should go in idlist so that order-token
3429 # values increase from left to right
3430 proc idcol {idlist id {i 0}} {
3431 set t [ordertoken $id]
3432 if {$i < 0} {
3433 set i 0
3435 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3436 if {$i > [llength $idlist]} {
3437 set i [llength $idlist]
3439 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3440 incr i
3441 } else {
3442 if {$t > [ordertoken [lindex $idlist $i]]} {
3443 while {[incr i] < [llength $idlist] &&
3444 $t >= [ordertoken [lindex $idlist $i]]} {}
3447 return $i
3450 proc initlayout {} {
3451 global rowidlist rowisopt rowfinal displayorder parentlist
3452 global numcommits canvxmax canv
3453 global nextcolor
3454 global colormap rowtextx
3455 global selectfirst
3457 set numcommits 0
3458 set displayorder {}
3459 set parentlist {}
3460 set nextcolor 0
3461 set rowidlist {}
3462 set rowisopt {}
3463 set rowfinal {}
3464 set canvxmax [$canv cget -width]
3465 catch {unset colormap}
3466 catch {unset rowtextx}
3467 set selectfirst 1
3470 proc setcanvscroll {} {
3471 global canv canv2 canv3 numcommits linespc canvxmax canvy0
3473 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3474 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3475 $canv2 conf -scrollregion [list 0 0 0 $ymax]
3476 $canv3 conf -scrollregion [list 0 0 0 $ymax]
3479 proc visiblerows {} {
3480 global canv numcommits linespc
3482 set ymax [lindex [$canv cget -scrollregion] 3]
3483 if {$ymax eq {} || $ymax == 0} return
3484 set f [$canv yview]
3485 set y0 [expr {int([lindex $f 0] * $ymax)}]
3486 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3487 if {$r0 < 0} {
3488 set r0 0
3490 set y1 [expr {int([lindex $f 1] * $ymax)}]
3491 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3492 if {$r1 >= $numcommits} {
3493 set r1 [expr {$numcommits - 1}]
3495 return [list $r0 $r1]
3498 proc layoutmore {} {
3499 global commitidx viewcomplete curview
3500 global numcommits pending_select selectedline curview
3501 global selectfirst lastscrollset commitinterest
3503 set canshow $commitidx($curview)
3504 if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3505 if {$numcommits == 0} {
3506 allcanvs delete all
3508 set r0 $numcommits
3509 set prev $numcommits
3510 set numcommits $canshow
3511 set t [clock clicks -milliseconds]
3512 if {$prev < 100 || $viewcomplete($curview) || $t - $lastscrollset > 500} {
3513 set lastscrollset $t
3514 setcanvscroll
3516 set rows [visiblerows]
3517 set r1 [lindex $rows 1]
3518 if {$r1 >= $canshow} {
3519 set r1 [expr {$canshow - 1}]
3521 if {$r0 <= $r1} {
3522 drawcommits $r0 $r1
3524 if {[info exists pending_select] &&
3525 [commitinview $pending_select $curview]} {
3526 selectline [rowofcommit $pending_select] 1
3528 if {$selectfirst} {
3529 if {[info exists selectedline] || [info exists pending_select]} {
3530 set selectfirst 0
3531 } else {
3532 set l [first_real_row]
3533 selectline $l 1
3534 set selectfirst 0
3539 proc doshowlocalchanges {} {
3540 global curview mainheadid
3542 if {[commitinview $mainheadid $curview]} {
3543 dodiffindex
3544 } else {
3545 lappend commitinterest($mainheadid) {dodiffindex}
3549 proc dohidelocalchanges {} {
3550 global nullid nullid2 lserial curview
3552 if {[commitinview $nullid $curview]} {
3553 removerow $nullid $curview
3555 if {[commitinview $nullid2 $curview]} {
3556 removerow $nullid2 $curview
3558 incr lserial
3561 # spawn off a process to do git diff-index --cached HEAD
3562 proc dodiffindex {} {
3563 global lserial showlocalchanges
3565 if {!$showlocalchanges} return
3566 incr lserial
3567 set fd [open "|git diff-index --cached HEAD" r]
3568 fconfigure $fd -blocking 0
3569 filerun $fd [list readdiffindex $fd $lserial]
3572 proc readdiffindex {fd serial} {
3573 global mainheadid nullid nullid2 curview commitinfo commitdata lserial
3575 set isdiff 1
3576 if {[gets $fd line] < 0} {
3577 if {![eof $fd]} {
3578 return 1
3580 set isdiff 0
3582 # we only need to see one line and we don't really care what it says...
3583 close $fd
3585 if {$serial != $lserial} {
3586 return 0
3589 # now see if there are any local changes not checked in to the index
3590 set fd [open "|git diff-files" r]
3591 fconfigure $fd -blocking 0
3592 filerun $fd [list readdifffiles $fd $serial]
3594 if {$isdiff && ![commitinview $nullid2 $curview]} {
3595 # add the line for the changes in the index to the graph
3596 set hl [mc "Local changes checked in to index but not committed"]
3597 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
3598 set commitdata($nullid2) "\n $hl\n"
3599 if {[commitinview $nullid $curview]} {
3600 removerow $nullid $curview
3602 insertrow $nullid2 $mainheadid $curview
3603 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
3604 removerow $nullid2 $curview
3606 return 0
3609 proc readdifffiles {fd serial} {
3610 global mainheadid nullid nullid2 curview
3611 global commitinfo commitdata lserial
3613 set isdiff 1
3614 if {[gets $fd line] < 0} {
3615 if {![eof $fd]} {
3616 return 1
3618 set isdiff 0
3620 # we only need to see one line and we don't really care what it says...
3621 close $fd
3623 if {$serial != $lserial} {
3624 return 0
3627 if {$isdiff && ![commitinview $nullid $curview]} {
3628 # add the line for the local diff to the graph
3629 set hl [mc "Local uncommitted changes, not checked in to index"]
3630 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
3631 set commitdata($nullid) "\n $hl\n"
3632 if {[commitinview $nullid2 $curview]} {
3633 set p $nullid2
3634 } else {
3635 set p $mainheadid
3637 insertrow $nullid $p $curview
3638 } elseif {!$isdiff && [commitinview $nullid $curview]} {
3639 removerow $nullid $curview
3641 return 0
3644 proc nextuse {id row} {
3645 global curview children
3647 if {[info exists children($curview,$id)]} {
3648 foreach kid $children($curview,$id) {
3649 if {![commitinview $kid $curview]} {
3650 return -1
3652 if {[rowofcommit $kid] > $row} {
3653 return [rowofcommit $kid]
3657 if {[commitinview $id $curview]} {
3658 return [rowofcommit $id]
3660 return -1
3663 proc prevuse {id row} {
3664 global curview children
3666 set ret -1
3667 if {[info exists children($curview,$id)]} {
3668 foreach kid $children($curview,$id) {
3669 if {![commitinview $kid $curview]} break
3670 if {[rowofcommit $kid] < $row} {
3671 set ret [rowofcommit $kid]
3675 return $ret
3678 proc make_idlist {row} {
3679 global displayorder parentlist uparrowlen downarrowlen mingaplen
3680 global commitidx curview children
3682 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3683 if {$r < 0} {
3684 set r 0
3686 set ra [expr {$row - $downarrowlen}]
3687 if {$ra < 0} {
3688 set ra 0
3690 set rb [expr {$row + $uparrowlen}]
3691 if {$rb > $commitidx($curview)} {
3692 set rb $commitidx($curview)
3694 make_disporder $r [expr {$rb + 1}]
3695 set ids {}
3696 for {} {$r < $ra} {incr r} {
3697 set nextid [lindex $displayorder [expr {$r + 1}]]
3698 foreach p [lindex $parentlist $r] {
3699 if {$p eq $nextid} continue
3700 set rn [nextuse $p $r]
3701 if {$rn >= $row &&
3702 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3703 lappend ids [list [ordertoken $p] $p]
3707 for {} {$r < $row} {incr r} {
3708 set nextid [lindex $displayorder [expr {$r + 1}]]
3709 foreach p [lindex $parentlist $r] {
3710 if {$p eq $nextid} continue
3711 set rn [nextuse $p $r]
3712 if {$rn < 0 || $rn >= $row} {
3713 lappend ids [list [ordertoken $p] $p]
3717 set id [lindex $displayorder $row]
3718 lappend ids [list [ordertoken $id] $id]
3719 while {$r < $rb} {
3720 foreach p [lindex $parentlist $r] {
3721 set firstkid [lindex $children($curview,$p) 0]
3722 if {[rowofcommit $firstkid] < $row} {
3723 lappend ids [list [ordertoken $p] $p]
3726 incr r
3727 set id [lindex $displayorder $r]
3728 if {$id ne {}} {
3729 set firstkid [lindex $children($curview,$id) 0]
3730 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3731 lappend ids [list [ordertoken $id] $id]
3735 set idlist {}
3736 foreach idx [lsort -unique $ids] {
3737 lappend idlist [lindex $idx 1]
3739 return $idlist
3742 proc rowsequal {a b} {
3743 while {[set i [lsearch -exact $a {}]] >= 0} {
3744 set a [lreplace $a $i $i]
3746 while {[set i [lsearch -exact $b {}]] >= 0} {
3747 set b [lreplace $b $i $i]
3749 return [expr {$a eq $b}]
3752 proc makeupline {id row rend col} {
3753 global rowidlist uparrowlen downarrowlen mingaplen
3755 for {set r $rend} {1} {set r $rstart} {
3756 set rstart [prevuse $id $r]
3757 if {$rstart < 0} return
3758 if {$rstart < $row} break
3760 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3761 set rstart [expr {$rend - $uparrowlen - 1}]
3763 for {set r $rstart} {[incr r] <= $row} {} {
3764 set idlist [lindex $rowidlist $r]
3765 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3766 set col [idcol $idlist $id $col]
3767 lset rowidlist $r [linsert $idlist $col $id]
3768 changedrow $r
3773 proc layoutrows {row endrow} {
3774 global rowidlist rowisopt rowfinal displayorder
3775 global uparrowlen downarrowlen maxwidth mingaplen
3776 global children parentlist
3777 global commitidx viewcomplete curview
3779 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3780 set idlist {}
3781 if {$row > 0} {
3782 set rm1 [expr {$row - 1}]
3783 foreach id [lindex $rowidlist $rm1] {
3784 if {$id ne {}} {
3785 lappend idlist $id
3788 set final [lindex $rowfinal $rm1]
3790 for {} {$row < $endrow} {incr row} {
3791 set rm1 [expr {$row - 1}]
3792 if {$rm1 < 0 || $idlist eq {}} {
3793 set idlist [make_idlist $row]
3794 set final 1
3795 } else {
3796 set id [lindex $displayorder $rm1]
3797 set col [lsearch -exact $idlist $id]
3798 set idlist [lreplace $idlist $col $col]
3799 foreach p [lindex $parentlist $rm1] {
3800 if {[lsearch -exact $idlist $p] < 0} {
3801 set col [idcol $idlist $p $col]
3802 set idlist [linsert $idlist $col $p]
3803 # if not the first child, we have to insert a line going up
3804 if {$id ne [lindex $children($curview,$p) 0]} {
3805 makeupline $p $rm1 $row $col
3809 set id [lindex $displayorder $row]
3810 if {$row > $downarrowlen} {
3811 set termrow [expr {$row - $downarrowlen - 1}]
3812 foreach p [lindex $parentlist $termrow] {
3813 set i [lsearch -exact $idlist $p]
3814 if {$i < 0} continue
3815 set nr [nextuse $p $termrow]
3816 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3817 set idlist [lreplace $idlist $i $i]
3821 set col [lsearch -exact $idlist $id]
3822 if {$col < 0} {
3823 set col [idcol $idlist $id]
3824 set idlist [linsert $idlist $col $id]
3825 if {$children($curview,$id) ne {}} {
3826 makeupline $id $rm1 $row $col
3829 set r [expr {$row + $uparrowlen - 1}]
3830 if {$r < $commitidx($curview)} {
3831 set x $col
3832 foreach p [lindex $parentlist $r] {
3833 if {[lsearch -exact $idlist $p] >= 0} continue
3834 set fk [lindex $children($curview,$p) 0]
3835 if {[rowofcommit $fk] < $row} {
3836 set x [idcol $idlist $p $x]
3837 set idlist [linsert $idlist $x $p]
3840 if {[incr r] < $commitidx($curview)} {
3841 set p [lindex $displayorder $r]
3842 if {[lsearch -exact $idlist $p] < 0} {
3843 set fk [lindex $children($curview,$p) 0]
3844 if {$fk ne {} && [rowofcommit $fk] < $row} {
3845 set x [idcol $idlist $p $x]
3846 set idlist [linsert $idlist $x $p]
3852 if {$final && !$viewcomplete($curview) &&
3853 $row + $uparrowlen + $mingaplen + $downarrowlen
3854 >= $commitidx($curview)} {
3855 set final 0
3857 set l [llength $rowidlist]
3858 if {$row == $l} {
3859 lappend rowidlist $idlist
3860 lappend rowisopt 0
3861 lappend rowfinal $final
3862 } elseif {$row < $l} {
3863 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3864 lset rowidlist $row $idlist
3865 changedrow $row
3867 lset rowfinal $row $final
3868 } else {
3869 set pad [ntimes [expr {$row - $l}] {}]
3870 set rowidlist [concat $rowidlist $pad]
3871 lappend rowidlist $idlist
3872 set rowfinal [concat $rowfinal $pad]
3873 lappend rowfinal $final
3874 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3877 return $row
3880 proc changedrow {row} {
3881 global displayorder iddrawn rowisopt need_redisplay
3883 set l [llength $rowisopt]
3884 if {$row < $l} {
3885 lset rowisopt $row 0
3886 if {$row + 1 < $l} {
3887 lset rowisopt [expr {$row + 1}] 0
3888 if {$row + 2 < $l} {
3889 lset rowisopt [expr {$row + 2}] 0
3893 set id [lindex $displayorder $row]
3894 if {[info exists iddrawn($id)]} {
3895 set need_redisplay 1
3899 proc insert_pad {row col npad} {
3900 global rowidlist
3902 set pad [ntimes $npad {}]
3903 set idlist [lindex $rowidlist $row]
3904 set bef [lrange $idlist 0 [expr {$col - 1}]]
3905 set aft [lrange $idlist $col end]
3906 set i [lsearch -exact $aft {}]
3907 if {$i > 0} {
3908 set aft [lreplace $aft $i $i]
3910 lset rowidlist $row [concat $bef $pad $aft]
3911 changedrow $row
3914 proc optimize_rows {row col endrow} {
3915 global rowidlist rowisopt displayorder curview children
3917 if {$row < 1} {
3918 set row 1
3920 for {} {$row < $endrow} {incr row; set col 0} {
3921 if {[lindex $rowisopt $row]} continue
3922 set haspad 0
3923 set y0 [expr {$row - 1}]
3924 set ym [expr {$row - 2}]
3925 set idlist [lindex $rowidlist $row]
3926 set previdlist [lindex $rowidlist $y0]
3927 if {$idlist eq {} || $previdlist eq {}} continue
3928 if {$ym >= 0} {
3929 set pprevidlist [lindex $rowidlist $ym]
3930 if {$pprevidlist eq {}} continue
3931 } else {
3932 set pprevidlist {}
3934 set x0 -1
3935 set xm -1
3936 for {} {$col < [llength $idlist]} {incr col} {
3937 set id [lindex $idlist $col]
3938 if {[lindex $previdlist $col] eq $id} continue
3939 if {$id eq {}} {
3940 set haspad 1
3941 continue
3943 set x0 [lsearch -exact $previdlist $id]
3944 if {$x0 < 0} continue
3945 set z [expr {$x0 - $col}]
3946 set isarrow 0
3947 set z0 {}
3948 if {$ym >= 0} {
3949 set xm [lsearch -exact $pprevidlist $id]
3950 if {$xm >= 0} {
3951 set z0 [expr {$xm - $x0}]
3954 if {$z0 eq {}} {
3955 # if row y0 is the first child of $id then it's not an arrow
3956 if {[lindex $children($curview,$id) 0] ne
3957 [lindex $displayorder $y0]} {
3958 set isarrow 1
3961 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3962 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3963 set isarrow 1
3965 # Looking at lines from this row to the previous row,
3966 # make them go straight up if they end in an arrow on
3967 # the previous row; otherwise make them go straight up
3968 # or at 45 degrees.
3969 if {$z < -1 || ($z < 0 && $isarrow)} {
3970 # Line currently goes left too much;
3971 # insert pads in the previous row, then optimize it
3972 set npad [expr {-1 - $z + $isarrow}]
3973 insert_pad $y0 $x0 $npad
3974 if {$y0 > 0} {
3975 optimize_rows $y0 $x0 $row
3977 set previdlist [lindex $rowidlist $y0]
3978 set x0 [lsearch -exact $previdlist $id]
3979 set z [expr {$x0 - $col}]
3980 if {$z0 ne {}} {
3981 set pprevidlist [lindex $rowidlist $ym]
3982 set xm [lsearch -exact $pprevidlist $id]
3983 set z0 [expr {$xm - $x0}]
3985 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3986 # Line currently goes right too much;
3987 # insert pads in this line
3988 set npad [expr {$z - 1 + $isarrow}]
3989 insert_pad $row $col $npad
3990 set idlist [lindex $rowidlist $row]
3991 incr col $npad
3992 set z [expr {$x0 - $col}]
3993 set haspad 1
3995 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3996 # this line links to its first child on row $row-2
3997 set id [lindex $displayorder $ym]
3998 set xc [lsearch -exact $pprevidlist $id]
3999 if {$xc >= 0} {
4000 set z0 [expr {$xc - $x0}]
4003 # avoid lines jigging left then immediately right
4004 if {$z0 ne {} && $z < 0 && $z0 > 0} {
4005 insert_pad $y0 $x0 1
4006 incr x0
4007 optimize_rows $y0 $x0 $row
4008 set previdlist [lindex $rowidlist $y0]
4011 if {!$haspad} {
4012 # Find the first column that doesn't have a line going right
4013 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4014 set id [lindex $idlist $col]
4015 if {$id eq {}} break
4016 set x0 [lsearch -exact $previdlist $id]
4017 if {$x0 < 0} {
4018 # check if this is the link to the first child
4019 set kid [lindex $displayorder $y0]
4020 if {[lindex $children($curview,$id) 0] eq $kid} {
4021 # it is, work out offset to child
4022 set x0 [lsearch -exact $previdlist $kid]
4025 if {$x0 <= $col} break
4027 # Insert a pad at that column as long as it has a line and
4028 # isn't the last column
4029 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4030 set idlist [linsert $idlist $col {}]
4031 lset rowidlist $row $idlist
4032 changedrow $row
4038 proc xc {row col} {
4039 global canvx0 linespc
4040 return [expr {$canvx0 + $col * $linespc}]
4043 proc yc {row} {
4044 global canvy0 linespc
4045 return [expr {$canvy0 + $row * $linespc}]
4048 proc linewidth {id} {
4049 global thickerline lthickness
4051 set wid $lthickness
4052 if {[info exists thickerline] && $id eq $thickerline} {
4053 set wid [expr {2 * $lthickness}]
4055 return $wid
4058 proc rowranges {id} {
4059 global curview children uparrowlen downarrowlen
4060 global rowidlist
4062 set kids $children($curview,$id)
4063 if {$kids eq {}} {
4064 return {}
4066 set ret {}
4067 lappend kids $id
4068 foreach child $kids {
4069 if {![commitinview $child $curview]} break
4070 set row [rowofcommit $child]
4071 if {![info exists prev]} {
4072 lappend ret [expr {$row + 1}]
4073 } else {
4074 if {$row <= $prevrow} {
4075 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4077 # see if the line extends the whole way from prevrow to row
4078 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4079 [lsearch -exact [lindex $rowidlist \
4080 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4081 # it doesn't, see where it ends
4082 set r [expr {$prevrow + $downarrowlen}]
4083 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4084 while {[incr r -1] > $prevrow &&
4085 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4086 } else {
4087 while {[incr r] <= $row &&
4088 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4089 incr r -1
4091 lappend ret $r
4092 # see where it starts up again
4093 set r [expr {$row - $uparrowlen}]
4094 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4095 while {[incr r] < $row &&
4096 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4097 } else {
4098 while {[incr r -1] >= $prevrow &&
4099 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4100 incr r
4102 lappend ret $r
4105 if {$child eq $id} {
4106 lappend ret $row
4108 set prev $child
4109 set prevrow $row
4111 return $ret
4114 proc drawlineseg {id row endrow arrowlow} {
4115 global rowidlist displayorder iddrawn linesegs
4116 global canv colormap linespc curview maxlinelen parentlist
4118 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4119 set le [expr {$row + 1}]
4120 set arrowhigh 1
4121 while {1} {
4122 set c [lsearch -exact [lindex $rowidlist $le] $id]
4123 if {$c < 0} {
4124 incr le -1
4125 break
4127 lappend cols $c
4128 set x [lindex $displayorder $le]
4129 if {$x eq $id} {
4130 set arrowhigh 0
4131 break
4133 if {[info exists iddrawn($x)] || $le == $endrow} {
4134 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4135 if {$c >= 0} {
4136 lappend cols $c
4137 set arrowhigh 0
4139 break
4141 incr le
4143 if {$le <= $row} {
4144 return $row
4147 set lines {}
4148 set i 0
4149 set joinhigh 0
4150 if {[info exists linesegs($id)]} {
4151 set lines $linesegs($id)
4152 foreach li $lines {
4153 set r0 [lindex $li 0]
4154 if {$r0 > $row} {
4155 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4156 set joinhigh 1
4158 break
4160 incr i
4163 set joinlow 0
4164 if {$i > 0} {
4165 set li [lindex $lines [expr {$i-1}]]
4166 set r1 [lindex $li 1]
4167 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4168 set joinlow 1
4172 set x [lindex $cols [expr {$le - $row}]]
4173 set xp [lindex $cols [expr {$le - 1 - $row}]]
4174 set dir [expr {$xp - $x}]
4175 if {$joinhigh} {
4176 set ith [lindex $lines $i 2]
4177 set coords [$canv coords $ith]
4178 set ah [$canv itemcget $ith -arrow]
4179 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4180 set x2 [lindex $cols [expr {$le + 1 - $row}]]
4181 if {$x2 ne {} && $x - $x2 == $dir} {
4182 set coords [lrange $coords 0 end-2]
4184 } else {
4185 set coords [list [xc $le $x] [yc $le]]
4187 if {$joinlow} {
4188 set itl [lindex $lines [expr {$i-1}] 2]
4189 set al [$canv itemcget $itl -arrow]
4190 set arrowlow [expr {$al eq "last" || $al eq "both"}]
4191 } elseif {$arrowlow} {
4192 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4193 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4194 set arrowlow 0
4197 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4198 for {set y $le} {[incr y -1] > $row} {} {
4199 set x $xp
4200 set xp [lindex $cols [expr {$y - 1 - $row}]]
4201 set ndir [expr {$xp - $x}]
4202 if {$dir != $ndir || $xp < 0} {
4203 lappend coords [xc $y $x] [yc $y]
4205 set dir $ndir
4207 if {!$joinlow} {
4208 if {$xp < 0} {
4209 # join parent line to first child
4210 set ch [lindex $displayorder $row]
4211 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4212 if {$xc < 0} {
4213 puts "oops: drawlineseg: child $ch not on row $row"
4214 } elseif {$xc != $x} {
4215 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4216 set d [expr {int(0.5 * $linespc)}]
4217 set x1 [xc $row $x]
4218 if {$xc < $x} {
4219 set x2 [expr {$x1 - $d}]
4220 } else {
4221 set x2 [expr {$x1 + $d}]
4223 set y2 [yc $row]
4224 set y1 [expr {$y2 + $d}]
4225 lappend coords $x1 $y1 $x2 $y2
4226 } elseif {$xc < $x - 1} {
4227 lappend coords [xc $row [expr {$x-1}]] [yc $row]
4228 } elseif {$xc > $x + 1} {
4229 lappend coords [xc $row [expr {$x+1}]] [yc $row]
4231 set x $xc
4233 lappend coords [xc $row $x] [yc $row]
4234 } else {
4235 set xn [xc $row $xp]
4236 set yn [yc $row]
4237 lappend coords $xn $yn
4239 if {!$joinhigh} {
4240 assigncolor $id
4241 set t [$canv create line $coords -width [linewidth $id] \
4242 -fill $colormap($id) -tags lines.$id -arrow $arrow]
4243 $canv lower $t
4244 bindline $t $id
4245 set lines [linsert $lines $i [list $row $le $t]]
4246 } else {
4247 $canv coords $ith $coords
4248 if {$arrow ne $ah} {
4249 $canv itemconf $ith -arrow $arrow
4251 lset lines $i 0 $row
4253 } else {
4254 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4255 set ndir [expr {$xo - $xp}]
4256 set clow [$canv coords $itl]
4257 if {$dir == $ndir} {
4258 set clow [lrange $clow 2 end]
4260 set coords [concat $coords $clow]
4261 if {!$joinhigh} {
4262 lset lines [expr {$i-1}] 1 $le
4263 } else {
4264 # coalesce two pieces
4265 $canv delete $ith
4266 set b [lindex $lines [expr {$i-1}] 0]
4267 set e [lindex $lines $i 1]
4268 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4270 $canv coords $itl $coords
4271 if {$arrow ne $al} {
4272 $canv itemconf $itl -arrow $arrow
4276 set linesegs($id) $lines
4277 return $le
4280 proc drawparentlinks {id row} {
4281 global rowidlist canv colormap curview parentlist
4282 global idpos linespc
4284 set rowids [lindex $rowidlist $row]
4285 set col [lsearch -exact $rowids $id]
4286 if {$col < 0} return
4287 set olds [lindex $parentlist $row]
4288 set row2 [expr {$row + 1}]
4289 set x [xc $row $col]
4290 set y [yc $row]
4291 set y2 [yc $row2]
4292 set d [expr {int(0.5 * $linespc)}]
4293 set ymid [expr {$y + $d}]
4294 set ids [lindex $rowidlist $row2]
4295 # rmx = right-most X coord used
4296 set rmx 0
4297 foreach p $olds {
4298 set i [lsearch -exact $ids $p]
4299 if {$i < 0} {
4300 puts "oops, parent $p of $id not in list"
4301 continue
4303 set x2 [xc $row2 $i]
4304 if {$x2 > $rmx} {
4305 set rmx $x2
4307 set j [lsearch -exact $rowids $p]
4308 if {$j < 0} {
4309 # drawlineseg will do this one for us
4310 continue
4312 assigncolor $p
4313 # should handle duplicated parents here...
4314 set coords [list $x $y]
4315 if {$i != $col} {
4316 # if attaching to a vertical segment, draw a smaller
4317 # slant for visual distinctness
4318 if {$i == $j} {
4319 if {$i < $col} {
4320 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4321 } else {
4322 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4324 } elseif {$i < $col && $i < $j} {
4325 # segment slants towards us already
4326 lappend coords [xc $row $j] $y
4327 } else {
4328 if {$i < $col - 1} {
4329 lappend coords [expr {$x2 + $linespc}] $y
4330 } elseif {$i > $col + 1} {
4331 lappend coords [expr {$x2 - $linespc}] $y
4333 lappend coords $x2 $y2
4335 } else {
4336 lappend coords $x2 $y2
4338 set t [$canv create line $coords -width [linewidth $p] \
4339 -fill $colormap($p) -tags lines.$p]
4340 $canv lower $t
4341 bindline $t $p
4343 if {$rmx > [lindex $idpos($id) 1]} {
4344 lset idpos($id) 1 $rmx
4345 redrawtags $id
4349 proc drawlines {id} {
4350 global canv
4352 $canv itemconf lines.$id -width [linewidth $id]
4355 proc drawcmittext {id row col} {
4356 global linespc canv canv2 canv3 fgcolor curview
4357 global cmitlisted commitinfo rowidlist parentlist
4358 global rowtextx idpos idtags idheads idotherrefs
4359 global linehtag linentag linedtag selectedline
4360 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4362 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4363 set listed $cmitlisted($curview,$id)
4364 if {$id eq $nullid} {
4365 set ofill red
4366 } elseif {$id eq $nullid2} {
4367 set ofill green
4368 } else {
4369 set ofill [expr {$listed != 0? "blue": "white"}]
4371 set x [xc $row $col]
4372 set y [yc $row]
4373 set orad [expr {$linespc / 3}]
4374 if {$listed <= 1} {
4375 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4376 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4377 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4378 } elseif {$listed == 2} {
4379 # triangle pointing left for left-side commits
4380 set t [$canv create polygon \
4381 [expr {$x - $orad}] $y \
4382 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4383 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4384 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4385 } else {
4386 # triangle pointing right for right-side commits
4387 set t [$canv create polygon \
4388 [expr {$x + $orad - 1}] $y \
4389 [expr {$x - $orad}] [expr {$y - $orad}] \
4390 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4391 -fill $ofill -outline $fgcolor -width 1 -tags circle]
4393 $canv raise $t
4394 $canv bind $t <1> {selcanvline {} %x %y}
4395 set rmx [llength [lindex $rowidlist $row]]
4396 set olds [lindex $parentlist $row]
4397 if {$olds ne {}} {
4398 set nextids [lindex $rowidlist [expr {$row + 1}]]
4399 foreach p $olds {
4400 set i [lsearch -exact $nextids $p]
4401 if {$i > $rmx} {
4402 set rmx $i
4406 set xt [xc $row $rmx]
4407 set rowtextx($row) $xt
4408 set idpos($id) [list $x $xt $y]
4409 if {[info exists idtags($id)] || [info exists idheads($id)]
4410 || [info exists idotherrefs($id)]} {
4411 set xt [drawtags $id $x $xt $y]
4413 set headline [lindex $commitinfo($id) 0]
4414 set name [lindex $commitinfo($id) 1]
4415 set date [lindex $commitinfo($id) 2]
4416 set date [formatdate $date]
4417 set font mainfont
4418 set nfont mainfont
4419 set isbold [ishighlighted $row]
4420 if {$isbold > 0} {
4421 lappend boldrows $row
4422 set font mainfontbold
4423 if {$isbold > 1} {
4424 lappend boldnamerows $row
4425 set nfont mainfontbold
4428 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4429 -text $headline -font $font -tags text]
4430 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4431 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4432 -text $name -font $nfont -tags text]
4433 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4434 -text $date -font mainfont -tags text]
4435 if {[info exists selectedline] && $selectedline == $row} {
4436 make_secsel $row
4438 set xr [expr {$xt + [font measure $font $headline]}]
4439 if {$xr > $canvxmax} {
4440 set canvxmax $xr
4441 setcanvscroll
4445 proc drawcmitrow {row} {
4446 global displayorder rowidlist nrows_drawn
4447 global iddrawn markingmatches
4448 global commitinfo numcommits
4449 global filehighlight fhighlights findpattern nhighlights
4450 global hlview vhighlights
4451 global highlight_related rhighlights
4453 if {$row >= $numcommits} return
4455 set id [lindex $displayorder $row]
4456 if {[info exists hlview] && ![info exists vhighlights($row)]} {
4457 askvhighlight $row $id
4459 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
4460 askfilehighlight $row $id
4462 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
4463 askfindhighlight $row $id
4465 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($row)]} {
4466 askrelhighlight $row $id
4468 if {![info exists iddrawn($id)]} {
4469 set col [lsearch -exact [lindex $rowidlist $row] $id]
4470 if {$col < 0} {
4471 puts "oops, row $row id $id not in list"
4472 return
4474 if {![info exists commitinfo($id)]} {
4475 getcommit $id
4477 assigncolor $id
4478 drawcmittext $id $row $col
4479 set iddrawn($id) 1
4480 incr nrows_drawn
4482 if {$markingmatches} {
4483 markrowmatches $row $id
4487 proc drawcommits {row {endrow {}}} {
4488 global numcommits iddrawn displayorder curview need_redisplay
4489 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4491 if {$row < 0} {
4492 set row 0
4494 if {$endrow eq {}} {
4495 set endrow $row
4497 if {$endrow >= $numcommits} {
4498 set endrow [expr {$numcommits - 1}]
4501 set rl1 [expr {$row - $downarrowlen - 3}]
4502 if {$rl1 < 0} {
4503 set rl1 0
4505 set ro1 [expr {$row - 3}]
4506 if {$ro1 < 0} {
4507 set ro1 0
4509 set r2 [expr {$endrow + $uparrowlen + 3}]
4510 if {$r2 > $numcommits} {
4511 set r2 $numcommits
4513 for {set r $rl1} {$r < $r2} {incr r} {
4514 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4515 if {$rl1 < $r} {
4516 layoutrows $rl1 $r
4518 set rl1 [expr {$r + 1}]
4521 if {$rl1 < $r} {
4522 layoutrows $rl1 $r
4524 optimize_rows $ro1 0 $r2
4525 if {$need_redisplay || $nrows_drawn > 2000} {
4526 clear_display
4527 drawvisible
4530 # make the lines join to already-drawn rows either side
4531 set r [expr {$row - 1}]
4532 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4533 set r $row
4535 set er [expr {$endrow + 1}]
4536 if {$er >= $numcommits ||
4537 ![info exists iddrawn([lindex $displayorder $er])]} {
4538 set er $endrow
4540 for {} {$r <= $er} {incr r} {
4541 set id [lindex $displayorder $r]
4542 set wasdrawn [info exists iddrawn($id)]
4543 drawcmitrow $r
4544 if {$r == $er} break
4545 set nextid [lindex $displayorder [expr {$r + 1}]]
4546 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4547 drawparentlinks $id $r
4549 set rowids [lindex $rowidlist $r]
4550 foreach lid $rowids {
4551 if {$lid eq {}} continue
4552 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4553 if {$lid eq $id} {
4554 # see if this is the first child of any of its parents
4555 foreach p [lindex $parentlist $r] {
4556 if {[lsearch -exact $rowids $p] < 0} {
4557 # make this line extend up to the child
4558 set lineend($p) [drawlineseg $p $r $er 0]
4561 } else {
4562 set lineend($lid) [drawlineseg $lid $r $er 1]
4568 proc undolayout {row} {
4569 global uparrowlen mingaplen downarrowlen
4570 global rowidlist rowisopt rowfinal need_redisplay
4572 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4573 if {$r < 0} {
4574 set r 0
4576 if {[llength $rowidlist] > $r} {
4577 incr r -1
4578 set rowidlist [lrange $rowidlist 0 $r]
4579 set rowfinal [lrange $rowfinal 0 $r]
4580 set rowisopt [lrange $rowisopt 0 $r]
4581 set need_redisplay 1
4582 run drawvisible
4586 proc drawvisible {} {
4587 global canv linespc curview vrowmod selectedline targetrow targetid
4588 global need_redisplay cscroll numcommits
4590 set fs [$canv yview]
4591 set ymax [lindex [$canv cget -scrollregion] 3]
4592 if {$ymax eq {} || $ymax == 0} return
4593 set f0 [lindex $fs 0]
4594 set f1 [lindex $fs 1]
4595 set y0 [expr {int($f0 * $ymax)}]
4596 set y1 [expr {int($f1 * $ymax)}]
4598 if {[info exists targetid]} {
4599 if {[commitinview $targetid $curview]} {
4600 set r [rowofcommit $targetid]
4601 if {$r != $targetrow} {
4602 # Fix up the scrollregion and change the scrolling position
4603 # now that our target row has moved.
4604 set diff [expr {($r - $targetrow) * $linespc}]
4605 set targetrow $r
4606 setcanvscroll
4607 set ymax [lindex [$canv cget -scrollregion] 3]
4608 incr y0 $diff
4609 incr y1 $diff
4610 set f0 [expr {$y0 / $ymax}]
4611 set f1 [expr {$y1 / $ymax}]
4612 allcanvs yview moveto $f0
4613 $cscroll set $f0 $f1
4614 set need_redisplay 1
4616 } else {
4617 unset targetid
4621 set row [expr {int(($y0 - 3) / $linespc) - 1}]
4622 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4623 if {$endrow >= $vrowmod($curview)} {
4624 update_arcrows $curview
4626 if {[info exists selectedline] &&
4627 $row <= $selectedline && $selectedline <= $endrow} {
4628 set targetrow $selectedline
4629 } else {
4630 set targetrow [expr {int(($row + $endrow) / 2)}]
4632 if {$targetrow >= $numcommits} {
4633 set targetrow [expr {$numcommits - 1}]
4635 set targetid [commitonrow $targetrow]
4636 drawcommits $row $endrow
4639 proc clear_display {} {
4640 global iddrawn linesegs need_redisplay nrows_drawn
4641 global vhighlights fhighlights nhighlights rhighlights
4643 allcanvs delete all
4644 catch {unset iddrawn}
4645 catch {unset linesegs}
4646 catch {unset vhighlights}
4647 catch {unset fhighlights}
4648 catch {unset nhighlights}
4649 catch {unset rhighlights}
4650 set need_redisplay 0
4651 set nrows_drawn 0
4654 proc findcrossings {id} {
4655 global rowidlist parentlist numcommits displayorder
4657 set cross {}
4658 set ccross {}
4659 foreach {s e} [rowranges $id] {
4660 if {$e >= $numcommits} {
4661 set e [expr {$numcommits - 1}]
4663 if {$e <= $s} continue
4664 for {set row $e} {[incr row -1] >= $s} {} {
4665 set x [lsearch -exact [lindex $rowidlist $row] $id]
4666 if {$x < 0} break
4667 set olds [lindex $parentlist $row]
4668 set kid [lindex $displayorder $row]
4669 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4670 if {$kidx < 0} continue
4671 set nextrow [lindex $rowidlist [expr {$row + 1}]]
4672 foreach p $olds {
4673 set px [lsearch -exact $nextrow $p]
4674 if {$px < 0} continue
4675 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4676 if {[lsearch -exact $ccross $p] >= 0} continue
4677 if {$x == $px + ($kidx < $px? -1: 1)} {
4678 lappend ccross $p
4679 } elseif {[lsearch -exact $cross $p] < 0} {
4680 lappend cross $p
4686 return [concat $ccross {{}} $cross]
4689 proc assigncolor {id} {
4690 global colormap colors nextcolor
4691 global parents children children curview
4693 if {[info exists colormap($id)]} return
4694 set ncolors [llength $colors]
4695 if {[info exists children($curview,$id)]} {
4696 set kids $children($curview,$id)
4697 } else {
4698 set kids {}
4700 if {[llength $kids] == 1} {
4701 set child [lindex $kids 0]
4702 if {[info exists colormap($child)]
4703 && [llength $parents($curview,$child)] == 1} {
4704 set colormap($id) $colormap($child)
4705 return
4708 set badcolors {}
4709 set origbad {}
4710 foreach x [findcrossings $id] {
4711 if {$x eq {}} {
4712 # delimiter between corner crossings and other crossings
4713 if {[llength $badcolors] >= $ncolors - 1} break
4714 set origbad $badcolors
4716 if {[info exists colormap($x)]
4717 && [lsearch -exact $badcolors $colormap($x)] < 0} {
4718 lappend badcolors $colormap($x)
4721 if {[llength $badcolors] >= $ncolors} {
4722 set badcolors $origbad
4724 set origbad $badcolors
4725 if {[llength $badcolors] < $ncolors - 1} {
4726 foreach child $kids {
4727 if {[info exists colormap($child)]
4728 && [lsearch -exact $badcolors $colormap($child)] < 0} {
4729 lappend badcolors $colormap($child)
4731 foreach p $parents($curview,$child) {
4732 if {[info exists colormap($p)]
4733 && [lsearch -exact $badcolors $colormap($p)] < 0} {
4734 lappend badcolors $colormap($p)
4738 if {[llength $badcolors] >= $ncolors} {
4739 set badcolors $origbad
4742 for {set i 0} {$i <= $ncolors} {incr i} {
4743 set c [lindex $colors $nextcolor]
4744 if {[incr nextcolor] >= $ncolors} {
4745 set nextcolor 0
4747 if {[lsearch -exact $badcolors $c]} break
4749 set colormap($id) $c
4752 proc bindline {t id} {
4753 global canv
4755 $canv bind $t <Enter> "lineenter %x %y $id"
4756 $canv bind $t <Motion> "linemotion %x %y $id"
4757 $canv bind $t <Leave> "lineleave $id"
4758 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4761 proc drawtags {id x xt y1} {
4762 global idtags idheads idotherrefs mainhead
4763 global linespc lthickness
4764 global canv rowtextx curview fgcolor bgcolor
4766 set marks {}
4767 set ntags 0
4768 set nheads 0
4769 if {[info exists idtags($id)]} {
4770 set marks $idtags($id)
4771 set ntags [llength $marks]
4773 if {[info exists idheads($id)]} {
4774 set marks [concat $marks $idheads($id)]
4775 set nheads [llength $idheads($id)]
4777 if {[info exists idotherrefs($id)]} {
4778 set marks [concat $marks $idotherrefs($id)]
4780 if {$marks eq {}} {
4781 return $xt
4784 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4785 set yt [expr {$y1 - 0.5 * $linespc}]
4786 set yb [expr {$yt + $linespc - 1}]
4787 set xvals {}
4788 set wvals {}
4789 set i -1
4790 foreach tag $marks {
4791 incr i
4792 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4793 set wid [font measure mainfontbold $tag]
4794 } else {
4795 set wid [font measure mainfont $tag]
4797 lappend xvals $xt
4798 lappend wvals $wid
4799 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4801 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4802 -width $lthickness -fill black -tags tag.$id]
4803 $canv lower $t
4804 foreach tag $marks x $xvals wid $wvals {
4805 set xl [expr {$x + $delta}]
4806 set xr [expr {$x + $delta + $wid + $lthickness}]
4807 set font mainfont
4808 if {[incr ntags -1] >= 0} {
4809 # draw a tag
4810 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4811 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4812 -width 1 -outline black -fill yellow -tags tag.$id]
4813 $canv bind $t <1> [list showtag $tag 1]
4814 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4815 } else {
4816 # draw a head or other ref
4817 if {[incr nheads -1] >= 0} {
4818 set col green
4819 if {$tag eq $mainhead} {
4820 set font mainfontbold
4822 } else {
4823 set col "#ddddff"
4825 set xl [expr {$xl - $delta/2}]
4826 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4827 -width 1 -outline black -fill $col -tags tag.$id
4828 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4829 set rwid [font measure mainfont $remoteprefix]
4830 set xi [expr {$x + 1}]
4831 set yti [expr {$yt + 1}]
4832 set xri [expr {$x + $rwid}]
4833 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4834 -width 0 -fill "#ffddaa" -tags tag.$id
4837 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4838 -font $font -tags [list tag.$id text]]
4839 if {$ntags >= 0} {
4840 $canv bind $t <1> [list showtag $tag 1]
4841 } elseif {$nheads >= 0} {
4842 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4845 return $xt
4848 proc xcoord {i level ln} {
4849 global canvx0 xspc1 xspc2
4851 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4852 if {$i > 0 && $i == $level} {
4853 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4854 } elseif {$i > $level} {
4855 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4857 return $x
4860 proc show_status {msg} {
4861 global canv fgcolor
4863 clear_display
4864 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4865 -tags text -fill $fgcolor
4868 # Don't change the text pane cursor if it is currently the hand cursor,
4869 # showing that we are over a sha1 ID link.
4870 proc settextcursor {c} {
4871 global ctext curtextcursor
4873 if {[$ctext cget -cursor] == $curtextcursor} {
4874 $ctext config -cursor $c
4876 set curtextcursor $c
4879 proc nowbusy {what {name {}}} {
4880 global isbusy busyname statusw
4882 if {[array names isbusy] eq {}} {
4883 . config -cursor watch
4884 settextcursor watch
4886 set isbusy($what) 1
4887 set busyname($what) $name
4888 if {$name ne {}} {
4889 $statusw conf -text $name
4893 proc notbusy {what} {
4894 global isbusy maincursor textcursor busyname statusw
4896 catch {
4897 unset isbusy($what)
4898 if {$busyname($what) ne {} &&
4899 [$statusw cget -text] eq $busyname($what)} {
4900 $statusw conf -text {}
4903 if {[array names isbusy] eq {}} {
4904 . config -cursor $maincursor
4905 settextcursor $textcursor
4909 proc findmatches {f} {
4910 global findtype findstring
4911 if {$findtype == [mc "Regexp"]} {
4912 set matches [regexp -indices -all -inline $findstring $f]
4913 } else {
4914 set fs $findstring
4915 if {$findtype == [mc "IgnCase"]} {
4916 set f [string tolower $f]
4917 set fs [string tolower $fs]
4919 set matches {}
4920 set i 0
4921 set l [string length $fs]
4922 while {[set j [string first $fs $f $i]] >= 0} {
4923 lappend matches [list $j [expr {$j+$l-1}]]
4924 set i [expr {$j + $l}]
4927 return $matches
4930 proc dofind {{dirn 1} {wrap 1}} {
4931 global findstring findstartline findcurline selectedline numcommits
4932 global gdttype filehighlight fh_serial find_dirn findallowwrap
4934 if {[info exists find_dirn]} {
4935 if {$find_dirn == $dirn} return
4936 stopfinding
4938 focus .
4939 if {$findstring eq {} || $numcommits == 0} return
4940 if {![info exists selectedline]} {
4941 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4942 } else {
4943 set findstartline $selectedline
4945 set findcurline $findstartline
4946 nowbusy finding [mc "Searching"]
4947 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
4948 after cancel do_file_hl $fh_serial
4949 do_file_hl $fh_serial
4951 set find_dirn $dirn
4952 set findallowwrap $wrap
4953 run findmore
4956 proc stopfinding {} {
4957 global find_dirn findcurline fprogcoord
4959 if {[info exists find_dirn]} {
4960 unset find_dirn
4961 unset findcurline
4962 notbusy finding
4963 set fprogcoord 0
4964 adjustprogress
4968 proc findmore {} {
4969 global commitdata commitinfo numcommits findpattern findloc
4970 global findstartline findcurline findallowwrap
4971 global find_dirn gdttype fhighlights fprogcoord
4972 global curview varcorder vrownum varccommits vrowmod
4974 if {![info exists find_dirn]} {
4975 return 0
4977 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
4978 set l $findcurline
4979 set moretodo 0
4980 if {$find_dirn > 0} {
4981 incr l
4982 if {$l >= $numcommits} {
4983 set l 0
4985 if {$l <= $findstartline} {
4986 set lim [expr {$findstartline + 1}]
4987 } else {
4988 set lim $numcommits
4989 set moretodo $findallowwrap
4991 } else {
4992 if {$l == 0} {
4993 set l $numcommits
4995 incr l -1
4996 if {$l >= $findstartline} {
4997 set lim [expr {$findstartline - 1}]
4998 } else {
4999 set lim -1
5000 set moretodo $findallowwrap
5003 set n [expr {($lim - $l) * $find_dirn}]
5004 if {$n > 500} {
5005 set n 500
5006 set moretodo 1
5008 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5009 update_arcrows $curview
5011 set found 0
5012 set domore 1
5013 set ai [bsearch $vrownum($curview) $l]
5014 set a [lindex $varcorder($curview) $ai]
5015 set arow [lindex $vrownum($curview) $ai]
5016 set ids [lindex $varccommits($curview,$a)]
5017 set arowend [expr {$arow + [llength $ids]}]
5018 if {$gdttype eq [mc "containing:"]} {
5019 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5020 if {$l < $arow || $l >= $arowend} {
5021 incr ai $find_dirn
5022 set a [lindex $varcorder($curview) $ai]
5023 set arow [lindex $vrownum($curview) $ai]
5024 set ids [lindex $varccommits($curview,$a)]
5025 set arowend [expr {$arow + [llength $ids]}]
5027 set id [lindex $ids [expr {$l - $arow}]]
5028 # shouldn't happen unless git log doesn't give all the commits...
5029 if {![info exists commitdata($id)] ||
5030 ![doesmatch $commitdata($id)]} {
5031 continue
5033 if {![info exists commitinfo($id)]} {
5034 getcommit $id
5036 set info $commitinfo($id)
5037 foreach f $info ty $fldtypes {
5038 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5039 [doesmatch $f]} {
5040 set found 1
5041 break
5044 if {$found} break
5046 } else {
5047 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5048 if {$l < $arow || $l >= $arowend} {
5049 incr ai $find_dirn
5050 set a [lindex $varcorder($curview) $ai]
5051 set arow [lindex $vrownum($curview) $ai]
5052 set ids [lindex $varccommits($curview,$a)]
5053 set arowend [expr {$arow + [llength $ids]}]
5055 set id [lindex $ids [expr {$l - $arow}]]
5056 if {![info exists fhighlights($l)]} {
5057 # this sets fhighlights($l) to -1
5058 askfilehighlight $l $id
5060 if {$fhighlights($l) > 0} {
5061 set found $domore
5062 break
5064 if {$fhighlights($l) < 0} {
5065 if {$domore} {
5066 set domore 0
5067 set findcurline [expr {$l - $find_dirn}]
5072 if {$found || ($domore && !$moretodo)} {
5073 unset findcurline
5074 unset find_dirn
5075 notbusy finding
5076 set fprogcoord 0
5077 adjustprogress
5078 if {$found} {
5079 findselectline $l
5080 } else {
5081 bell
5083 return 0
5085 if {!$domore} {
5086 flushhighlights
5087 } else {
5088 set findcurline [expr {$l - $find_dirn}]
5090 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5091 if {$n < 0} {
5092 incr n $numcommits
5094 set fprogcoord [expr {$n * 1.0 / $numcommits}]
5095 adjustprogress
5096 return $domore
5099 proc findselectline {l} {
5100 global findloc commentend ctext findcurline markingmatches gdttype
5102 set markingmatches 1
5103 set findcurline $l
5104 selectline $l 1
5105 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5106 # highlight the matches in the comments
5107 set f [$ctext get 1.0 $commentend]
5108 set matches [findmatches $f]
5109 foreach match $matches {
5110 set start [lindex $match 0]
5111 set end [expr {[lindex $match 1] + 1}]
5112 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5115 drawvisible
5118 # mark the bits of a headline or author that match a find string
5119 proc markmatches {canv l str tag matches font row} {
5120 global selectedline
5122 set bbox [$canv bbox $tag]
5123 set x0 [lindex $bbox 0]
5124 set y0 [lindex $bbox 1]
5125 set y1 [lindex $bbox 3]
5126 foreach match $matches {
5127 set start [lindex $match 0]
5128 set end [lindex $match 1]
5129 if {$start > $end} continue
5130 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5131 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5132 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5133 [expr {$x0+$xlen+2}] $y1 \
5134 -outline {} -tags [list match$l matches] -fill yellow]
5135 $canv lower $t
5136 if {[info exists selectedline] && $row == $selectedline} {
5137 $canv raise $t secsel
5142 proc unmarkmatches {} {
5143 global markingmatches
5145 allcanvs delete matches
5146 set markingmatches 0
5147 stopfinding
5150 proc selcanvline {w x y} {
5151 global canv canvy0 ctext linespc
5152 global rowtextx
5153 set ymax [lindex [$canv cget -scrollregion] 3]
5154 if {$ymax == {}} return
5155 set yfrac [lindex [$canv yview] 0]
5156 set y [expr {$y + $yfrac * $ymax}]
5157 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5158 if {$l < 0} {
5159 set l 0
5161 if {$w eq $canv} {
5162 set xmax [lindex [$canv cget -scrollregion] 2]
5163 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5164 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5166 unmarkmatches
5167 selectline $l 1
5170 proc commit_descriptor {p} {
5171 global commitinfo
5172 if {![info exists commitinfo($p)]} {
5173 getcommit $p
5175 set l "..."
5176 if {[llength $commitinfo($p)] > 1} {
5177 set l [lindex $commitinfo($p) 0]
5179 return "$p ($l)\n"
5182 # append some text to the ctext widget, and make any SHA1 ID
5183 # that we know about be a clickable link.
5184 proc appendwithlinks {text tags} {
5185 global ctext linknum curview pendinglinks
5187 set start [$ctext index "end - 1c"]
5188 $ctext insert end $text $tags
5189 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5190 foreach l $links {
5191 set s [lindex $l 0]
5192 set e [lindex $l 1]
5193 set linkid [string range $text $s $e]
5194 incr e
5195 $ctext tag delete link$linknum
5196 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5197 setlink $linkid link$linknum
5198 incr linknum
5202 proc setlink {id lk} {
5203 global curview ctext pendinglinks commitinterest
5205 if {[commitinview $id $curview]} {
5206 $ctext tag conf $lk -foreground blue -underline 1
5207 $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5208 $ctext tag bind $lk <Enter> {linkcursor %W 1}
5209 $ctext tag bind $lk <Leave> {linkcursor %W -1}
5210 } else {
5211 lappend pendinglinks($id) $lk
5212 lappend commitinterest($id) {makelink %I}
5216 proc makelink {id} {
5217 global pendinglinks
5219 if {![info exists pendinglinks($id)]} return
5220 foreach lk $pendinglinks($id) {
5221 setlink $id $lk
5223 unset pendinglinks($id)
5226 proc linkcursor {w inc} {
5227 global linkentercount curtextcursor
5229 if {[incr linkentercount $inc] > 0} {
5230 $w configure -cursor hand2
5231 } else {
5232 $w configure -cursor $curtextcursor
5233 if {$linkentercount < 0} {
5234 set linkentercount 0
5239 proc viewnextline {dir} {
5240 global canv linespc
5242 $canv delete hover
5243 set ymax [lindex [$canv cget -scrollregion] 3]
5244 set wnow [$canv yview]
5245 set wtop [expr {[lindex $wnow 0] * $ymax}]
5246 set newtop [expr {$wtop + $dir * $linespc}]
5247 if {$newtop < 0} {
5248 set newtop 0
5249 } elseif {$newtop > $ymax} {
5250 set newtop $ymax
5252 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5255 # add a list of tag or branch names at position pos
5256 # returns the number of names inserted
5257 proc appendrefs {pos ids var} {
5258 global ctext linknum curview $var maxrefs
5260 if {[catch {$ctext index $pos}]} {
5261 return 0
5263 $ctext conf -state normal
5264 $ctext delete $pos "$pos lineend"
5265 set tags {}
5266 foreach id $ids {
5267 foreach tag [set $var\($id\)] {
5268 lappend tags [list $tag $id]
5271 if {[llength $tags] > $maxrefs} {
5272 $ctext insert $pos "many ([llength $tags])"
5273 } else {
5274 set tags [lsort -index 0 -decreasing $tags]
5275 set sep {}
5276 foreach ti $tags {
5277 set id [lindex $ti 1]
5278 set lk link$linknum
5279 incr linknum
5280 $ctext tag delete $lk
5281 $ctext insert $pos $sep
5282 $ctext insert $pos [lindex $ti 0] $lk
5283 setlink $id $lk
5284 set sep ", "
5287 $ctext conf -state disabled
5288 return [llength $tags]
5291 # called when we have finished computing the nearby tags
5292 proc dispneartags {delay} {
5293 global selectedline currentid showneartags tagphase
5295 if {![info exists selectedline] || !$showneartags} return
5296 after cancel dispnexttag
5297 if {$delay} {
5298 after 200 dispnexttag
5299 set tagphase -1
5300 } else {
5301 after idle dispnexttag
5302 set tagphase 0
5306 proc dispnexttag {} {
5307 global selectedline currentid showneartags tagphase ctext
5309 if {![info exists selectedline] || !$showneartags} return
5310 switch -- $tagphase {
5312 set dtags [desctags $currentid]
5313 if {$dtags ne {}} {
5314 appendrefs precedes $dtags idtags
5318 set atags [anctags $currentid]
5319 if {$atags ne {}} {
5320 appendrefs follows $atags idtags
5324 set dheads [descheads $currentid]
5325 if {$dheads ne {}} {
5326 if {[appendrefs branch $dheads idheads] > 1
5327 && [$ctext get "branch -3c"] eq "h"} {
5328 # turn "Branch" into "Branches"
5329 $ctext conf -state normal
5330 $ctext insert "branch -2c" "es"
5331 $ctext conf -state disabled
5336 if {[incr tagphase] <= 2} {
5337 after idle dispnexttag
5341 proc make_secsel {l} {
5342 global linehtag linentag linedtag canv canv2 canv3
5344 if {![info exists linehtag($l)]} return
5345 $canv delete secsel
5346 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5347 -tags secsel -fill [$canv cget -selectbackground]]
5348 $canv lower $t
5349 $canv2 delete secsel
5350 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5351 -tags secsel -fill [$canv2 cget -selectbackground]]
5352 $canv2 lower $t
5353 $canv3 delete secsel
5354 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5355 -tags secsel -fill [$canv3 cget -selectbackground]]
5356 $canv3 lower $t
5359 proc selectline {l isnew} {
5360 global canv ctext commitinfo selectedline
5361 global canvy0 linespc parents children curview
5362 global currentid sha1entry
5363 global commentend idtags linknum
5364 global mergemax numcommits pending_select
5365 global cmitmode showneartags allcommits
5367 catch {unset pending_select}
5368 $canv delete hover
5369 normalline
5370 unsel_reflist
5371 stopfinding
5372 if {$l < 0 || $l >= $numcommits} return
5373 set y [expr {$canvy0 + $l * $linespc}]
5374 set ymax [lindex [$canv cget -scrollregion] 3]
5375 set ytop [expr {$y - $linespc - 1}]
5376 set ybot [expr {$y + $linespc + 1}]
5377 set wnow [$canv yview]
5378 set wtop [expr {[lindex $wnow 0] * $ymax}]
5379 set wbot [expr {[lindex $wnow 1] * $ymax}]
5380 set wh [expr {$wbot - $wtop}]
5381 set newtop $wtop
5382 if {$ytop < $wtop} {
5383 if {$ybot < $wtop} {
5384 set newtop [expr {$y - $wh / 2.0}]
5385 } else {
5386 set newtop $ytop
5387 if {$newtop > $wtop - $linespc} {
5388 set newtop [expr {$wtop - $linespc}]
5391 } elseif {$ybot > $wbot} {
5392 if {$ytop > $wbot} {
5393 set newtop [expr {$y - $wh / 2.0}]
5394 } else {
5395 set newtop [expr {$ybot - $wh}]
5396 if {$newtop < $wtop + $linespc} {
5397 set newtop [expr {$wtop + $linespc}]
5401 if {$newtop != $wtop} {
5402 if {$newtop < 0} {
5403 set newtop 0
5405 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5406 drawvisible
5409 make_secsel $l
5411 set id [commitonrow $l]
5412 if {$isnew} {
5413 addtohistory [list selbyid $id]
5416 set selectedline $l
5417 set currentid $id
5418 $sha1entry delete 0 end
5419 $sha1entry insert 0 $id
5420 $sha1entry selection from 0
5421 $sha1entry selection to end
5422 rhighlight_sel $id
5424 $ctext conf -state normal
5425 clear_ctext
5426 set linknum 0
5427 set info $commitinfo($id)
5428 set date [formatdate [lindex $info 2]]
5429 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
5430 set date [formatdate [lindex $info 4]]
5431 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
5432 if {[info exists idtags($id)]} {
5433 $ctext insert end [mc "Tags:"]
5434 foreach tag $idtags($id) {
5435 $ctext insert end " $tag"
5437 $ctext insert end "\n"
5440 set headers {}
5441 set olds $parents($curview,$id)
5442 if {[llength $olds] > 1} {
5443 set np 0
5444 foreach p $olds {
5445 if {$np >= $mergemax} {
5446 set tag mmax
5447 } else {
5448 set tag m$np
5450 $ctext insert end "[mc "Parent"]: " $tag
5451 appendwithlinks [commit_descriptor $p] {}
5452 incr np
5454 } else {
5455 foreach p $olds {
5456 append headers "[mc "Parent"]: [commit_descriptor $p]"
5460 foreach c $children($curview,$id) {
5461 append headers "[mc "Child"]: [commit_descriptor $c]"
5464 # make anything that looks like a SHA1 ID be a clickable link
5465 appendwithlinks $headers {}
5466 if {$showneartags} {
5467 if {![info exists allcommits]} {
5468 getallcommits
5470 $ctext insert end "[mc "Branch"]: "
5471 $ctext mark set branch "end -1c"
5472 $ctext mark gravity branch left
5473 $ctext insert end "\n[mc "Follows"]: "
5474 $ctext mark set follows "end -1c"
5475 $ctext mark gravity follows left
5476 $ctext insert end "\n[mc "Precedes"]: "
5477 $ctext mark set precedes "end -1c"
5478 $ctext mark gravity precedes left
5479 $ctext insert end "\n"
5480 dispneartags 1
5482 $ctext insert end "\n"
5483 set comment [lindex $info 5]
5484 if {[string first "\r" $comment] >= 0} {
5485 set comment [string map {"\r" "\n "} $comment]
5487 appendwithlinks $comment {comment}
5489 $ctext tag remove found 1.0 end
5490 $ctext conf -state disabled
5491 set commentend [$ctext index "end - 1c"]
5493 init_flist [mc "Comments"]
5494 if {$cmitmode eq "tree"} {
5495 gettree $id
5496 } elseif {[llength $olds] <= 1} {
5497 startdiff $id
5498 } else {
5499 mergediff $id
5503 proc selfirstline {} {
5504 unmarkmatches
5505 selectline 0 1
5508 proc sellastline {} {
5509 global numcommits
5510 unmarkmatches
5511 set l [expr {$numcommits - 1}]
5512 selectline $l 1
5515 proc selnextline {dir} {
5516 global selectedline
5517 focus .
5518 if {![info exists selectedline]} return
5519 set l [expr {$selectedline + $dir}]
5520 unmarkmatches
5521 selectline $l 1
5524 proc selnextpage {dir} {
5525 global canv linespc selectedline numcommits
5527 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5528 if {$lpp < 1} {
5529 set lpp 1
5531 allcanvs yview scroll [expr {$dir * $lpp}] units
5532 drawvisible
5533 if {![info exists selectedline]} return
5534 set l [expr {$selectedline + $dir * $lpp}]
5535 if {$l < 0} {
5536 set l 0
5537 } elseif {$l >= $numcommits} {
5538 set l [expr $numcommits - 1]
5540 unmarkmatches
5541 selectline $l 1
5544 proc unselectline {} {
5545 global selectedline currentid
5547 catch {unset selectedline}
5548 catch {unset currentid}
5549 allcanvs delete secsel
5550 rhighlight_none
5553 proc reselectline {} {
5554 global selectedline
5556 if {[info exists selectedline]} {
5557 selectline $selectedline 0
5561 proc addtohistory {cmd} {
5562 global history historyindex curview
5564 set elt [list $curview $cmd]
5565 if {$historyindex > 0
5566 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5567 return
5570 if {$historyindex < [llength $history]} {
5571 set history [lreplace $history $historyindex end $elt]
5572 } else {
5573 lappend history $elt
5575 incr historyindex
5576 if {$historyindex > 1} {
5577 .tf.bar.leftbut conf -state normal
5578 } else {
5579 .tf.bar.leftbut conf -state disabled
5581 .tf.bar.rightbut conf -state disabled
5584 proc godo {elt} {
5585 global curview
5587 set view [lindex $elt 0]
5588 set cmd [lindex $elt 1]
5589 if {$curview != $view} {
5590 showview $view
5592 eval $cmd
5595 proc goback {} {
5596 global history historyindex
5597 focus .
5599 if {$historyindex > 1} {
5600 incr historyindex -1
5601 godo [lindex $history [expr {$historyindex - 1}]]
5602 .tf.bar.rightbut conf -state normal
5604 if {$historyindex <= 1} {
5605 .tf.bar.leftbut conf -state disabled
5609 proc goforw {} {
5610 global history historyindex
5611 focus .
5613 if {$historyindex < [llength $history]} {
5614 set cmd [lindex $history $historyindex]
5615 incr historyindex
5616 godo $cmd
5617 .tf.bar.leftbut conf -state normal
5619 if {$historyindex >= [llength $history]} {
5620 .tf.bar.rightbut conf -state disabled
5624 proc gettree {id} {
5625 global treefilelist treeidlist diffids diffmergeid treepending
5626 global nullid nullid2
5628 set diffids $id
5629 catch {unset diffmergeid}
5630 if {![info exists treefilelist($id)]} {
5631 if {![info exists treepending]} {
5632 if {$id eq $nullid} {
5633 set cmd [list | git ls-files]
5634 } elseif {$id eq $nullid2} {
5635 set cmd [list | git ls-files --stage -t]
5636 } else {
5637 set cmd [list | git ls-tree -r $id]
5639 if {[catch {set gtf [open $cmd r]}]} {
5640 return
5642 set treepending $id
5643 set treefilelist($id) {}
5644 set treeidlist($id) {}
5645 fconfigure $gtf -blocking 0
5646 filerun $gtf [list gettreeline $gtf $id]
5648 } else {
5649 setfilelist $id
5653 proc gettreeline {gtf id} {
5654 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5656 set nl 0
5657 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5658 if {$diffids eq $nullid} {
5659 set fname $line
5660 } else {
5661 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5662 set i [string first "\t" $line]
5663 if {$i < 0} continue
5664 set sha1 [lindex $line 2]
5665 set fname [string range $line [expr {$i+1}] end]
5666 if {[string index $fname 0] eq "\""} {
5667 set fname [lindex $fname 0]
5669 lappend treeidlist($id) $sha1
5671 lappend treefilelist($id) $fname
5673 if {![eof $gtf]} {
5674 return [expr {$nl >= 1000? 2: 1}]
5676 close $gtf
5677 unset treepending
5678 if {$cmitmode ne "tree"} {
5679 if {![info exists diffmergeid]} {
5680 gettreediffs $diffids
5682 } elseif {$id ne $diffids} {
5683 gettree $diffids
5684 } else {
5685 setfilelist $id
5687 return 0
5690 proc showfile {f} {
5691 global treefilelist treeidlist diffids nullid nullid2
5692 global ctext commentend
5694 set i [lsearch -exact $treefilelist($diffids) $f]
5695 if {$i < 0} {
5696 puts "oops, $f not in list for id $diffids"
5697 return
5699 if {$diffids eq $nullid} {
5700 if {[catch {set bf [open $f r]} err]} {
5701 puts "oops, can't read $f: $err"
5702 return
5704 } else {
5705 set blob [lindex $treeidlist($diffids) $i]
5706 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5707 puts "oops, error reading blob $blob: $err"
5708 return
5711 fconfigure $bf -blocking 0
5712 filerun $bf [list getblobline $bf $diffids]
5713 $ctext config -state normal
5714 clear_ctext $commentend
5715 $ctext insert end "\n"
5716 $ctext insert end "$f\n" filesep
5717 $ctext config -state disabled
5718 $ctext yview $commentend
5719 settabs 0
5722 proc getblobline {bf id} {
5723 global diffids cmitmode ctext
5725 if {$id ne $diffids || $cmitmode ne "tree"} {
5726 catch {close $bf}
5727 return 0
5729 $ctext config -state normal
5730 set nl 0
5731 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5732 $ctext insert end "$line\n"
5734 if {[eof $bf]} {
5735 # delete last newline
5736 $ctext delete "end - 2c" "end - 1c"
5737 close $bf
5738 return 0
5740 $ctext config -state disabled
5741 return [expr {$nl >= 1000? 2: 1}]
5744 proc mergediff {id} {
5745 global diffmergeid mdifffd
5746 global diffids
5747 global parents
5748 global limitdiffs viewfiles curview
5750 set diffmergeid $id
5751 set diffids $id
5752 # this doesn't seem to actually affect anything...
5753 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5754 if {$limitdiffs && $viewfiles($curview) ne {}} {
5755 set cmd [concat $cmd -- $viewfiles($curview)]
5757 if {[catch {set mdf [open $cmd r]} err]} {
5758 error_popup "[mc "Error getting merge diffs:"] $err"
5759 return
5761 fconfigure $mdf -blocking 0
5762 set mdifffd($id) $mdf
5763 set np [llength $parents($curview,$id)]
5764 settabs $np
5765 filerun $mdf [list getmergediffline $mdf $id $np]
5768 proc getmergediffline {mdf id np} {
5769 global diffmergeid ctext cflist mergemax
5770 global difffilestart mdifffd
5772 $ctext conf -state normal
5773 set nr 0
5774 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5775 if {![info exists diffmergeid] || $id != $diffmergeid
5776 || $mdf != $mdifffd($id)} {
5777 close $mdf
5778 return 0
5780 if {[regexp {^diff --cc (.*)} $line match fname]} {
5781 # start of a new file
5782 $ctext insert end "\n"
5783 set here [$ctext index "end - 1c"]
5784 lappend difffilestart $here
5785 add_flist [list $fname]
5786 set l [expr {(78 - [string length $fname]) / 2}]
5787 set pad [string range "----------------------------------------" 1 $l]
5788 $ctext insert end "$pad $fname $pad\n" filesep
5789 } elseif {[regexp {^@@} $line]} {
5790 $ctext insert end "$line\n" hunksep
5791 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5792 # do nothing
5793 } else {
5794 # parse the prefix - one ' ', '-' or '+' for each parent
5795 set spaces {}
5796 set minuses {}
5797 set pluses {}
5798 set isbad 0
5799 for {set j 0} {$j < $np} {incr j} {
5800 set c [string range $line $j $j]
5801 if {$c == " "} {
5802 lappend spaces $j
5803 } elseif {$c == "-"} {
5804 lappend minuses $j
5805 } elseif {$c == "+"} {
5806 lappend pluses $j
5807 } else {
5808 set isbad 1
5809 break
5812 set tags {}
5813 set num {}
5814 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5815 # line doesn't appear in result, parents in $minuses have the line
5816 set num [lindex $minuses 0]
5817 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5818 # line appears in result, parents in $pluses don't have the line
5819 lappend tags mresult
5820 set num [lindex $spaces 0]
5822 if {$num ne {}} {
5823 if {$num >= $mergemax} {
5824 set num "max"
5826 lappend tags m$num
5828 $ctext insert end "$line\n" $tags
5831 $ctext conf -state disabled
5832 if {[eof $mdf]} {
5833 close $mdf
5834 return 0
5836 return [expr {$nr >= 1000? 2: 1}]
5839 proc startdiff {ids} {
5840 global treediffs diffids treepending diffmergeid nullid nullid2
5842 settabs 1
5843 set diffids $ids
5844 catch {unset diffmergeid}
5845 if {![info exists treediffs($ids)] ||
5846 [lsearch -exact $ids $nullid] >= 0 ||
5847 [lsearch -exact $ids $nullid2] >= 0} {
5848 if {![info exists treepending]} {
5849 gettreediffs $ids
5851 } else {
5852 addtocflist $ids
5856 proc path_filter {filter name} {
5857 foreach p $filter {
5858 set l [string length $p]
5859 if {[string index $p end] eq "/"} {
5860 if {[string compare -length $l $p $name] == 0} {
5861 return 1
5863 } else {
5864 if {[string compare -length $l $p $name] == 0 &&
5865 ([string length $name] == $l ||
5866 [string index $name $l] eq "/")} {
5867 return 1
5871 return 0
5874 proc addtocflist {ids} {
5875 global treediffs
5877 add_flist $treediffs($ids)
5878 getblobdiffs $ids
5881 proc diffcmd {ids flags} {
5882 global nullid nullid2
5884 set i [lsearch -exact $ids $nullid]
5885 set j [lsearch -exact $ids $nullid2]
5886 if {$i >= 0} {
5887 if {[llength $ids] > 1 && $j < 0} {
5888 # comparing working directory with some specific revision
5889 set cmd [concat | git diff-index $flags]
5890 if {$i == 0} {
5891 lappend cmd -R [lindex $ids 1]
5892 } else {
5893 lappend cmd [lindex $ids 0]
5895 } else {
5896 # comparing working directory with index
5897 set cmd [concat | git diff-files $flags]
5898 if {$j == 1} {
5899 lappend cmd -R
5902 } elseif {$j >= 0} {
5903 set cmd [concat | git diff-index --cached $flags]
5904 if {[llength $ids] > 1} {
5905 # comparing index with specific revision
5906 if {$i == 0} {
5907 lappend cmd -R [lindex $ids 1]
5908 } else {
5909 lappend cmd [lindex $ids 0]
5911 } else {
5912 # comparing index with HEAD
5913 lappend cmd HEAD
5915 } else {
5916 set cmd [concat | git diff-tree -r $flags $ids]
5918 return $cmd
5921 proc gettreediffs {ids} {
5922 global treediff treepending
5924 set treepending $ids
5925 set treediff {}
5926 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5927 fconfigure $gdtf -blocking 0
5928 filerun $gdtf [list gettreediffline $gdtf $ids]
5931 proc gettreediffline {gdtf ids} {
5932 global treediff treediffs treepending diffids diffmergeid
5933 global cmitmode viewfiles curview limitdiffs
5935 set nr 0
5936 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5937 set i [string first "\t" $line]
5938 if {$i >= 0} {
5939 set file [string range $line [expr {$i+1}] end]
5940 if {[string index $file 0] eq "\""} {
5941 set file [lindex $file 0]
5943 lappend treediff $file
5946 if {![eof $gdtf]} {
5947 return [expr {$nr >= 1000? 2: 1}]
5949 close $gdtf
5950 if {$limitdiffs && $viewfiles($curview) ne {}} {
5951 set flist {}
5952 foreach f $treediff {
5953 if {[path_filter $viewfiles($curview) $f]} {
5954 lappend flist $f
5957 set treediffs($ids) $flist
5958 } else {
5959 set treediffs($ids) $treediff
5961 unset treepending
5962 if {$cmitmode eq "tree"} {
5963 gettree $diffids
5964 } elseif {$ids != $diffids} {
5965 if {![info exists diffmergeid]} {
5966 gettreediffs $diffids
5968 } else {
5969 addtocflist $ids
5971 return 0
5974 # empty string or positive integer
5975 proc diffcontextvalidate {v} {
5976 return [regexp {^(|[1-9][0-9]*)$} $v]
5979 proc diffcontextchange {n1 n2 op} {
5980 global diffcontextstring diffcontext
5982 if {[string is integer -strict $diffcontextstring]} {
5983 if {$diffcontextstring > 0} {
5984 set diffcontext $diffcontextstring
5985 reselectline
5990 proc getblobdiffs {ids} {
5991 global blobdifffd diffids env
5992 global diffinhdr treediffs
5993 global diffcontext
5994 global limitdiffs viewfiles curview
5996 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5997 if {$limitdiffs && $viewfiles($curview) ne {}} {
5998 set cmd [concat $cmd -- $viewfiles($curview)]
6000 if {[catch {set bdf [open $cmd r]} err]} {
6001 puts "error getting diffs: $err"
6002 return
6004 set diffinhdr 0
6005 fconfigure $bdf -blocking 0
6006 set blobdifffd($ids) $bdf
6007 filerun $bdf [list getblobdiffline $bdf $diffids]
6010 proc setinlist {var i val} {
6011 global $var
6013 while {[llength [set $var]] < $i} {
6014 lappend $var {}
6016 if {[llength [set $var]] == $i} {
6017 lappend $var $val
6018 } else {
6019 lset $var $i $val
6023 proc makediffhdr {fname ids} {
6024 global ctext curdiffstart treediffs
6026 set i [lsearch -exact $treediffs($ids) $fname]
6027 if {$i >= 0} {
6028 setinlist difffilestart $i $curdiffstart
6030 set l [expr {(78 - [string length $fname]) / 2}]
6031 set pad [string range "----------------------------------------" 1 $l]
6032 $ctext insert $curdiffstart "$pad $fname $pad" filesep
6035 proc getblobdiffline {bdf ids} {
6036 global diffids blobdifffd ctext curdiffstart
6037 global diffnexthead diffnextnote difffilestart
6038 global diffinhdr treediffs
6040 set nr 0
6041 $ctext conf -state normal
6042 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6043 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6044 close $bdf
6045 return 0
6047 if {![string compare -length 11 "diff --git " $line]} {
6048 # trim off "diff --git "
6049 set line [string range $line 11 end]
6050 set diffinhdr 1
6051 # start of a new file
6052 $ctext insert end "\n"
6053 set curdiffstart [$ctext index "end - 1c"]
6054 $ctext insert end "\n" filesep
6055 # If the name hasn't changed the length will be odd,
6056 # the middle char will be a space, and the two bits either
6057 # side will be a/name and b/name, or "a/name" and "b/name".
6058 # If the name has changed we'll get "rename from" and
6059 # "rename to" or "copy from" and "copy to" lines following this,
6060 # and we'll use them to get the filenames.
6061 # This complexity is necessary because spaces in the filename(s)
6062 # don't get escaped.
6063 set l [string length $line]
6064 set i [expr {$l / 2}]
6065 if {!(($l & 1) && [string index $line $i] eq " " &&
6066 [string range $line 2 [expr {$i - 1}]] eq \
6067 [string range $line [expr {$i + 3}] end])} {
6068 continue
6070 # unescape if quoted and chop off the a/ from the front
6071 if {[string index $line 0] eq "\""} {
6072 set fname [string range [lindex $line 0] 2 end]
6073 } else {
6074 set fname [string range $line 2 [expr {$i - 1}]]
6076 makediffhdr $fname $ids
6078 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6079 $line match f1l f1c f2l f2c rest]} {
6080 $ctext insert end "$line\n" hunksep
6081 set diffinhdr 0
6083 } elseif {$diffinhdr} {
6084 if {![string compare -length 12 "rename from " $line]} {
6085 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6086 if {[string index $fname 0] eq "\""} {
6087 set fname [lindex $fname 0]
6089 set i [lsearch -exact $treediffs($ids) $fname]
6090 if {$i >= 0} {
6091 setinlist difffilestart $i $curdiffstart
6093 } elseif {![string compare -length 10 $line "rename to "] ||
6094 ![string compare -length 8 $line "copy to "]} {
6095 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6096 if {[string index $fname 0] eq "\""} {
6097 set fname [lindex $fname 0]
6099 makediffhdr $fname $ids
6100 } elseif {[string compare -length 3 $line "---"] == 0} {
6101 # do nothing
6102 continue
6103 } elseif {[string compare -length 3 $line "+++"] == 0} {
6104 set diffinhdr 0
6105 continue
6107 $ctext insert end "$line\n" filesep
6109 } else {
6110 set x [string range $line 0 0]
6111 if {$x == "-" || $x == "+"} {
6112 set tag [expr {$x == "+"}]
6113 $ctext insert end "$line\n" d$tag
6114 } elseif {$x == " "} {
6115 $ctext insert end "$line\n"
6116 } else {
6117 # "\ No newline at end of file",
6118 # or something else we don't recognize
6119 $ctext insert end "$line\n" hunksep
6123 $ctext conf -state disabled
6124 if {[eof $bdf]} {
6125 close $bdf
6126 return 0
6128 return [expr {$nr >= 1000? 2: 1}]
6131 proc changediffdisp {} {
6132 global ctext diffelide
6134 $ctext tag conf d0 -elide [lindex $diffelide 0]
6135 $ctext tag conf d1 -elide [lindex $diffelide 1]
6138 proc prevfile {} {
6139 global difffilestart ctext
6140 set prev [lindex $difffilestart 0]
6141 set here [$ctext index @0,0]
6142 foreach loc $difffilestart {
6143 if {[$ctext compare $loc >= $here]} {
6144 $ctext yview $prev
6145 return
6147 set prev $loc
6149 $ctext yview $prev
6152 proc nextfile {} {
6153 global difffilestart ctext
6154 set here [$ctext index @0,0]
6155 foreach loc $difffilestart {
6156 if {[$ctext compare $loc > $here]} {
6157 $ctext yview $loc
6158 return
6163 proc clear_ctext {{first 1.0}} {
6164 global ctext smarktop smarkbot
6165 global pendinglinks
6167 set l [lindex [split $first .] 0]
6168 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6169 set smarktop $l
6171 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6172 set smarkbot $l
6174 $ctext delete $first end
6175 if {$first eq "1.0"} {
6176 catch {unset pendinglinks}
6180 proc settabs {{firstab {}}} {
6181 global firsttabstop tabstop ctext have_tk85
6183 if {$firstab ne {} && $have_tk85} {
6184 set firsttabstop $firstab
6186 set w [font measure textfont "0"]
6187 if {$firsttabstop != 0} {
6188 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6189 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6190 } elseif {$have_tk85 || $tabstop != 8} {
6191 $ctext conf -tabs [expr {$tabstop * $w}]
6192 } else {
6193 $ctext conf -tabs {}
6197 proc incrsearch {name ix op} {
6198 global ctext searchstring searchdirn
6200 $ctext tag remove found 1.0 end
6201 if {[catch {$ctext index anchor}]} {
6202 # no anchor set, use start of selection, or of visible area
6203 set sel [$ctext tag ranges sel]
6204 if {$sel ne {}} {
6205 $ctext mark set anchor [lindex $sel 0]
6206 } elseif {$searchdirn eq "-forwards"} {
6207 $ctext mark set anchor @0,0
6208 } else {
6209 $ctext mark set anchor @0,[winfo height $ctext]
6212 if {$searchstring ne {}} {
6213 set here [$ctext search $searchdirn -- $searchstring anchor]
6214 if {$here ne {}} {
6215 $ctext see $here
6217 searchmarkvisible 1
6221 proc dosearch {} {
6222 global sstring ctext searchstring searchdirn
6224 focus $sstring
6225 $sstring icursor end
6226 set searchdirn -forwards
6227 if {$searchstring ne {}} {
6228 set sel [$ctext tag ranges sel]
6229 if {$sel ne {}} {
6230 set start "[lindex $sel 0] + 1c"
6231 } elseif {[catch {set start [$ctext index anchor]}]} {
6232 set start "@0,0"
6234 set match [$ctext search -count mlen -- $searchstring $start]
6235 $ctext tag remove sel 1.0 end
6236 if {$match eq {}} {
6237 bell
6238 return
6240 $ctext see $match
6241 set mend "$match + $mlen c"
6242 $ctext tag add sel $match $mend
6243 $ctext mark unset anchor
6247 proc dosearchback {} {
6248 global sstring ctext searchstring searchdirn
6250 focus $sstring
6251 $sstring icursor end
6252 set searchdirn -backwards
6253 if {$searchstring ne {}} {
6254 set sel [$ctext tag ranges sel]
6255 if {$sel ne {}} {
6256 set start [lindex $sel 0]
6257 } elseif {[catch {set start [$ctext index anchor]}]} {
6258 set start @0,[winfo height $ctext]
6260 set match [$ctext search -backwards -count ml -- $searchstring $start]
6261 $ctext tag remove sel 1.0 end
6262 if {$match eq {}} {
6263 bell
6264 return
6266 $ctext see $match
6267 set mend "$match + $ml c"
6268 $ctext tag add sel $match $mend
6269 $ctext mark unset anchor
6273 proc searchmark {first last} {
6274 global ctext searchstring
6276 set mend $first.0
6277 while {1} {
6278 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6279 if {$match eq {}} break
6280 set mend "$match + $mlen c"
6281 $ctext tag add found $match $mend
6285 proc searchmarkvisible {doall} {
6286 global ctext smarktop smarkbot
6288 set topline [lindex [split [$ctext index @0,0] .] 0]
6289 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6290 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6291 # no overlap with previous
6292 searchmark $topline $botline
6293 set smarktop $topline
6294 set smarkbot $botline
6295 } else {
6296 if {$topline < $smarktop} {
6297 searchmark $topline [expr {$smarktop-1}]
6298 set smarktop $topline
6300 if {$botline > $smarkbot} {
6301 searchmark [expr {$smarkbot+1}] $botline
6302 set smarkbot $botline
6307 proc scrolltext {f0 f1} {
6308 global searchstring
6310 .bleft.sb set $f0 $f1
6311 if {$searchstring ne {}} {
6312 searchmarkvisible 0
6316 proc setcoords {} {
6317 global linespc charspc canvx0 canvy0
6318 global xspc1 xspc2 lthickness
6320 set linespc [font metrics mainfont -linespace]
6321 set charspc [font measure mainfont "m"]
6322 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6323 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6324 set lthickness [expr {int($linespc / 9) + 1}]
6325 set xspc1(0) $linespc
6326 set xspc2 $linespc
6329 proc redisplay {} {
6330 global canv
6331 global selectedline
6333 set ymax [lindex [$canv cget -scrollregion] 3]
6334 if {$ymax eq {} || $ymax == 0} return
6335 set span [$canv yview]
6336 clear_display
6337 setcanvscroll
6338 allcanvs yview moveto [lindex $span 0]
6339 drawvisible
6340 if {[info exists selectedline]} {
6341 selectline $selectedline 0
6342 allcanvs yview moveto [lindex $span 0]
6346 proc parsefont {f n} {
6347 global fontattr
6349 set fontattr($f,family) [lindex $n 0]
6350 set s [lindex $n 1]
6351 if {$s eq {} || $s == 0} {
6352 set s 10
6353 } elseif {$s < 0} {
6354 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6356 set fontattr($f,size) $s
6357 set fontattr($f,weight) normal
6358 set fontattr($f,slant) roman
6359 foreach style [lrange $n 2 end] {
6360 switch -- $style {
6361 "normal" -
6362 "bold" {set fontattr($f,weight) $style}
6363 "roman" -
6364 "italic" {set fontattr($f,slant) $style}
6369 proc fontflags {f {isbold 0}} {
6370 global fontattr
6372 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6373 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6374 -slant $fontattr($f,slant)]
6377 proc fontname {f} {
6378 global fontattr
6380 set n [list $fontattr($f,family) $fontattr($f,size)]
6381 if {$fontattr($f,weight) eq "bold"} {
6382 lappend n "bold"
6384 if {$fontattr($f,slant) eq "italic"} {
6385 lappend n "italic"
6387 return $n
6390 proc incrfont {inc} {
6391 global mainfont textfont ctext canv cflist showrefstop
6392 global stopped entries fontattr
6394 unmarkmatches
6395 set s $fontattr(mainfont,size)
6396 incr s $inc
6397 if {$s < 1} {
6398 set s 1
6400 set fontattr(mainfont,size) $s
6401 font config mainfont -size $s
6402 font config mainfontbold -size $s
6403 set mainfont [fontname mainfont]
6404 set s $fontattr(textfont,size)
6405 incr s $inc
6406 if {$s < 1} {
6407 set s 1
6409 set fontattr(textfont,size) $s
6410 font config textfont -size $s
6411 font config textfontbold -size $s
6412 set textfont [fontname textfont]
6413 setcoords
6414 settabs
6415 redisplay
6418 proc clearsha1 {} {
6419 global sha1entry sha1string
6420 if {[string length $sha1string] == 40} {
6421 $sha1entry delete 0 end
6425 proc sha1change {n1 n2 op} {
6426 global sha1string currentid sha1but
6427 if {$sha1string == {}
6428 || ([info exists currentid] && $sha1string == $currentid)} {
6429 set state disabled
6430 } else {
6431 set state normal
6433 if {[$sha1but cget -state] == $state} return
6434 if {$state == "normal"} {
6435 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6436 } else {
6437 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6441 proc gotocommit {} {
6442 global sha1string tagids headids curview varcid
6444 if {$sha1string == {}
6445 || ([info exists currentid] && $sha1string == $currentid)} return
6446 if {[info exists tagids($sha1string)]} {
6447 set id $tagids($sha1string)
6448 } elseif {[info exists headids($sha1string)]} {
6449 set id $headids($sha1string)
6450 } else {
6451 set id [string tolower $sha1string]
6452 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6453 set matches [array names varcid "$curview,$id*"]
6454 if {$matches ne {}} {
6455 if {[llength $matches] > 1} {
6456 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6457 return
6459 set id [lindex [split [lindex $matches 0] ","] 1]
6463 if {[commitinview $id $curview]} {
6464 selectline [rowofcommit $id] 1
6465 return
6467 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6468 set msg [mc "SHA1 id %s is not known" $sha1string]
6469 } else {
6470 set msg [mc "Tag/Head %s is not known" $sha1string]
6472 error_popup $msg
6475 proc lineenter {x y id} {
6476 global hoverx hovery hoverid hovertimer
6477 global commitinfo canv
6479 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6480 set hoverx $x
6481 set hovery $y
6482 set hoverid $id
6483 if {[info exists hovertimer]} {
6484 after cancel $hovertimer
6486 set hovertimer [after 500 linehover]
6487 $canv delete hover
6490 proc linemotion {x y id} {
6491 global hoverx hovery hoverid hovertimer
6493 if {[info exists hoverid] && $id == $hoverid} {
6494 set hoverx $x
6495 set hovery $y
6496 if {[info exists hovertimer]} {
6497 after cancel $hovertimer
6499 set hovertimer [after 500 linehover]
6503 proc lineleave {id} {
6504 global hoverid hovertimer canv
6506 if {[info exists hoverid] && $id == $hoverid} {
6507 $canv delete hover
6508 if {[info exists hovertimer]} {
6509 after cancel $hovertimer
6510 unset hovertimer
6512 unset hoverid
6516 proc linehover {} {
6517 global hoverx hovery hoverid hovertimer
6518 global canv linespc lthickness
6519 global commitinfo
6521 set text [lindex $commitinfo($hoverid) 0]
6522 set ymax [lindex [$canv cget -scrollregion] 3]
6523 if {$ymax == {}} return
6524 set yfrac [lindex [$canv yview] 0]
6525 set x [expr {$hoverx + 2 * $linespc}]
6526 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6527 set x0 [expr {$x - 2 * $lthickness}]
6528 set y0 [expr {$y - 2 * $lthickness}]
6529 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6530 set y1 [expr {$y + $linespc + 2 * $lthickness}]
6531 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6532 -fill \#ffff80 -outline black -width 1 -tags hover]
6533 $canv raise $t
6534 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6535 -font mainfont]
6536 $canv raise $t
6539 proc clickisonarrow {id y} {
6540 global lthickness
6542 set ranges [rowranges $id]
6543 set thresh [expr {2 * $lthickness + 6}]
6544 set n [expr {[llength $ranges] - 1}]
6545 for {set i 1} {$i < $n} {incr i} {
6546 set row [lindex $ranges $i]
6547 if {abs([yc $row] - $y) < $thresh} {
6548 return $i
6551 return {}
6554 proc arrowjump {id n y} {
6555 global canv
6557 # 1 <-> 2, 3 <-> 4, etc...
6558 set n [expr {(($n - 1) ^ 1) + 1}]
6559 set row [lindex [rowranges $id] $n]
6560 set yt [yc $row]
6561 set ymax [lindex [$canv cget -scrollregion] 3]
6562 if {$ymax eq {} || $ymax <= 0} return
6563 set view [$canv yview]
6564 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6565 set yfrac [expr {$yt / $ymax - $yspan / 2}]
6566 if {$yfrac < 0} {
6567 set yfrac 0
6569 allcanvs yview moveto $yfrac
6572 proc lineclick {x y id isnew} {
6573 global ctext commitinfo children canv thickerline curview
6575 if {![info exists commitinfo($id)] && ![getcommit $id]} return
6576 unmarkmatches
6577 unselectline
6578 normalline
6579 $canv delete hover
6580 # draw this line thicker than normal
6581 set thickerline $id
6582 drawlines $id
6583 if {$isnew} {
6584 set ymax [lindex [$canv cget -scrollregion] 3]
6585 if {$ymax eq {}} return
6586 set yfrac [lindex [$canv yview] 0]
6587 set y [expr {$y + $yfrac * $ymax}]
6589 set dirn [clickisonarrow $id $y]
6590 if {$dirn ne {}} {
6591 arrowjump $id $dirn $y
6592 return
6595 if {$isnew} {
6596 addtohistory [list lineclick $x $y $id 0]
6598 # fill the details pane with info about this line
6599 $ctext conf -state normal
6600 clear_ctext
6601 settabs 0
6602 $ctext insert end "[mc "Parent"]:\t"
6603 $ctext insert end $id link0
6604 setlink $id link0
6605 set info $commitinfo($id)
6606 $ctext insert end "\n\t[lindex $info 0]\n"
6607 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
6608 set date [formatdate [lindex $info 2]]
6609 $ctext insert end "\t[mc "Date"]:\t$date\n"
6610 set kids $children($curview,$id)
6611 if {$kids ne {}} {
6612 $ctext insert end "\n[mc "Children"]:"
6613 set i 0
6614 foreach child $kids {
6615 incr i
6616 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6617 set info $commitinfo($child)
6618 $ctext insert end "\n\t"
6619 $ctext insert end $child link$i
6620 setlink $child link$i
6621 $ctext insert end "\n\t[lindex $info 0]"
6622 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
6623 set date [formatdate [lindex $info 2]]
6624 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
6627 $ctext conf -state disabled
6628 init_flist {}
6631 proc normalline {} {
6632 global thickerline
6633 if {[info exists thickerline]} {
6634 set id $thickerline
6635 unset thickerline
6636 drawlines $id
6640 proc selbyid {id} {
6641 global curview
6642 if {[commitinview $id $curview]} {
6643 selectline [rowofcommit $id] 1
6647 proc mstime {} {
6648 global startmstime
6649 if {![info exists startmstime]} {
6650 set startmstime [clock clicks -milliseconds]
6652 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6655 proc rowmenu {x y id} {
6656 global rowctxmenu selectedline rowmenuid curview
6657 global nullid nullid2 fakerowmenu mainhead
6659 stopfinding
6660 set rowmenuid $id
6661 if {![info exists selectedline]
6662 || [rowofcommit $id] eq $selectedline} {
6663 set state disabled
6664 } else {
6665 set state normal
6667 if {$id ne $nullid && $id ne $nullid2} {
6668 set menu $rowctxmenu
6669 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6670 } else {
6671 set menu $fakerowmenu
6673 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6674 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6675 $menu entryconfigure [mc "Make patch"] -state $state
6676 tk_popup $menu $x $y
6679 proc diffvssel {dirn} {
6680 global rowmenuid selectedline
6682 if {![info exists selectedline]} return
6683 if {$dirn} {
6684 set oldid [commitonrow $selectedline]
6685 set newid $rowmenuid
6686 } else {
6687 set oldid $rowmenuid
6688 set newid [commitonrow $selectedline]
6690 addtohistory [list doseldiff $oldid $newid]
6691 doseldiff $oldid $newid
6694 proc doseldiff {oldid newid} {
6695 global ctext
6696 global commitinfo
6698 $ctext conf -state normal
6699 clear_ctext
6700 init_flist [mc "Top"]
6701 $ctext insert end "[mc "From"] "
6702 $ctext insert end $oldid link0
6703 setlink $oldid link0
6704 $ctext insert end "\n "
6705 $ctext insert end [lindex $commitinfo($oldid) 0]
6706 $ctext insert end "\n\n[mc "To"] "
6707 $ctext insert end $newid link1
6708 setlink $newid link1
6709 $ctext insert end "\n "
6710 $ctext insert end [lindex $commitinfo($newid) 0]
6711 $ctext insert end "\n"
6712 $ctext conf -state disabled
6713 $ctext tag remove found 1.0 end
6714 startdiff [list $oldid $newid]
6717 proc mkpatch {} {
6718 global rowmenuid currentid commitinfo patchtop patchnum
6720 if {![info exists currentid]} return
6721 set oldid $currentid
6722 set oldhead [lindex $commitinfo($oldid) 0]
6723 set newid $rowmenuid
6724 set newhead [lindex $commitinfo($newid) 0]
6725 set top .patch
6726 set patchtop $top
6727 catch {destroy $top}
6728 toplevel $top
6729 label $top.title -text [mc "Generate patch"]
6730 grid $top.title - -pady 10
6731 label $top.from -text [mc "From:"]
6732 entry $top.fromsha1 -width 40 -relief flat
6733 $top.fromsha1 insert 0 $oldid
6734 $top.fromsha1 conf -state readonly
6735 grid $top.from $top.fromsha1 -sticky w
6736 entry $top.fromhead -width 60 -relief flat
6737 $top.fromhead insert 0 $oldhead
6738 $top.fromhead conf -state readonly
6739 grid x $top.fromhead -sticky w
6740 label $top.to -text [mc "To:"]
6741 entry $top.tosha1 -width 40 -relief flat
6742 $top.tosha1 insert 0 $newid
6743 $top.tosha1 conf -state readonly
6744 grid $top.to $top.tosha1 -sticky w
6745 entry $top.tohead -width 60 -relief flat
6746 $top.tohead insert 0 $newhead
6747 $top.tohead conf -state readonly
6748 grid x $top.tohead -sticky w
6749 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6750 grid $top.rev x -pady 10
6751 label $top.flab -text [mc "Output file:"]
6752 entry $top.fname -width 60
6753 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6754 incr patchnum
6755 grid $top.flab $top.fname -sticky w
6756 frame $top.buts
6757 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6758 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6759 grid $top.buts.gen $top.buts.can
6760 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6761 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6762 grid $top.buts - -pady 10 -sticky ew
6763 focus $top.fname
6766 proc mkpatchrev {} {
6767 global patchtop
6769 set oldid [$patchtop.fromsha1 get]
6770 set oldhead [$patchtop.fromhead get]
6771 set newid [$patchtop.tosha1 get]
6772 set newhead [$patchtop.tohead get]
6773 foreach e [list fromsha1 fromhead tosha1 tohead] \
6774 v [list $newid $newhead $oldid $oldhead] {
6775 $patchtop.$e conf -state normal
6776 $patchtop.$e delete 0 end
6777 $patchtop.$e insert 0 $v
6778 $patchtop.$e conf -state readonly
6782 proc mkpatchgo {} {
6783 global patchtop nullid nullid2
6785 set oldid [$patchtop.fromsha1 get]
6786 set newid [$patchtop.tosha1 get]
6787 set fname [$patchtop.fname get]
6788 set cmd [diffcmd [list $oldid $newid] -p]
6789 # trim off the initial "|"
6790 set cmd [lrange $cmd 1 end]
6791 lappend cmd >$fname &
6792 if {[catch {eval exec $cmd} err]} {
6793 error_popup "[mc "Error creating patch:"] $err"
6795 catch {destroy $patchtop}
6796 unset patchtop
6799 proc mkpatchcan {} {
6800 global patchtop
6802 catch {destroy $patchtop}
6803 unset patchtop
6806 proc mktag {} {
6807 global rowmenuid mktagtop commitinfo
6809 set top .maketag
6810 set mktagtop $top
6811 catch {destroy $top}
6812 toplevel $top
6813 label $top.title -text [mc "Create tag"]
6814 grid $top.title - -pady 10
6815 label $top.id -text [mc "ID:"]
6816 entry $top.sha1 -width 40 -relief flat
6817 $top.sha1 insert 0 $rowmenuid
6818 $top.sha1 conf -state readonly
6819 grid $top.id $top.sha1 -sticky w
6820 entry $top.head -width 60 -relief flat
6821 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6822 $top.head conf -state readonly
6823 grid x $top.head -sticky w
6824 label $top.tlab -text [mc "Tag name:"]
6825 entry $top.tag -width 60
6826 grid $top.tlab $top.tag -sticky w
6827 frame $top.buts
6828 button $top.buts.gen -text [mc "Create"] -command mktaggo
6829 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6830 grid $top.buts.gen $top.buts.can
6831 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6832 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6833 grid $top.buts - -pady 10 -sticky ew
6834 focus $top.tag
6837 proc domktag {} {
6838 global mktagtop env tagids idtags
6840 set id [$mktagtop.sha1 get]
6841 set tag [$mktagtop.tag get]
6842 if {$tag == {}} {
6843 error_popup [mc "No tag name specified"]
6844 return
6846 if {[info exists tagids($tag)]} {
6847 error_popup [mc "Tag \"%s\" already exists" $tag]
6848 return
6850 if {[catch {
6851 set dir [gitdir]
6852 set fname [file join $dir "refs/tags" $tag]
6853 set f [open $fname w]
6854 puts $f $id
6855 close $f
6856 } err]} {
6857 error_popup "[mc "Error creating tag:"] $err"
6858 return
6861 set tagids($tag) $id
6862 lappend idtags($id) $tag
6863 redrawtags $id
6864 addedtag $id
6865 dispneartags 0
6866 run refill_reflist
6869 proc redrawtags {id} {
6870 global canv linehtag idpos currentid curview
6871 global canvxmax iddrawn
6873 if {![commitinview $id $curview]} return
6874 if {![info exists iddrawn($id)]} return
6875 set row [rowofcommit $id]
6876 $canv delete tag.$id
6877 set xt [eval drawtags $id $idpos($id)]
6878 $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
6879 set text [$canv itemcget $linehtag($row) -text]
6880 set font [$canv itemcget $linehtag($row) -font]
6881 set xr [expr {$xt + [font measure $font $text]}]
6882 if {$xr > $canvxmax} {
6883 set canvxmax $xr
6884 setcanvscroll
6886 if {[info exists currentid] && $currentid == $id} {
6887 make_secsel $row
6891 proc mktagcan {} {
6892 global mktagtop
6894 catch {destroy $mktagtop}
6895 unset mktagtop
6898 proc mktaggo {} {
6899 domktag
6900 mktagcan
6903 proc writecommit {} {
6904 global rowmenuid wrcomtop commitinfo wrcomcmd
6906 set top .writecommit
6907 set wrcomtop $top
6908 catch {destroy $top}
6909 toplevel $top
6910 label $top.title -text [mc "Write commit to file"]
6911 grid $top.title - -pady 10
6912 label $top.id -text [mc "ID:"]
6913 entry $top.sha1 -width 40 -relief flat
6914 $top.sha1 insert 0 $rowmenuid
6915 $top.sha1 conf -state readonly
6916 grid $top.id $top.sha1 -sticky w
6917 entry $top.head -width 60 -relief flat
6918 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6919 $top.head conf -state readonly
6920 grid x $top.head -sticky w
6921 label $top.clab -text [mc "Command:"]
6922 entry $top.cmd -width 60 -textvariable wrcomcmd
6923 grid $top.clab $top.cmd -sticky w -pady 10
6924 label $top.flab -text [mc "Output file:"]
6925 entry $top.fname -width 60
6926 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6927 grid $top.flab $top.fname -sticky w
6928 frame $top.buts
6929 button $top.buts.gen -text [mc "Write"] -command wrcomgo
6930 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
6931 grid $top.buts.gen $top.buts.can
6932 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6933 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6934 grid $top.buts - -pady 10 -sticky ew
6935 focus $top.fname
6938 proc wrcomgo {} {
6939 global wrcomtop
6941 set id [$wrcomtop.sha1 get]
6942 set cmd "echo $id | [$wrcomtop.cmd get]"
6943 set fname [$wrcomtop.fname get]
6944 if {[catch {exec sh -c $cmd >$fname &} err]} {
6945 error_popup "[mc "Error writing commit:"] $err"
6947 catch {destroy $wrcomtop}
6948 unset wrcomtop
6951 proc wrcomcan {} {
6952 global wrcomtop
6954 catch {destroy $wrcomtop}
6955 unset wrcomtop
6958 proc mkbranch {} {
6959 global rowmenuid mkbrtop
6961 set top .makebranch
6962 catch {destroy $top}
6963 toplevel $top
6964 label $top.title -text [mc "Create new branch"]
6965 grid $top.title - -pady 10
6966 label $top.id -text [mc "ID:"]
6967 entry $top.sha1 -width 40 -relief flat
6968 $top.sha1 insert 0 $rowmenuid
6969 $top.sha1 conf -state readonly
6970 grid $top.id $top.sha1 -sticky w
6971 label $top.nlab -text [mc "Name:"]
6972 entry $top.name -width 40
6973 grid $top.nlab $top.name -sticky w
6974 frame $top.buts
6975 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
6976 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
6977 grid $top.buts.go $top.buts.can
6978 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6979 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6980 grid $top.buts - -pady 10 -sticky ew
6981 focus $top.name
6984 proc mkbrgo {top} {
6985 global headids idheads
6987 set name [$top.name get]
6988 set id [$top.sha1 get]
6989 if {$name eq {}} {
6990 error_popup [mc "Please specify a name for the new branch"]
6991 return
6993 catch {destroy $top}
6994 nowbusy newbranch
6995 update
6996 if {[catch {
6997 exec git branch $name $id
6998 } err]} {
6999 notbusy newbranch
7000 error_popup $err
7001 } else {
7002 set headids($name) $id
7003 lappend idheads($id) $name
7004 addedhead $id $name
7005 notbusy newbranch
7006 redrawtags $id
7007 dispneartags 0
7008 run refill_reflist
7012 proc cherrypick {} {
7013 global rowmenuid curview
7014 global mainhead
7016 set oldhead [exec git rev-parse HEAD]
7017 set dheads [descheads $rowmenuid]
7018 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7019 set ok [confirm_popup [mc "Commit %s is already\
7020 included in branch %s -- really re-apply it?" \
7021 [string range $rowmenuid 0 7] $mainhead]]
7022 if {!$ok} return
7024 nowbusy cherrypick [mc "Cherry-picking"]
7025 update
7026 # Unfortunately git-cherry-pick writes stuff to stderr even when
7027 # no error occurs, and exec takes that as an indication of error...
7028 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7029 notbusy cherrypick
7030 error_popup $err
7031 return
7033 set newhead [exec git rev-parse HEAD]
7034 if {$newhead eq $oldhead} {
7035 notbusy cherrypick
7036 error_popup [mc "No changes committed"]
7037 return
7039 addnewchild $newhead $oldhead
7040 if {[commitinview $oldhead $curview]} {
7041 insertrow $newhead $oldhead $curview
7042 if {$mainhead ne {}} {
7043 movehead $newhead $mainhead
7044 movedhead $newhead $mainhead
7046 redrawtags $oldhead
7047 redrawtags $newhead
7049 notbusy cherrypick
7052 proc resethead {} {
7053 global mainheadid mainhead rowmenuid confirm_ok resettype
7055 set confirm_ok 0
7056 set w ".confirmreset"
7057 toplevel $w
7058 wm transient $w .
7059 wm title $w [mc "Confirm reset"]
7060 message $w.m -text \
7061 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7062 -justify center -aspect 1000
7063 pack $w.m -side top -fill x -padx 20 -pady 20
7064 frame $w.f -relief sunken -border 2
7065 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7066 grid $w.f.rt -sticky w
7067 set resettype mixed
7068 radiobutton $w.f.soft -value soft -variable resettype -justify left \
7069 -text [mc "Soft: Leave working tree and index untouched"]
7070 grid $w.f.soft -sticky w
7071 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7072 -text [mc "Mixed: Leave working tree untouched, reset index"]
7073 grid $w.f.mixed -sticky w
7074 radiobutton $w.f.hard -value hard -variable resettype -justify left \
7075 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7076 grid $w.f.hard -sticky w
7077 pack $w.f -side top -fill x
7078 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7079 pack $w.ok -side left -fill x -padx 20 -pady 20
7080 button $w.cancel -text [mc Cancel] -command "destroy $w"
7081 pack $w.cancel -side right -fill x -padx 20 -pady 20
7082 bind $w <Visibility> "grab $w; focus $w"
7083 tkwait window $w
7084 if {!$confirm_ok} return
7085 if {[catch {set fd [open \
7086 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
7087 error_popup $err
7088 } else {
7089 dohidelocalchanges
7090 filerun $fd [list readresetstat $fd]
7091 nowbusy reset [mc "Resetting"]
7095 proc readresetstat {fd} {
7096 global mainhead mainheadid showlocalchanges rprogcoord
7098 if {[gets $fd line] >= 0} {
7099 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7100 set rprogcoord [expr {1.0 * $m / $n}]
7101 adjustprogress
7103 return 1
7105 set rprogcoord 0
7106 adjustprogress
7107 notbusy reset
7108 if {[catch {close $fd} err]} {
7109 error_popup $err
7111 set oldhead $mainheadid
7112 set newhead [exec git rev-parse HEAD]
7113 if {$newhead ne $oldhead} {
7114 movehead $newhead $mainhead
7115 movedhead $newhead $mainhead
7116 set mainheadid $newhead
7117 redrawtags $oldhead
7118 redrawtags $newhead
7120 if {$showlocalchanges} {
7121 doshowlocalchanges
7123 return 0
7126 # context menu for a head
7127 proc headmenu {x y id head} {
7128 global headmenuid headmenuhead headctxmenu mainhead
7130 stopfinding
7131 set headmenuid $id
7132 set headmenuhead $head
7133 set state normal
7134 if {$head eq $mainhead} {
7135 set state disabled
7137 $headctxmenu entryconfigure 0 -state $state
7138 $headctxmenu entryconfigure 1 -state $state
7139 tk_popup $headctxmenu $x $y
7142 proc cobranch {} {
7143 global headmenuid headmenuhead mainhead headids
7144 global showlocalchanges mainheadid
7146 # check the tree is clean first??
7147 set oldmainhead $mainhead
7148 nowbusy checkout [mc "Checking out"]
7149 update
7150 dohidelocalchanges
7151 if {[catch {
7152 exec git checkout -q $headmenuhead
7153 } err]} {
7154 notbusy checkout
7155 error_popup $err
7156 } else {
7157 notbusy checkout
7158 set mainhead $headmenuhead
7159 set mainheadid $headmenuid
7160 if {[info exists headids($oldmainhead)]} {
7161 redrawtags $headids($oldmainhead)
7163 redrawtags $headmenuid
7165 if {$showlocalchanges} {
7166 dodiffindex
7170 proc rmbranch {} {
7171 global headmenuid headmenuhead mainhead
7172 global idheads
7174 set head $headmenuhead
7175 set id $headmenuid
7176 # this check shouldn't be needed any more...
7177 if {$head eq $mainhead} {
7178 error_popup [mc "Cannot delete the currently checked-out branch"]
7179 return
7181 set dheads [descheads $id]
7182 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7183 # the stuff on this branch isn't on any other branch
7184 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7185 branch.\nReally delete branch %s?" $head $head]]} return
7187 nowbusy rmbranch
7188 update
7189 if {[catch {exec git branch -D $head} err]} {
7190 notbusy rmbranch
7191 error_popup $err
7192 return
7194 removehead $id $head
7195 removedhead $id $head
7196 redrawtags $id
7197 notbusy rmbranch
7198 dispneartags 0
7199 run refill_reflist
7202 # Display a list of tags and heads
7203 proc showrefs {} {
7204 global showrefstop bgcolor fgcolor selectbgcolor
7205 global bglist fglist reflistfilter reflist maincursor
7207 set top .showrefs
7208 set showrefstop $top
7209 if {[winfo exists $top]} {
7210 raise $top
7211 refill_reflist
7212 return
7214 toplevel $top
7215 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7216 text $top.list -background $bgcolor -foreground $fgcolor \
7217 -selectbackground $selectbgcolor -font mainfont \
7218 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7219 -width 30 -height 20 -cursor $maincursor \
7220 -spacing1 1 -spacing3 1 -state disabled
7221 $top.list tag configure highlight -background $selectbgcolor
7222 lappend bglist $top.list
7223 lappend fglist $top.list
7224 scrollbar $top.ysb -command "$top.list yview" -orient vertical
7225 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7226 grid $top.list $top.ysb -sticky nsew
7227 grid $top.xsb x -sticky ew
7228 frame $top.f
7229 label $top.f.l -text "[mc "Filter"]: " -font uifont
7230 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
7231 set reflistfilter "*"
7232 trace add variable reflistfilter write reflistfilter_change
7233 pack $top.f.e -side right -fill x -expand 1
7234 pack $top.f.l -side left
7235 grid $top.f - -sticky ew -pady 2
7236 button $top.close -command [list destroy $top] -text [mc "Close"] \
7237 -font uifont
7238 grid $top.close -
7239 grid columnconfigure $top 0 -weight 1
7240 grid rowconfigure $top 0 -weight 1
7241 bind $top.list <1> {break}
7242 bind $top.list <B1-Motion> {break}
7243 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7244 set reflist {}
7245 refill_reflist
7248 proc sel_reflist {w x y} {
7249 global showrefstop reflist headids tagids otherrefids
7251 if {![winfo exists $showrefstop]} return
7252 set l [lindex [split [$w index "@$x,$y"] "."] 0]
7253 set ref [lindex $reflist [expr {$l-1}]]
7254 set n [lindex $ref 0]
7255 switch -- [lindex $ref 1] {
7256 "H" {selbyid $headids($n)}
7257 "T" {selbyid $tagids($n)}
7258 "o" {selbyid $otherrefids($n)}
7260 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7263 proc unsel_reflist {} {
7264 global showrefstop
7266 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7267 $showrefstop.list tag remove highlight 0.0 end
7270 proc reflistfilter_change {n1 n2 op} {
7271 global reflistfilter
7273 after cancel refill_reflist
7274 after 200 refill_reflist
7277 proc refill_reflist {} {
7278 global reflist reflistfilter showrefstop headids tagids otherrefids
7279 global curview commitinterest
7281 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7282 set refs {}
7283 foreach n [array names headids] {
7284 if {[string match $reflistfilter $n]} {
7285 if {[commitinview $headids($n) $curview]} {
7286 lappend refs [list $n H]
7287 } else {
7288 set commitinterest($headids($n)) {run refill_reflist}
7292 foreach n [array names tagids] {
7293 if {[string match $reflistfilter $n]} {
7294 if {[commitinview $tagids($n) $curview]} {
7295 lappend refs [list $n T]
7296 } else {
7297 set commitinterest($tagids($n)) {run refill_reflist}
7301 foreach n [array names otherrefids] {
7302 if {[string match $reflistfilter $n]} {
7303 if {[commitinview $otherrefids($n) $curview]} {
7304 lappend refs [list $n o]
7305 } else {
7306 set commitinterest($otherrefids($n)) {run refill_reflist}
7310 set refs [lsort -index 0 $refs]
7311 if {$refs eq $reflist} return
7313 # Update the contents of $showrefstop.list according to the
7314 # differences between $reflist (old) and $refs (new)
7315 $showrefstop.list conf -state normal
7316 $showrefstop.list insert end "\n"
7317 set i 0
7318 set j 0
7319 while {$i < [llength $reflist] || $j < [llength $refs]} {
7320 if {$i < [llength $reflist]} {
7321 if {$j < [llength $refs]} {
7322 set cmp [string compare [lindex $reflist $i 0] \
7323 [lindex $refs $j 0]]
7324 if {$cmp == 0} {
7325 set cmp [string compare [lindex $reflist $i 1] \
7326 [lindex $refs $j 1]]
7328 } else {
7329 set cmp -1
7331 } else {
7332 set cmp 1
7334 switch -- $cmp {
7335 -1 {
7336 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7337 incr i
7340 incr i
7341 incr j
7344 set l [expr {$j + 1}]
7345 $showrefstop.list image create $l.0 -align baseline \
7346 -image reficon-[lindex $refs $j 1] -padx 2
7347 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7348 incr j
7352 set reflist $refs
7353 # delete last newline
7354 $showrefstop.list delete end-2c end-1c
7355 $showrefstop.list conf -state disabled
7358 # Stuff for finding nearby tags
7359 proc getallcommits {} {
7360 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7361 global idheads idtags idotherrefs allparents tagobjid
7363 if {![info exists allcommits]} {
7364 set nextarc 0
7365 set allcommits 0
7366 set seeds {}
7367 set allcwait 0
7368 set cachedarcs 0
7369 set allccache [file join [gitdir] "gitk.cache"]
7370 if {![catch {
7371 set f [open $allccache r]
7372 set allcwait 1
7373 getcache $f
7374 }]} return
7377 if {$allcwait} {
7378 return
7380 set cmd [list | git rev-list --parents]
7381 set allcupdate [expr {$seeds ne {}}]
7382 if {!$allcupdate} {
7383 set ids "--all"
7384 } else {
7385 set refs [concat [array names idheads] [array names idtags] \
7386 [array names idotherrefs]]
7387 set ids {}
7388 set tagobjs {}
7389 foreach name [array names tagobjid] {
7390 lappend tagobjs $tagobjid($name)
7392 foreach id [lsort -unique $refs] {
7393 if {![info exists allparents($id)] &&
7394 [lsearch -exact $tagobjs $id] < 0} {
7395 lappend ids $id
7398 if {$ids ne {}} {
7399 foreach id $seeds {
7400 lappend ids "^$id"
7404 if {$ids ne {}} {
7405 set fd [open [concat $cmd $ids] r]
7406 fconfigure $fd -blocking 0
7407 incr allcommits
7408 nowbusy allcommits
7409 filerun $fd [list getallclines $fd]
7410 } else {
7411 dispneartags 0
7415 # Since most commits have 1 parent and 1 child, we group strings of
7416 # such commits into "arcs" joining branch/merge points (BMPs), which
7417 # are commits that either don't have 1 parent or don't have 1 child.
7419 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7420 # arcout(id) - outgoing arcs for BMP
7421 # arcids(a) - list of IDs on arc including end but not start
7422 # arcstart(a) - BMP ID at start of arc
7423 # arcend(a) - BMP ID at end of arc
7424 # growing(a) - arc a is still growing
7425 # arctags(a) - IDs out of arcids (excluding end) that have tags
7426 # archeads(a) - IDs out of arcids (excluding end) that have heads
7427 # The start of an arc is at the descendent end, so "incoming" means
7428 # coming from descendents, and "outgoing" means going towards ancestors.
7430 proc getallclines {fd} {
7431 global allparents allchildren idtags idheads nextarc
7432 global arcnos arcids arctags arcout arcend arcstart archeads growing
7433 global seeds allcommits cachedarcs allcupdate
7435 set nid 0
7436 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7437 set id [lindex $line 0]
7438 if {[info exists allparents($id)]} {
7439 # seen it already
7440 continue
7442 set cachedarcs 0
7443 set olds [lrange $line 1 end]
7444 set allparents($id) $olds
7445 if {![info exists allchildren($id)]} {
7446 set allchildren($id) {}
7447 set arcnos($id) {}
7448 lappend seeds $id
7449 } else {
7450 set a $arcnos($id)
7451 if {[llength $olds] == 1 && [llength $a] == 1} {
7452 lappend arcids($a) $id
7453 if {[info exists idtags($id)]} {
7454 lappend arctags($a) $id
7456 if {[info exists idheads($id)]} {
7457 lappend archeads($a) $id
7459 if {[info exists allparents($olds)]} {
7460 # seen parent already
7461 if {![info exists arcout($olds)]} {
7462 splitarc $olds
7464 lappend arcids($a) $olds
7465 set arcend($a) $olds
7466 unset growing($a)
7468 lappend allchildren($olds) $id
7469 lappend arcnos($olds) $a
7470 continue
7473 foreach a $arcnos($id) {
7474 lappend arcids($a) $id
7475 set arcend($a) $id
7476 unset growing($a)
7479 set ao {}
7480 foreach p $olds {
7481 lappend allchildren($p) $id
7482 set a [incr nextarc]
7483 set arcstart($a) $id
7484 set archeads($a) {}
7485 set arctags($a) {}
7486 set archeads($a) {}
7487 set arcids($a) {}
7488 lappend ao $a
7489 set growing($a) 1
7490 if {[info exists allparents($p)]} {
7491 # seen it already, may need to make a new branch
7492 if {![info exists arcout($p)]} {
7493 splitarc $p
7495 lappend arcids($a) $p
7496 set arcend($a) $p
7497 unset growing($a)
7499 lappend arcnos($p) $a
7501 set arcout($id) $ao
7503 if {$nid > 0} {
7504 global cached_dheads cached_dtags cached_atags
7505 catch {unset cached_dheads}
7506 catch {unset cached_dtags}
7507 catch {unset cached_atags}
7509 if {![eof $fd]} {
7510 return [expr {$nid >= 1000? 2: 1}]
7512 set cacheok 1
7513 if {[catch {
7514 fconfigure $fd -blocking 1
7515 close $fd
7516 } err]} {
7517 # got an error reading the list of commits
7518 # if we were updating, try rereading the whole thing again
7519 if {$allcupdate} {
7520 incr allcommits -1
7521 dropcache $err
7522 return
7524 error_popup "[mc "Error reading commit topology information;\
7525 branch and preceding/following tag information\
7526 will be incomplete."]\n($err)"
7527 set cacheok 0
7529 if {[incr allcommits -1] == 0} {
7530 notbusy allcommits
7531 if {$cacheok} {
7532 run savecache
7535 dispneartags 0
7536 return 0
7539 proc recalcarc {a} {
7540 global arctags archeads arcids idtags idheads
7542 set at {}
7543 set ah {}
7544 foreach id [lrange $arcids($a) 0 end-1] {
7545 if {[info exists idtags($id)]} {
7546 lappend at $id
7548 if {[info exists idheads($id)]} {
7549 lappend ah $id
7552 set arctags($a) $at
7553 set archeads($a) $ah
7556 proc splitarc {p} {
7557 global arcnos arcids nextarc arctags archeads idtags idheads
7558 global arcstart arcend arcout allparents growing
7560 set a $arcnos($p)
7561 if {[llength $a] != 1} {
7562 puts "oops splitarc called but [llength $a] arcs already"
7563 return
7565 set a [lindex $a 0]
7566 set i [lsearch -exact $arcids($a) $p]
7567 if {$i < 0} {
7568 puts "oops splitarc $p not in arc $a"
7569 return
7571 set na [incr nextarc]
7572 if {[info exists arcend($a)]} {
7573 set arcend($na) $arcend($a)
7574 } else {
7575 set l [lindex $allparents([lindex $arcids($a) end]) 0]
7576 set j [lsearch -exact $arcnos($l) $a]
7577 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7579 set tail [lrange $arcids($a) [expr {$i+1}] end]
7580 set arcids($a) [lrange $arcids($a) 0 $i]
7581 set arcend($a) $p
7582 set arcstart($na) $p
7583 set arcout($p) $na
7584 set arcids($na) $tail
7585 if {[info exists growing($a)]} {
7586 set growing($na) 1
7587 unset growing($a)
7590 foreach id $tail {
7591 if {[llength $arcnos($id)] == 1} {
7592 set arcnos($id) $na
7593 } else {
7594 set j [lsearch -exact $arcnos($id) $a]
7595 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7599 # reconstruct tags and heads lists
7600 if {$arctags($a) ne {} || $archeads($a) ne {}} {
7601 recalcarc $a
7602 recalcarc $na
7603 } else {
7604 set arctags($na) {}
7605 set archeads($na) {}
7609 # Update things for a new commit added that is a child of one
7610 # existing commit. Used when cherry-picking.
7611 proc addnewchild {id p} {
7612 global allparents allchildren idtags nextarc
7613 global arcnos arcids arctags arcout arcend arcstart archeads growing
7614 global seeds allcommits
7616 if {![info exists allcommits] || ![info exists arcnos($p)]} return
7617 set allparents($id) [list $p]
7618 set allchildren($id) {}
7619 set arcnos($id) {}
7620 lappend seeds $id
7621 lappend allchildren($p) $id
7622 set a [incr nextarc]
7623 set arcstart($a) $id
7624 set archeads($a) {}
7625 set arctags($a) {}
7626 set arcids($a) [list $p]
7627 set arcend($a) $p
7628 if {![info exists arcout($p)]} {
7629 splitarc $p
7631 lappend arcnos($p) $a
7632 set arcout($id) [list $a]
7635 # This implements a cache for the topology information.
7636 # The cache saves, for each arc, the start and end of the arc,
7637 # the ids on the arc, and the outgoing arcs from the end.
7638 proc readcache {f} {
7639 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7640 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7641 global allcwait
7643 set a $nextarc
7644 set lim $cachedarcs
7645 if {$lim - $a > 500} {
7646 set lim [expr {$a + 500}]
7648 if {[catch {
7649 if {$a == $lim} {
7650 # finish reading the cache and setting up arctags, etc.
7651 set line [gets $f]
7652 if {$line ne "1"} {error "bad final version"}
7653 close $f
7654 foreach id [array names idtags] {
7655 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7656 [llength $allparents($id)] == 1} {
7657 set a [lindex $arcnos($id) 0]
7658 if {$arctags($a) eq {}} {
7659 recalcarc $a
7663 foreach id [array names idheads] {
7664 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7665 [llength $allparents($id)] == 1} {
7666 set a [lindex $arcnos($id) 0]
7667 if {$archeads($a) eq {}} {
7668 recalcarc $a
7672 foreach id [lsort -unique $possible_seeds] {
7673 if {$arcnos($id) eq {}} {
7674 lappend seeds $id
7677 set allcwait 0
7678 } else {
7679 while {[incr a] <= $lim} {
7680 set line [gets $f]
7681 if {[llength $line] != 3} {error "bad line"}
7682 set s [lindex $line 0]
7683 set arcstart($a) $s
7684 lappend arcout($s) $a
7685 if {![info exists arcnos($s)]} {
7686 lappend possible_seeds $s
7687 set arcnos($s) {}
7689 set e [lindex $line 1]
7690 if {$e eq {}} {
7691 set growing($a) 1
7692 } else {
7693 set arcend($a) $e
7694 if {![info exists arcout($e)]} {
7695 set arcout($e) {}
7698 set arcids($a) [lindex $line 2]
7699 foreach id $arcids($a) {
7700 lappend allparents($s) $id
7701 set s $id
7702 lappend arcnos($id) $a
7704 if {![info exists allparents($s)]} {
7705 set allparents($s) {}
7707 set arctags($a) {}
7708 set archeads($a) {}
7710 set nextarc [expr {$a - 1}]
7712 } err]} {
7713 dropcache $err
7714 return 0
7716 if {!$allcwait} {
7717 getallcommits
7719 return $allcwait
7722 proc getcache {f} {
7723 global nextarc cachedarcs possible_seeds
7725 if {[catch {
7726 set line [gets $f]
7727 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7728 # make sure it's an integer
7729 set cachedarcs [expr {int([lindex $line 1])}]
7730 if {$cachedarcs < 0} {error "bad number of arcs"}
7731 set nextarc 0
7732 set possible_seeds {}
7733 run readcache $f
7734 } err]} {
7735 dropcache $err
7737 return 0
7740 proc dropcache {err} {
7741 global allcwait nextarc cachedarcs seeds
7743 #puts "dropping cache ($err)"
7744 foreach v {arcnos arcout arcids arcstart arcend growing \
7745 arctags archeads allparents allchildren} {
7746 global $v
7747 catch {unset $v}
7749 set allcwait 0
7750 set nextarc 0
7751 set cachedarcs 0
7752 set seeds {}
7753 getallcommits
7756 proc writecache {f} {
7757 global cachearc cachedarcs allccache
7758 global arcstart arcend arcnos arcids arcout
7760 set a $cachearc
7761 set lim $cachedarcs
7762 if {$lim - $a > 1000} {
7763 set lim [expr {$a + 1000}]
7765 if {[catch {
7766 while {[incr a] <= $lim} {
7767 if {[info exists arcend($a)]} {
7768 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7769 } else {
7770 puts $f [list $arcstart($a) {} $arcids($a)]
7773 } err]} {
7774 catch {close $f}
7775 catch {file delete $allccache}
7776 #puts "writing cache failed ($err)"
7777 return 0
7779 set cachearc [expr {$a - 1}]
7780 if {$a > $cachedarcs} {
7781 puts $f "1"
7782 close $f
7783 return 0
7785 return 1
7788 proc savecache {} {
7789 global nextarc cachedarcs cachearc allccache
7791 if {$nextarc == $cachedarcs} return
7792 set cachearc 0
7793 set cachedarcs $nextarc
7794 catch {
7795 set f [open $allccache w]
7796 puts $f [list 1 $cachedarcs]
7797 run writecache $f
7801 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7802 # or 0 if neither is true.
7803 proc anc_or_desc {a b} {
7804 global arcout arcstart arcend arcnos cached_isanc
7806 if {$arcnos($a) eq $arcnos($b)} {
7807 # Both are on the same arc(s); either both are the same BMP,
7808 # or if one is not a BMP, the other is also not a BMP or is
7809 # the BMP at end of the arc (and it only has 1 incoming arc).
7810 # Or both can be BMPs with no incoming arcs.
7811 if {$a eq $b || $arcnos($a) eq {}} {
7812 return 0
7814 # assert {[llength $arcnos($a)] == 1}
7815 set arc [lindex $arcnos($a) 0]
7816 set i [lsearch -exact $arcids($arc) $a]
7817 set j [lsearch -exact $arcids($arc) $b]
7818 if {$i < 0 || $i > $j} {
7819 return 1
7820 } else {
7821 return -1
7825 if {![info exists arcout($a)]} {
7826 set arc [lindex $arcnos($a) 0]
7827 if {[info exists arcend($arc)]} {
7828 set aend $arcend($arc)
7829 } else {
7830 set aend {}
7832 set a $arcstart($arc)
7833 } else {
7834 set aend $a
7836 if {![info exists arcout($b)]} {
7837 set arc [lindex $arcnos($b) 0]
7838 if {[info exists arcend($arc)]} {
7839 set bend $arcend($arc)
7840 } else {
7841 set bend {}
7843 set b $arcstart($arc)
7844 } else {
7845 set bend $b
7847 if {$a eq $bend} {
7848 return 1
7850 if {$b eq $aend} {
7851 return -1
7853 if {[info exists cached_isanc($a,$bend)]} {
7854 if {$cached_isanc($a,$bend)} {
7855 return 1
7858 if {[info exists cached_isanc($b,$aend)]} {
7859 if {$cached_isanc($b,$aend)} {
7860 return -1
7862 if {[info exists cached_isanc($a,$bend)]} {
7863 return 0
7867 set todo [list $a $b]
7868 set anc($a) a
7869 set anc($b) b
7870 for {set i 0} {$i < [llength $todo]} {incr i} {
7871 set x [lindex $todo $i]
7872 if {$anc($x) eq {}} {
7873 continue
7875 foreach arc $arcnos($x) {
7876 set xd $arcstart($arc)
7877 if {$xd eq $bend} {
7878 set cached_isanc($a,$bend) 1
7879 set cached_isanc($b,$aend) 0
7880 return 1
7881 } elseif {$xd eq $aend} {
7882 set cached_isanc($b,$aend) 1
7883 set cached_isanc($a,$bend) 0
7884 return -1
7886 if {![info exists anc($xd)]} {
7887 set anc($xd) $anc($x)
7888 lappend todo $xd
7889 } elseif {$anc($xd) ne $anc($x)} {
7890 set anc($xd) {}
7894 set cached_isanc($a,$bend) 0
7895 set cached_isanc($b,$aend) 0
7896 return 0
7899 # This identifies whether $desc has an ancestor that is
7900 # a growing tip of the graph and which is not an ancestor of $anc
7901 # and returns 0 if so and 1 if not.
7902 # If we subsequently discover a tag on such a growing tip, and that
7903 # turns out to be a descendent of $anc (which it could, since we
7904 # don't necessarily see children before parents), then $desc
7905 # isn't a good choice to display as a descendent tag of
7906 # $anc (since it is the descendent of another tag which is
7907 # a descendent of $anc). Similarly, $anc isn't a good choice to
7908 # display as a ancestor tag of $desc.
7910 proc is_certain {desc anc} {
7911 global arcnos arcout arcstart arcend growing problems
7913 set certain {}
7914 if {[llength $arcnos($anc)] == 1} {
7915 # tags on the same arc are certain
7916 if {$arcnos($desc) eq $arcnos($anc)} {
7917 return 1
7919 if {![info exists arcout($anc)]} {
7920 # if $anc is partway along an arc, use the start of the arc instead
7921 set a [lindex $arcnos($anc) 0]
7922 set anc $arcstart($a)
7925 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7926 set x $desc
7927 } else {
7928 set a [lindex $arcnos($desc) 0]
7929 set x $arcend($a)
7931 if {$x == $anc} {
7932 return 1
7934 set anclist [list $x]
7935 set dl($x) 1
7936 set nnh 1
7937 set ngrowanc 0
7938 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7939 set x [lindex $anclist $i]
7940 if {$dl($x)} {
7941 incr nnh -1
7943 set done($x) 1
7944 foreach a $arcout($x) {
7945 if {[info exists growing($a)]} {
7946 if {![info exists growanc($x)] && $dl($x)} {
7947 set growanc($x) 1
7948 incr ngrowanc
7950 } else {
7951 set y $arcend($a)
7952 if {[info exists dl($y)]} {
7953 if {$dl($y)} {
7954 if {!$dl($x)} {
7955 set dl($y) 0
7956 if {![info exists done($y)]} {
7957 incr nnh -1
7959 if {[info exists growanc($x)]} {
7960 incr ngrowanc -1
7962 set xl [list $y]
7963 for {set k 0} {$k < [llength $xl]} {incr k} {
7964 set z [lindex $xl $k]
7965 foreach c $arcout($z) {
7966 if {[info exists arcend($c)]} {
7967 set v $arcend($c)
7968 if {[info exists dl($v)] && $dl($v)} {
7969 set dl($v) 0
7970 if {![info exists done($v)]} {
7971 incr nnh -1
7973 if {[info exists growanc($v)]} {
7974 incr ngrowanc -1
7976 lappend xl $v
7983 } elseif {$y eq $anc || !$dl($x)} {
7984 set dl($y) 0
7985 lappend anclist $y
7986 } else {
7987 set dl($y) 1
7988 lappend anclist $y
7989 incr nnh
7994 foreach x [array names growanc] {
7995 if {$dl($x)} {
7996 return 0
7998 return 0
8000 return 1
8003 proc validate_arctags {a} {
8004 global arctags idtags
8006 set i -1
8007 set na $arctags($a)
8008 foreach id $arctags($a) {
8009 incr i
8010 if {![info exists idtags($id)]} {
8011 set na [lreplace $na $i $i]
8012 incr i -1
8015 set arctags($a) $na
8018 proc validate_archeads {a} {
8019 global archeads idheads
8021 set i -1
8022 set na $archeads($a)
8023 foreach id $archeads($a) {
8024 incr i
8025 if {![info exists idheads($id)]} {
8026 set na [lreplace $na $i $i]
8027 incr i -1
8030 set archeads($a) $na
8033 # Return the list of IDs that have tags that are descendents of id,
8034 # ignoring IDs that are descendents of IDs already reported.
8035 proc desctags {id} {
8036 global arcnos arcstart arcids arctags idtags allparents
8037 global growing cached_dtags
8039 if {![info exists allparents($id)]} {
8040 return {}
8042 set t1 [clock clicks -milliseconds]
8043 set argid $id
8044 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8045 # part-way along an arc; check that arc first
8046 set a [lindex $arcnos($id) 0]
8047 if {$arctags($a) ne {}} {
8048 validate_arctags $a
8049 set i [lsearch -exact $arcids($a) $id]
8050 set tid {}
8051 foreach t $arctags($a) {
8052 set j [lsearch -exact $arcids($a) $t]
8053 if {$j >= $i} break
8054 set tid $t
8056 if {$tid ne {}} {
8057 return $tid
8060 set id $arcstart($a)
8061 if {[info exists idtags($id)]} {
8062 return $id
8065 if {[info exists cached_dtags($id)]} {
8066 return $cached_dtags($id)
8069 set origid $id
8070 set todo [list $id]
8071 set queued($id) 1
8072 set nc 1
8073 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8074 set id [lindex $todo $i]
8075 set done($id) 1
8076 set ta [info exists hastaggedancestor($id)]
8077 if {!$ta} {
8078 incr nc -1
8080 # ignore tags on starting node
8081 if {!$ta && $i > 0} {
8082 if {[info exists idtags($id)]} {
8083 set tagloc($id) $id
8084 set ta 1
8085 } elseif {[info exists cached_dtags($id)]} {
8086 set tagloc($id) $cached_dtags($id)
8087 set ta 1
8090 foreach a $arcnos($id) {
8091 set d $arcstart($a)
8092 if {!$ta && $arctags($a) ne {}} {
8093 validate_arctags $a
8094 if {$arctags($a) ne {}} {
8095 lappend tagloc($id) [lindex $arctags($a) end]
8098 if {$ta || $arctags($a) ne {}} {
8099 set tomark [list $d]
8100 for {set j 0} {$j < [llength $tomark]} {incr j} {
8101 set dd [lindex $tomark $j]
8102 if {![info exists hastaggedancestor($dd)]} {
8103 if {[info exists done($dd)]} {
8104 foreach b $arcnos($dd) {
8105 lappend tomark $arcstart($b)
8107 if {[info exists tagloc($dd)]} {
8108 unset tagloc($dd)
8110 } elseif {[info exists queued($dd)]} {
8111 incr nc -1
8113 set hastaggedancestor($dd) 1
8117 if {![info exists queued($d)]} {
8118 lappend todo $d
8119 set queued($d) 1
8120 if {![info exists hastaggedancestor($d)]} {
8121 incr nc
8126 set tags {}
8127 foreach id [array names tagloc] {
8128 if {![info exists hastaggedancestor($id)]} {
8129 foreach t $tagloc($id) {
8130 if {[lsearch -exact $tags $t] < 0} {
8131 lappend tags $t
8136 set t2 [clock clicks -milliseconds]
8137 set loopix $i
8139 # remove tags that are descendents of other tags
8140 for {set i 0} {$i < [llength $tags]} {incr i} {
8141 set a [lindex $tags $i]
8142 for {set j 0} {$j < $i} {incr j} {
8143 set b [lindex $tags $j]
8144 set r [anc_or_desc $a $b]
8145 if {$r == 1} {
8146 set tags [lreplace $tags $j $j]
8147 incr j -1
8148 incr i -1
8149 } elseif {$r == -1} {
8150 set tags [lreplace $tags $i $i]
8151 incr i -1
8152 break
8157 if {[array names growing] ne {}} {
8158 # graph isn't finished, need to check if any tag could get
8159 # eclipsed by another tag coming later. Simply ignore any
8160 # tags that could later get eclipsed.
8161 set ctags {}
8162 foreach t $tags {
8163 if {[is_certain $t $origid]} {
8164 lappend ctags $t
8167 if {$tags eq $ctags} {
8168 set cached_dtags($origid) $tags
8169 } else {
8170 set tags $ctags
8172 } else {
8173 set cached_dtags($origid) $tags
8175 set t3 [clock clicks -milliseconds]
8176 if {0 && $t3 - $t1 >= 100} {
8177 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8178 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8180 return $tags
8183 proc anctags {id} {
8184 global arcnos arcids arcout arcend arctags idtags allparents
8185 global growing cached_atags
8187 if {![info exists allparents($id)]} {
8188 return {}
8190 set t1 [clock clicks -milliseconds]
8191 set argid $id
8192 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8193 # part-way along an arc; check that arc first
8194 set a [lindex $arcnos($id) 0]
8195 if {$arctags($a) ne {}} {
8196 validate_arctags $a
8197 set i [lsearch -exact $arcids($a) $id]
8198 foreach t $arctags($a) {
8199 set j [lsearch -exact $arcids($a) $t]
8200 if {$j > $i} {
8201 return $t
8205 if {![info exists arcend($a)]} {
8206 return {}
8208 set id $arcend($a)
8209 if {[info exists idtags($id)]} {
8210 return $id
8213 if {[info exists cached_atags($id)]} {
8214 return $cached_atags($id)
8217 set origid $id
8218 set todo [list $id]
8219 set queued($id) 1
8220 set taglist {}
8221 set nc 1
8222 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8223 set id [lindex $todo $i]
8224 set done($id) 1
8225 set td [info exists hastaggeddescendent($id)]
8226 if {!$td} {
8227 incr nc -1
8229 # ignore tags on starting node
8230 if {!$td && $i > 0} {
8231 if {[info exists idtags($id)]} {
8232 set tagloc($id) $id
8233 set td 1
8234 } elseif {[info exists cached_atags($id)]} {
8235 set tagloc($id) $cached_atags($id)
8236 set td 1
8239 foreach a $arcout($id) {
8240 if {!$td && $arctags($a) ne {}} {
8241 validate_arctags $a
8242 if {$arctags($a) ne {}} {
8243 lappend tagloc($id) [lindex $arctags($a) 0]
8246 if {![info exists arcend($a)]} continue
8247 set d $arcend($a)
8248 if {$td || $arctags($a) ne {}} {
8249 set tomark [list $d]
8250 for {set j 0} {$j < [llength $tomark]} {incr j} {
8251 set dd [lindex $tomark $j]
8252 if {![info exists hastaggeddescendent($dd)]} {
8253 if {[info exists done($dd)]} {
8254 foreach b $arcout($dd) {
8255 if {[info exists arcend($b)]} {
8256 lappend tomark $arcend($b)
8259 if {[info exists tagloc($dd)]} {
8260 unset tagloc($dd)
8262 } elseif {[info exists queued($dd)]} {
8263 incr nc -1
8265 set hastaggeddescendent($dd) 1
8269 if {![info exists queued($d)]} {
8270 lappend todo $d
8271 set queued($d) 1
8272 if {![info exists hastaggeddescendent($d)]} {
8273 incr nc
8278 set t2 [clock clicks -milliseconds]
8279 set loopix $i
8280 set tags {}
8281 foreach id [array names tagloc] {
8282 if {![info exists hastaggeddescendent($id)]} {
8283 foreach t $tagloc($id) {
8284 if {[lsearch -exact $tags $t] < 0} {
8285 lappend tags $t
8291 # remove tags that are ancestors of other tags
8292 for {set i 0} {$i < [llength $tags]} {incr i} {
8293 set a [lindex $tags $i]
8294 for {set j 0} {$j < $i} {incr j} {
8295 set b [lindex $tags $j]
8296 set r [anc_or_desc $a $b]
8297 if {$r == -1} {
8298 set tags [lreplace $tags $j $j]
8299 incr j -1
8300 incr i -1
8301 } elseif {$r == 1} {
8302 set tags [lreplace $tags $i $i]
8303 incr i -1
8304 break
8309 if {[array names growing] ne {}} {
8310 # graph isn't finished, need to check if any tag could get
8311 # eclipsed by another tag coming later. Simply ignore any
8312 # tags that could later get eclipsed.
8313 set ctags {}
8314 foreach t $tags {
8315 if {[is_certain $origid $t]} {
8316 lappend ctags $t
8319 if {$tags eq $ctags} {
8320 set cached_atags($origid) $tags
8321 } else {
8322 set tags $ctags
8324 } else {
8325 set cached_atags($origid) $tags
8327 set t3 [clock clicks -milliseconds]
8328 if {0 && $t3 - $t1 >= 100} {
8329 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8330 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8332 return $tags
8335 # Return the list of IDs that have heads that are descendents of id,
8336 # including id itself if it has a head.
8337 proc descheads {id} {
8338 global arcnos arcstart arcids archeads idheads cached_dheads
8339 global allparents
8341 if {![info exists allparents($id)]} {
8342 return {}
8344 set aret {}
8345 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8346 # part-way along an arc; check it first
8347 set a [lindex $arcnos($id) 0]
8348 if {$archeads($a) ne {}} {
8349 validate_archeads $a
8350 set i [lsearch -exact $arcids($a) $id]
8351 foreach t $archeads($a) {
8352 set j [lsearch -exact $arcids($a) $t]
8353 if {$j > $i} break
8354 lappend aret $t
8357 set id $arcstart($a)
8359 set origid $id
8360 set todo [list $id]
8361 set seen($id) 1
8362 set ret {}
8363 for {set i 0} {$i < [llength $todo]} {incr i} {
8364 set id [lindex $todo $i]
8365 if {[info exists cached_dheads($id)]} {
8366 set ret [concat $ret $cached_dheads($id)]
8367 } else {
8368 if {[info exists idheads($id)]} {
8369 lappend ret $id
8371 foreach a $arcnos($id) {
8372 if {$archeads($a) ne {}} {
8373 validate_archeads $a
8374 if {$archeads($a) ne {}} {
8375 set ret [concat $ret $archeads($a)]
8378 set d $arcstart($a)
8379 if {![info exists seen($d)]} {
8380 lappend todo $d
8381 set seen($d) 1
8386 set ret [lsort -unique $ret]
8387 set cached_dheads($origid) $ret
8388 return [concat $ret $aret]
8391 proc addedtag {id} {
8392 global arcnos arcout cached_dtags cached_atags
8394 if {![info exists arcnos($id)]} return
8395 if {![info exists arcout($id)]} {
8396 recalcarc [lindex $arcnos($id) 0]
8398 catch {unset cached_dtags}
8399 catch {unset cached_atags}
8402 proc addedhead {hid head} {
8403 global arcnos arcout cached_dheads
8405 if {![info exists arcnos($hid)]} return
8406 if {![info exists arcout($hid)]} {
8407 recalcarc [lindex $arcnos($hid) 0]
8409 catch {unset cached_dheads}
8412 proc removedhead {hid head} {
8413 global cached_dheads
8415 catch {unset cached_dheads}
8418 proc movedhead {hid head} {
8419 global arcnos arcout cached_dheads
8421 if {![info exists arcnos($hid)]} return
8422 if {![info exists arcout($hid)]} {
8423 recalcarc [lindex $arcnos($hid) 0]
8425 catch {unset cached_dheads}
8428 proc changedrefs {} {
8429 global cached_dheads cached_dtags cached_atags
8430 global arctags archeads arcnos arcout idheads idtags
8432 foreach id [concat [array names idheads] [array names idtags]] {
8433 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8434 set a [lindex $arcnos($id) 0]
8435 if {![info exists donearc($a)]} {
8436 recalcarc $a
8437 set donearc($a) 1
8441 catch {unset cached_dtags}
8442 catch {unset cached_atags}
8443 catch {unset cached_dheads}
8446 proc rereadrefs {} {
8447 global idtags idheads idotherrefs mainheadid
8449 set refids [concat [array names idtags] \
8450 [array names idheads] [array names idotherrefs]]
8451 foreach id $refids {
8452 if {![info exists ref($id)]} {
8453 set ref($id) [listrefs $id]
8456 set oldmainhead $mainheadid
8457 readrefs
8458 changedrefs
8459 set refids [lsort -unique [concat $refids [array names idtags] \
8460 [array names idheads] [array names idotherrefs]]]
8461 foreach id $refids {
8462 set v [listrefs $id]
8463 if {![info exists ref($id)] || $ref($id) != $v ||
8464 ($id eq $oldmainhead && $id ne $mainheadid) ||
8465 ($id eq $mainheadid && $id ne $oldmainhead)} {
8466 redrawtags $id
8469 run refill_reflist
8472 proc listrefs {id} {
8473 global idtags idheads idotherrefs
8475 set x {}
8476 if {[info exists idtags($id)]} {
8477 set x $idtags($id)
8479 set y {}
8480 if {[info exists idheads($id)]} {
8481 set y $idheads($id)
8483 set z {}
8484 if {[info exists idotherrefs($id)]} {
8485 set z $idotherrefs($id)
8487 return [list $x $y $z]
8490 proc showtag {tag isnew} {
8491 global ctext tagcontents tagids linknum tagobjid
8493 if {$isnew} {
8494 addtohistory [list showtag $tag 0]
8496 $ctext conf -state normal
8497 clear_ctext
8498 settabs 0
8499 set linknum 0
8500 if {![info exists tagcontents($tag)]} {
8501 catch {
8502 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8505 if {[info exists tagcontents($tag)]} {
8506 set text $tagcontents($tag)
8507 } else {
8508 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
8510 appendwithlinks $text {}
8511 $ctext conf -state disabled
8512 init_flist {}
8515 proc doquit {} {
8516 global stopped
8517 set stopped 100
8518 savestuff .
8519 destroy .
8522 proc mkfontdisp {font top which} {
8523 global fontattr fontpref $font
8525 set fontpref($font) [set $font]
8526 button $top.${font}but -text $which -font optionfont \
8527 -command [list choosefont $font $which]
8528 label $top.$font -relief flat -font $font \
8529 -text $fontattr($font,family) -justify left
8530 grid x $top.${font}but $top.$font -sticky w
8533 proc choosefont {font which} {
8534 global fontparam fontlist fonttop fontattr
8536 set fontparam(which) $which
8537 set fontparam(font) $font
8538 set fontparam(family) [font actual $font -family]
8539 set fontparam(size) $fontattr($font,size)
8540 set fontparam(weight) $fontattr($font,weight)
8541 set fontparam(slant) $fontattr($font,slant)
8542 set top .gitkfont
8543 set fonttop $top
8544 if {![winfo exists $top]} {
8545 font create sample
8546 eval font config sample [font actual $font]
8547 toplevel $top
8548 wm title $top [mc "Gitk font chooser"]
8549 label $top.l -textvariable fontparam(which) -font uifont
8550 pack $top.l -side top
8551 set fontlist [lsort [font families]]
8552 frame $top.f
8553 listbox $top.f.fam -listvariable fontlist \
8554 -yscrollcommand [list $top.f.sb set]
8555 bind $top.f.fam <<ListboxSelect>> selfontfam
8556 scrollbar $top.f.sb -command [list $top.f.fam yview]
8557 pack $top.f.sb -side right -fill y
8558 pack $top.f.fam -side left -fill both -expand 1
8559 pack $top.f -side top -fill both -expand 1
8560 frame $top.g
8561 spinbox $top.g.size -from 4 -to 40 -width 4 \
8562 -textvariable fontparam(size) \
8563 -validatecommand {string is integer -strict %s}
8564 checkbutton $top.g.bold -padx 5 \
8565 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8566 -variable fontparam(weight) -onvalue bold -offvalue normal
8567 checkbutton $top.g.ital -padx 5 \
8568 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8569 -variable fontparam(slant) -onvalue italic -offvalue roman
8570 pack $top.g.size $top.g.bold $top.g.ital -side left
8571 pack $top.g -side top
8572 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8573 -background white
8574 $top.c create text 100 25 -anchor center -text $which -font sample \
8575 -fill black -tags text
8576 bind $top.c <Configure> [list centertext $top.c]
8577 pack $top.c -side top -fill x
8578 frame $top.buts
8579 button $top.buts.ok -text [mc "OK"] -command fontok -default active \
8580 -font uifont
8581 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal \
8582 -font uifont
8583 grid $top.buts.ok $top.buts.can
8584 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8585 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8586 pack $top.buts -side bottom -fill x
8587 trace add variable fontparam write chg_fontparam
8588 } else {
8589 raise $top
8590 $top.c itemconf text -text $which
8592 set i [lsearch -exact $fontlist $fontparam(family)]
8593 if {$i >= 0} {
8594 $top.f.fam selection set $i
8595 $top.f.fam see $i
8599 proc centertext {w} {
8600 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8603 proc fontok {} {
8604 global fontparam fontpref prefstop
8606 set f $fontparam(font)
8607 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8608 if {$fontparam(weight) eq "bold"} {
8609 lappend fontpref($f) "bold"
8611 if {$fontparam(slant) eq "italic"} {
8612 lappend fontpref($f) "italic"
8614 set w $prefstop.$f
8615 $w conf -text $fontparam(family) -font $fontpref($f)
8617 fontcan
8620 proc fontcan {} {
8621 global fonttop fontparam
8623 if {[info exists fonttop]} {
8624 catch {destroy $fonttop}
8625 catch {font delete sample}
8626 unset fonttop
8627 unset fontparam
8631 proc selfontfam {} {
8632 global fonttop fontparam
8634 set i [$fonttop.f.fam curselection]
8635 if {$i ne {}} {
8636 set fontparam(family) [$fonttop.f.fam get $i]
8640 proc chg_fontparam {v sub op} {
8641 global fontparam
8643 font config sample -$sub $fontparam($sub)
8646 proc doprefs {} {
8647 global maxwidth maxgraphpct
8648 global oldprefs prefstop showneartags showlocalchanges
8649 global bgcolor fgcolor ctext diffcolors selectbgcolor
8650 global uifont tabstop limitdiffs
8652 set top .gitkprefs
8653 set prefstop $top
8654 if {[winfo exists $top]} {
8655 raise $top
8656 return
8658 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8659 limitdiffs tabstop} {
8660 set oldprefs($v) [set $v]
8662 toplevel $top
8663 wm title $top [mc "Gitk preferences"]
8664 label $top.ldisp -text [mc "Commit list display options"]
8665 $top.ldisp configure -font uifont
8666 grid $top.ldisp - -sticky w -pady 10
8667 label $top.spacer -text " "
8668 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8669 -font optionfont
8670 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8671 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8672 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8673 -font optionfont
8674 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8675 grid x $top.maxpctl $top.maxpct -sticky w
8676 frame $top.showlocal
8677 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8678 checkbutton $top.showlocal.b -variable showlocalchanges
8679 pack $top.showlocal.b $top.showlocal.l -side left
8680 grid x $top.showlocal -sticky w
8682 label $top.ddisp -text [mc "Diff display options"]
8683 $top.ddisp configure -font uifont
8684 grid $top.ddisp - -sticky w -pady 10
8685 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8686 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8687 grid x $top.tabstopl $top.tabstop -sticky w
8688 frame $top.ntag
8689 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8690 checkbutton $top.ntag.b -variable showneartags
8691 pack $top.ntag.b $top.ntag.l -side left
8692 grid x $top.ntag -sticky w
8693 frame $top.ldiff
8694 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8695 checkbutton $top.ldiff.b -variable limitdiffs
8696 pack $top.ldiff.b $top.ldiff.l -side left
8697 grid x $top.ldiff -sticky w
8699 label $top.cdisp -text [mc "Colors: press to choose"]
8700 $top.cdisp configure -font uifont
8701 grid $top.cdisp - -sticky w -pady 10
8702 label $top.bg -padx 40 -relief sunk -background $bgcolor
8703 button $top.bgbut -text [mc "Background"] -font optionfont \
8704 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8705 grid x $top.bgbut $top.bg -sticky w
8706 label $top.fg -padx 40 -relief sunk -background $fgcolor
8707 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8708 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8709 grid x $top.fgbut $top.fg -sticky w
8710 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8711 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8712 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8713 [list $ctext tag conf d0 -foreground]]
8714 grid x $top.diffoldbut $top.diffold -sticky w
8715 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8716 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8717 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8718 [list $ctext tag conf d1 -foreground]]
8719 grid x $top.diffnewbut $top.diffnew -sticky w
8720 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8721 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8722 -command [list choosecolor diffcolors 2 $top.hunksep \
8723 "diff hunk header" \
8724 [list $ctext tag conf hunksep -foreground]]
8725 grid x $top.hunksepbut $top.hunksep -sticky w
8726 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8727 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8728 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8729 grid x $top.selbgbut $top.selbgsep -sticky w
8731 label $top.cfont -text [mc "Fonts: press to choose"]
8732 $top.cfont configure -font uifont
8733 grid $top.cfont - -sticky w -pady 10
8734 mkfontdisp mainfont $top [mc "Main font"]
8735 mkfontdisp textfont $top [mc "Diff display font"]
8736 mkfontdisp uifont $top [mc "User interface font"]
8738 frame $top.buts
8739 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8740 $top.buts.ok configure -font uifont
8741 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8742 $top.buts.can configure -font uifont
8743 grid $top.buts.ok $top.buts.can
8744 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8745 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8746 grid $top.buts - - -pady 10 -sticky ew
8747 bind $top <Visibility> "focus $top.buts.ok"
8750 proc choosecolor {v vi w x cmd} {
8751 global $v
8753 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8754 -title [mc "Gitk: choose color for %s" $x]]
8755 if {$c eq {}} return
8756 $w conf -background $c
8757 lset $v $vi $c
8758 eval $cmd $c
8761 proc setselbg {c} {
8762 global bglist cflist
8763 foreach w $bglist {
8764 $w configure -selectbackground $c
8766 $cflist tag configure highlight \
8767 -background [$cflist cget -selectbackground]
8768 allcanvs itemconf secsel -fill $c
8771 proc setbg {c} {
8772 global bglist
8774 foreach w $bglist {
8775 $w conf -background $c
8779 proc setfg {c} {
8780 global fglist canv
8782 foreach w $fglist {
8783 $w conf -foreground $c
8785 allcanvs itemconf text -fill $c
8786 $canv itemconf circle -outline $c
8789 proc prefscan {} {
8790 global oldprefs prefstop
8792 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8793 limitdiffs tabstop} {
8794 global $v
8795 set $v $oldprefs($v)
8797 catch {destroy $prefstop}
8798 unset prefstop
8799 fontcan
8802 proc prefsok {} {
8803 global maxwidth maxgraphpct
8804 global oldprefs prefstop showneartags showlocalchanges
8805 global fontpref mainfont textfont uifont
8806 global limitdiffs treediffs
8808 catch {destroy $prefstop}
8809 unset prefstop
8810 fontcan
8811 set fontchanged 0
8812 if {$mainfont ne $fontpref(mainfont)} {
8813 set mainfont $fontpref(mainfont)
8814 parsefont mainfont $mainfont
8815 eval font configure mainfont [fontflags mainfont]
8816 eval font configure mainfontbold [fontflags mainfont 1]
8817 setcoords
8818 set fontchanged 1
8820 if {$textfont ne $fontpref(textfont)} {
8821 set textfont $fontpref(textfont)
8822 parsefont textfont $textfont
8823 eval font configure textfont [fontflags textfont]
8824 eval font configure textfontbold [fontflags textfont 1]
8826 if {$uifont ne $fontpref(uifont)} {
8827 set uifont $fontpref(uifont)
8828 parsefont uifont $uifont
8829 eval font configure uifont [fontflags uifont]
8831 settabs
8832 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8833 if {$showlocalchanges} {
8834 doshowlocalchanges
8835 } else {
8836 dohidelocalchanges
8839 if {$limitdiffs != $oldprefs(limitdiffs)} {
8840 # treediffs elements are limited by path
8841 catch {unset treediffs}
8843 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8844 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8845 redisplay
8846 } elseif {$showneartags != $oldprefs(showneartags) ||
8847 $limitdiffs != $oldprefs(limitdiffs)} {
8848 reselectline
8852 proc formatdate {d} {
8853 global datetimeformat
8854 if {$d ne {}} {
8855 set d [clock format $d -format $datetimeformat]
8857 return $d
8860 # This list of encoding names and aliases is distilled from
8861 # http://www.iana.org/assignments/character-sets.
8862 # Not all of them are supported by Tcl.
8863 set encoding_aliases {
8864 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8865 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8866 { ISO-10646-UTF-1 csISO10646UTF1 }
8867 { ISO_646.basic:1983 ref csISO646basic1983 }
8868 { INVARIANT csINVARIANT }
8869 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8870 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8871 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8872 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8873 { NATS-DANO iso-ir-9-1 csNATSDANO }
8874 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8875 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8876 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8877 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8878 { ISO-2022-KR csISO2022KR }
8879 { EUC-KR csEUCKR }
8880 { ISO-2022-JP csISO2022JP }
8881 { ISO-2022-JP-2 csISO2022JP2 }
8882 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8883 csISO13JISC6220jp }
8884 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8885 { IT iso-ir-15 ISO646-IT csISO15Italian }
8886 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8887 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8888 { greek7-old iso-ir-18 csISO18Greek7Old }
8889 { latin-greek iso-ir-19 csISO19LatinGreek }
8890 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8891 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8892 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8893 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8894 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8895 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8896 { INIS iso-ir-49 csISO49INIS }
8897 { INIS-8 iso-ir-50 csISO50INIS8 }
8898 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8899 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8900 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8901 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8902 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8903 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8904 csISO60Norwegian1 }
8905 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8906 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8907 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8908 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8909 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8910 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8911 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8912 { greek7 iso-ir-88 csISO88Greek7 }
8913 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8914 { iso-ir-90 csISO90 }
8915 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8916 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8917 csISO92JISC62991984b }
8918 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8919 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8920 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8921 csISO95JIS62291984handadd }
8922 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8923 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8924 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8925 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8926 CP819 csISOLatin1 }
8927 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8928 { T.61-7bit iso-ir-102 csISO102T617bit }
8929 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8930 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8931 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8932 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8933 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8934 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8935 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8936 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8937 arabic csISOLatinArabic }
8938 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8939 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8940 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8941 greek greek8 csISOLatinGreek }
8942 { T.101-G2 iso-ir-128 csISO128T101G2 }
8943 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8944 csISOLatinHebrew }
8945 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8946 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8947 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8948 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8949 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8950 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8951 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8952 csISOLatinCyrillic }
8953 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8954 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8955 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8956 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8957 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8958 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8959 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8960 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8961 { ISO_10367-box iso-ir-155 csISO10367Box }
8962 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8963 { latin-lap lap iso-ir-158 csISO158Lap }
8964 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8965 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8966 { us-dk csUSDK }
8967 { dk-us csDKUS }
8968 { JIS_X0201 X0201 csHalfWidthKatakana }
8969 { KSC5636 ISO646-KR csKSC5636 }
8970 { ISO-10646-UCS-2 csUnicode }
8971 { ISO-10646-UCS-4 csUCS4 }
8972 { DEC-MCS dec csDECMCS }
8973 { hp-roman8 roman8 r8 csHPRoman8 }
8974 { macintosh mac csMacintosh }
8975 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8976 csIBM037 }
8977 { IBM038 EBCDIC-INT cp038 csIBM038 }
8978 { IBM273 CP273 csIBM273 }
8979 { IBM274 EBCDIC-BE CP274 csIBM274 }
8980 { IBM275 EBCDIC-BR cp275 csIBM275 }
8981 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8982 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8983 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8984 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8985 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8986 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8987 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8988 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8989 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8990 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8991 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8992 { IBM437 cp437 437 csPC8CodePage437 }
8993 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8994 { IBM775 cp775 csPC775Baltic }
8995 { IBM850 cp850 850 csPC850Multilingual }
8996 { IBM851 cp851 851 csIBM851 }
8997 { IBM852 cp852 852 csPCp852 }
8998 { IBM855 cp855 855 csIBM855 }
8999 { IBM857 cp857 857 csIBM857 }
9000 { IBM860 cp860 860 csIBM860 }
9001 { IBM861 cp861 861 cp-is csIBM861 }
9002 { IBM862 cp862 862 csPC862LatinHebrew }
9003 { IBM863 cp863 863 csIBM863 }
9004 { IBM864 cp864 csIBM864 }
9005 { IBM865 cp865 865 csIBM865 }
9006 { IBM866 cp866 866 csIBM866 }
9007 { IBM868 CP868 cp-ar csIBM868 }
9008 { IBM869 cp869 869 cp-gr csIBM869 }
9009 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9010 { IBM871 CP871 ebcdic-cp-is csIBM871 }
9011 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9012 { IBM891 cp891 csIBM891 }
9013 { IBM903 cp903 csIBM903 }
9014 { IBM904 cp904 904 csIBBM904 }
9015 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9016 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9017 { IBM1026 CP1026 csIBM1026 }
9018 { EBCDIC-AT-DE csIBMEBCDICATDE }
9019 { EBCDIC-AT-DE-A csEBCDICATDEA }
9020 { EBCDIC-CA-FR csEBCDICCAFR }
9021 { EBCDIC-DK-NO csEBCDICDKNO }
9022 { EBCDIC-DK-NO-A csEBCDICDKNOA }
9023 { EBCDIC-FI-SE csEBCDICFISE }
9024 { EBCDIC-FI-SE-A csEBCDICFISEA }
9025 { EBCDIC-FR csEBCDICFR }
9026 { EBCDIC-IT csEBCDICIT }
9027 { EBCDIC-PT csEBCDICPT }
9028 { EBCDIC-ES csEBCDICES }
9029 { EBCDIC-ES-A csEBCDICESA }
9030 { EBCDIC-ES-S csEBCDICESS }
9031 { EBCDIC-UK csEBCDICUK }
9032 { EBCDIC-US csEBCDICUS }
9033 { UNKNOWN-8BIT csUnknown8BiT }
9034 { MNEMONIC csMnemonic }
9035 { MNEM csMnem }
9036 { VISCII csVISCII }
9037 { VIQR csVIQR }
9038 { KOI8-R csKOI8R }
9039 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9040 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9041 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9042 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9043 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9044 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9045 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9046 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9047 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9048 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9049 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9050 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9051 { IBM1047 IBM-1047 }
9052 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9053 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9054 { UNICODE-1-1 csUnicode11 }
9055 { CESU-8 csCESU-8 }
9056 { BOCU-1 csBOCU-1 }
9057 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9058 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9059 l8 }
9060 { ISO-8859-15 ISO_8859-15 Latin-9 }
9061 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9062 { GBK CP936 MS936 windows-936 }
9063 { JIS_Encoding csJISEncoding }
9064 { Shift_JIS MS_Kanji csShiftJIS }
9065 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9066 EUC-JP }
9067 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9068 { ISO-10646-UCS-Basic csUnicodeASCII }
9069 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9070 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9071 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9072 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9073 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9074 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9075 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9076 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9077 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9078 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9079 { Adobe-Standard-Encoding csAdobeStandardEncoding }
9080 { Ventura-US csVenturaUS }
9081 { Ventura-International csVenturaInternational }
9082 { PC8-Danish-Norwegian csPC8DanishNorwegian }
9083 { PC8-Turkish csPC8Turkish }
9084 { IBM-Symbols csIBMSymbols }
9085 { IBM-Thai csIBMThai }
9086 { HP-Legal csHPLegal }
9087 { HP-Pi-font csHPPiFont }
9088 { HP-Math8 csHPMath8 }
9089 { Adobe-Symbol-Encoding csHPPSMath }
9090 { HP-DeskTop csHPDesktop }
9091 { Ventura-Math csVenturaMath }
9092 { Microsoft-Publishing csMicrosoftPublishing }
9093 { Windows-31J csWindows31J }
9094 { GB2312 csGB2312 }
9095 { Big5 csBig5 }
9098 proc tcl_encoding {enc} {
9099 global encoding_aliases
9100 set names [encoding names]
9101 set lcnames [string tolower $names]
9102 set enc [string tolower $enc]
9103 set i [lsearch -exact $lcnames $enc]
9104 if {$i < 0} {
9105 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9106 if {[regsub {^iso[-_]} $enc iso encx]} {
9107 set i [lsearch -exact $lcnames $encx]
9110 if {$i < 0} {
9111 foreach l $encoding_aliases {
9112 set ll [string tolower $l]
9113 if {[lsearch -exact $ll $enc] < 0} continue
9114 # look through the aliases for one that tcl knows about
9115 foreach e $ll {
9116 set i [lsearch -exact $lcnames $e]
9117 if {$i < 0} {
9118 if {[regsub {^iso[-_]} $e iso ex]} {
9119 set i [lsearch -exact $lcnames $ex]
9122 if {$i >= 0} break
9124 break
9127 if {$i >= 0} {
9128 return [lindex $names $i]
9130 return {}
9133 # First check that Tcl/Tk is recent enough
9134 if {[catch {package require Tk 8.4} err]} {
9135 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9136 Gitk requires at least Tcl/Tk 8.4."]
9137 exit 1
9140 # defaults...
9141 set datemode 0
9142 set wrcomcmd "git diff-tree --stdin -p --pretty"
9144 set gitencoding {}
9145 catch {
9146 set gitencoding [exec git config --get i18n.commitencoding]
9148 if {$gitencoding == ""} {
9149 set gitencoding "utf-8"
9151 set tclencoding [tcl_encoding $gitencoding]
9152 if {$tclencoding == {}} {
9153 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9156 set mainfont {Helvetica 9}
9157 set textfont {Courier 9}
9158 set uifont {Helvetica 9 bold}
9159 set tabstop 8
9160 set findmergefiles 0
9161 set maxgraphpct 50
9162 set maxwidth 16
9163 set revlistorder 0
9164 set fastdate 0
9165 set uparrowlen 5
9166 set downarrowlen 5
9167 set mingaplen 100
9168 set cmitmode "patch"
9169 set wrapcomment "none"
9170 set showneartags 1
9171 set maxrefs 20
9172 set maxlinelen 200
9173 set showlocalchanges 1
9174 set limitdiffs 1
9175 set datetimeformat "%Y-%m-%d %H:%M:%S"
9177 set colors {green red blue magenta darkgrey brown orange}
9178 set bgcolor white
9179 set fgcolor black
9180 set diffcolors {red "#00a000" blue}
9181 set diffcontext 3
9182 set selectbgcolor gray85
9184 ## For msgcat loading, first locate the installation location.
9185 if { [info exists ::env(GITK_MSGSDIR)] } {
9186 ## Msgsdir was manually set in the environment.
9187 set gitk_msgsdir $::env(GITK_MSGSDIR)
9188 } else {
9189 ## Let's guess the prefix from argv0.
9190 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9191 set gitk_libdir [file join $gitk_prefix share gitk lib]
9192 set gitk_msgsdir [file join $gitk_libdir msgs]
9193 unset gitk_prefix
9196 ## Internationalization (i18n) through msgcat and gettext. See
9197 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9198 package require msgcat
9199 namespace import ::msgcat::mc
9200 ## And eventually load the actual message catalog
9201 ::msgcat::mcload $gitk_msgsdir
9203 catch {source ~/.gitk}
9205 font create optionfont -family sans-serif -size -12
9207 parsefont mainfont $mainfont
9208 eval font create mainfont [fontflags mainfont]
9209 eval font create mainfontbold [fontflags mainfont 1]
9211 parsefont textfont $textfont
9212 eval font create textfont [fontflags textfont]
9213 eval font create textfontbold [fontflags textfont 1]
9215 parsefont uifont $uifont
9216 eval font create uifont [fontflags uifont]
9218 # check that we can find a .git directory somewhere...
9219 if {[catch {set gitdir [gitdir]}]} {
9220 show_error {} . [mc "Cannot find a git repository here."]
9221 exit 1
9223 if {![file isdirectory $gitdir]} {
9224 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9225 exit 1
9228 set mergeonly 0
9229 set revtreeargs {}
9230 set cmdline_files {}
9231 set i 0
9232 foreach arg $argv {
9233 switch -- $arg {
9234 "" { }
9235 "-d" { set datemode 1 }
9236 "--merge" {
9237 set mergeonly 1
9238 lappend revtreeargs $arg
9240 "--" {
9241 set cmdline_files [lrange $argv [expr {$i + 1}] end]
9242 break
9244 default {
9245 lappend revtreeargs $arg
9248 incr i
9251 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9252 # no -- on command line, but some arguments (other than -d)
9253 if {[catch {
9254 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9255 set cmdline_files [split $f "\n"]
9256 set n [llength $cmdline_files]
9257 set revtreeargs [lrange $revtreeargs 0 end-$n]
9258 # Unfortunately git rev-parse doesn't produce an error when
9259 # something is both a revision and a filename. To be consistent
9260 # with git log and git rev-list, check revtreeargs for filenames.
9261 foreach arg $revtreeargs {
9262 if {[file exists $arg]} {
9263 show_error {} . [mc "Ambiguous argument '%s': both revision\
9264 and filename" $arg]
9265 exit 1
9268 } err]} {
9269 # unfortunately we get both stdout and stderr in $err,
9270 # so look for "fatal:".
9271 set i [string first "fatal:" $err]
9272 if {$i > 0} {
9273 set err [string range $err [expr {$i + 6}] end]
9275 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9276 exit 1
9280 if {$mergeonly} {
9281 # find the list of unmerged files
9282 set mlist {}
9283 set nr_unmerged 0
9284 if {[catch {
9285 set fd [open "| git ls-files -u" r]
9286 } err]} {
9287 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9288 exit 1
9290 while {[gets $fd line] >= 0} {
9291 set i [string first "\t" $line]
9292 if {$i < 0} continue
9293 set fname [string range $line [expr {$i+1}] end]
9294 if {[lsearch -exact $mlist $fname] >= 0} continue
9295 incr nr_unmerged
9296 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9297 lappend mlist $fname
9300 catch {close $fd}
9301 if {$mlist eq {}} {
9302 if {$nr_unmerged == 0} {
9303 show_error {} . [mc "No files selected: --merge specified but\
9304 no files are unmerged."]
9305 } else {
9306 show_error {} . [mc "No files selected: --merge specified but\
9307 no unmerged files are within file limit."]
9309 exit 1
9311 set cmdline_files $mlist
9314 set nullid "0000000000000000000000000000000000000000"
9315 set nullid2 "0000000000000000000000000000000000000001"
9317 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9319 set runq {}
9320 set history {}
9321 set historyindex 0
9322 set fh_serial 0
9323 set nhl_names {}
9324 set highlight_paths {}
9325 set findpattern {}
9326 set searchdirn -forwards
9327 set boldrows {}
9328 set boldnamerows {}
9329 set diffelide {0 0}
9330 set markingmatches 0
9331 set linkentercount 0
9332 set need_redisplay 0
9333 set nrows_drawn 0
9334 set firsttabstop 0
9336 set nextviewnum 1
9337 set curview 0
9338 set selectedview 0
9339 set selectedhlview [mc "None"]
9340 set highlight_related [mc "None"]
9341 set highlight_files {}
9342 set viewfiles(0) {}
9343 set viewperm(0) 0
9344 set viewargs(0) {}
9346 set loginstance 0
9347 set cmdlineok 0
9348 set stopped 0
9349 set stuffsaved 0
9350 set patchnum 0
9351 set lserial 0
9352 setcoords
9353 makewindow
9354 # wait for the window to become visible
9355 tkwait visibility .
9356 wm title . "[file tail $argv0]: [file tail [pwd]]"
9357 readrefs
9359 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9360 # create a view for the files/dirs specified on the command line
9361 set curview 1
9362 set selectedview 1
9363 set nextviewnum 2
9364 set viewname(1) [mc "Command line"]
9365 set viewfiles(1) $cmdline_files
9366 set viewargs(1) $revtreeargs
9367 set viewperm(1) 0
9368 addviewmenu 1
9369 .bar.view entryconf [mc "Edit view..."] -state normal
9370 .bar.view entryconf [mc "Delete view"] -state normal
9373 if {[info exists permviews]} {
9374 foreach v $permviews {
9375 set n $nextviewnum
9376 incr nextviewnum
9377 set viewname($n) [lindex $v 0]
9378 set viewfiles($n) [lindex $v 1]
9379 set viewargs($n) [lindex $v 2]
9380 set viewperm($n) 1
9381 addviewmenu $n
9384 getcommits