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