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