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