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