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