Code

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