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