Code

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