Code

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