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