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