Code

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