Code

gitk: Fix some corner cases in the targetid/targetrow stuff
[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
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     set found 0
4990     set domore 1
4991     set ai [bsearch $vrownum($curview) $l]
4992     set a [lindex $varcorder($curview) $ai]
4993     set arow [lindex $vrownum($curview) $ai]
4994     set ids [lindex $varccommits($curview,$a)]
4995     set arowend [expr {$arow + [llength $ids]}]
4996     if {$gdttype eq [mc "containing:"]} {
4997         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4998             if {$l < $arow || $l >= $arowend} {
4999                 incr ai $find_dirn
5000                 set a [lindex $varcorder($curview) $ai]
5001                 set arow [lindex $vrownum($curview) $ai]
5002                 set ids [lindex $varccommits($curview,$a)]
5003                 set arowend [expr {$arow + [llength $ids]}]
5004             }
5005             set id [lindex $ids [expr {$l - $arow}]]
5006             # shouldn't happen unless git log doesn't give all the commits...
5007             if {![info exists commitdata($id)] ||
5008                 ![doesmatch $commitdata($id)]} {
5009                 continue
5010             }
5011             if {![info exists commitinfo($id)]} {
5012                 getcommit $id
5013             }
5014             set info $commitinfo($id)
5015             foreach f $info ty $fldtypes {
5016                 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5017                     [doesmatch $f]} {
5018                     set found 1
5019                     break
5020                 }
5021             }
5022             if {$found} break
5023         }
5024     } else {
5025         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5026             if {$l < $arow || $l >= $arowend} {
5027                 incr ai $find_dirn
5028                 set a [lindex $varcorder($curview) $ai]
5029                 set arow [lindex $vrownum($curview) $ai]
5030                 set ids [lindex $varccommits($curview,$a)]
5031                 set arowend [expr {$arow + [llength $ids]}]
5032             }
5033             set id [lindex $ids [expr {$l - $arow}]]
5034             if {![info exists fhighlights($l)]} {
5035                 askfilehighlight $l $id
5036                 if {$domore} {
5037                     set domore 0
5038                     set findcurline [expr {$l - $find_dirn}]
5039                 }
5040             } elseif {$fhighlights($l)} {
5041                 set found $domore
5042                 break
5043             }
5044         }
5045     }
5046     if {$found || ($domore && !$moretodo)} {
5047         unset findcurline
5048         unset find_dirn
5049         notbusy finding
5050         set fprogcoord 0
5051         adjustprogress
5052         if {$found} {
5053             findselectline $l
5054         } else {
5055             bell
5056         }
5057         return 0
5058     }
5059     if {!$domore} {
5060         flushhighlights
5061     } else {
5062         set findcurline [expr {$l - $find_dirn}]
5063     }
5064     set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5065     if {$n < 0} {
5066         incr n $numcommits
5067     }
5068     set fprogcoord [expr {$n * 1.0 / $numcommits}]
5069     adjustprogress
5070     return $domore
5073 proc findselectline {l} {
5074     global findloc commentend ctext findcurline markingmatches gdttype
5076     set markingmatches 1
5077     set findcurline $l
5078     selectline $l 1
5079     if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5080         # highlight the matches in the comments
5081         set f [$ctext get 1.0 $commentend]
5082         set matches [findmatches $f]
5083         foreach match $matches {
5084             set start [lindex $match 0]
5085             set end [expr {[lindex $match 1] + 1}]
5086             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5087         }
5088     }
5089     drawvisible
5092 # mark the bits of a headline or author that match a find string
5093 proc markmatches {canv l str tag matches font row} {
5094     global selectedline
5096     set bbox [$canv bbox $tag]
5097     set x0 [lindex $bbox 0]
5098     set y0 [lindex $bbox 1]
5099     set y1 [lindex $bbox 3]
5100     foreach match $matches {
5101         set start [lindex $match 0]
5102         set end [lindex $match 1]
5103         if {$start > $end} continue
5104         set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5105         set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5106         set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5107                    [expr {$x0+$xlen+2}] $y1 \
5108                    -outline {} -tags [list match$l matches] -fill yellow]
5109         $canv lower $t
5110         if {[info exists selectedline] && $row == $selectedline} {
5111             $canv raise $t secsel
5112         }
5113     }
5116 proc unmarkmatches {} {
5117     global markingmatches
5119     allcanvs delete matches
5120     set markingmatches 0
5121     stopfinding
5124 proc selcanvline {w x y} {
5125     global canv canvy0 ctext linespc
5126     global rowtextx
5127     set ymax [lindex [$canv cget -scrollregion] 3]
5128     if {$ymax == {}} return
5129     set yfrac [lindex [$canv yview] 0]
5130     set y [expr {$y + $yfrac * $ymax}]
5131     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5132     if {$l < 0} {
5133         set l 0
5134     }
5135     if {$w eq $canv} {
5136         set xmax [lindex [$canv cget -scrollregion] 2]
5137         set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5138         if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5139     }
5140     unmarkmatches
5141     selectline $l 1
5144 proc commit_descriptor {p} {
5145     global commitinfo
5146     if {![info exists commitinfo($p)]} {
5147         getcommit $p
5148     }
5149     set l "..."
5150     if {[llength $commitinfo($p)] > 1} {
5151         set l [lindex $commitinfo($p) 0]
5152     }
5153     return "$p ($l)\n"
5156 # append some text to the ctext widget, and make any SHA1 ID
5157 # that we know about be a clickable link.
5158 proc appendwithlinks {text tags} {
5159     global ctext linknum curview pendinglinks
5161     set start [$ctext index "end - 1c"]
5162     $ctext insert end $text $tags
5163     set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5164     foreach l $links {
5165         set s [lindex $l 0]
5166         set e [lindex $l 1]
5167         set linkid [string range $text $s $e]
5168         incr e
5169         $ctext tag delete link$linknum
5170         $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5171         setlink $linkid link$linknum
5172         incr linknum
5173     }
5176 proc setlink {id lk} {
5177     global curview ctext pendinglinks commitinterest
5179     if {[commitinview $id $curview]} {
5180         $ctext tag conf $lk -foreground blue -underline 1
5181         $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5182         $ctext tag bind $lk <Enter> {linkcursor %W 1}
5183         $ctext tag bind $lk <Leave> {linkcursor %W -1}
5184     } else {
5185         lappend pendinglinks($id) $lk
5186         lappend commitinterest($id) {makelink %I}
5187     }
5190 proc makelink {id} {
5191     global pendinglinks
5193     if {![info exists pendinglinks($id)]} return
5194     foreach lk $pendinglinks($id) {
5195         setlink $id $lk
5196     }
5197     unset pendinglinks($id)
5200 proc linkcursor {w inc} {
5201     global linkentercount curtextcursor
5203     if {[incr linkentercount $inc] > 0} {
5204         $w configure -cursor hand2
5205     } else {
5206         $w configure -cursor $curtextcursor
5207         if {$linkentercount < 0} {
5208             set linkentercount 0
5209         }
5210     }
5213 proc viewnextline {dir} {
5214     global canv linespc
5216     $canv delete hover
5217     set ymax [lindex [$canv cget -scrollregion] 3]
5218     set wnow [$canv yview]
5219     set wtop [expr {[lindex $wnow 0] * $ymax}]
5220     set newtop [expr {$wtop + $dir * $linespc}]
5221     if {$newtop < 0} {
5222         set newtop 0
5223     } elseif {$newtop > $ymax} {
5224         set newtop $ymax
5225     }
5226     allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5229 # add a list of tag or branch names at position pos
5230 # returns the number of names inserted
5231 proc appendrefs {pos ids var} {
5232     global ctext linknum curview $var maxrefs
5234     if {[catch {$ctext index $pos}]} {
5235         return 0
5236     }
5237     $ctext conf -state normal
5238     $ctext delete $pos "$pos lineend"
5239     set tags {}
5240     foreach id $ids {
5241         foreach tag [set $var\($id\)] {
5242             lappend tags [list $tag $id]
5243         }
5244     }
5245     if {[llength $tags] > $maxrefs} {
5246         $ctext insert $pos "many ([llength $tags])"
5247     } else {
5248         set tags [lsort -index 0 -decreasing $tags]
5249         set sep {}
5250         foreach ti $tags {
5251             set id [lindex $ti 1]
5252             set lk link$linknum
5253             incr linknum
5254             $ctext tag delete $lk
5255             $ctext insert $pos $sep
5256             $ctext insert $pos [lindex $ti 0] $lk
5257             setlink $id $lk
5258             set sep ", "
5259         }
5260     }
5261     $ctext conf -state disabled
5262     return [llength $tags]
5265 # called when we have finished computing the nearby tags
5266 proc dispneartags {delay} {
5267     global selectedline currentid showneartags tagphase
5269     if {![info exists selectedline] || !$showneartags} return
5270     after cancel dispnexttag
5271     if {$delay} {
5272         after 200 dispnexttag
5273         set tagphase -1
5274     } else {
5275         after idle dispnexttag
5276         set tagphase 0
5277     }
5280 proc dispnexttag {} {
5281     global selectedline currentid showneartags tagphase ctext
5283     if {![info exists selectedline] || !$showneartags} return
5284     switch -- $tagphase {
5285         0 {
5286             set dtags [desctags $currentid]
5287             if {$dtags ne {}} {
5288                 appendrefs precedes $dtags idtags
5289             }
5290         }
5291         1 {
5292             set atags [anctags $currentid]
5293             if {$atags ne {}} {
5294                 appendrefs follows $atags idtags
5295             }
5296         }
5297         2 {
5298             set dheads [descheads $currentid]
5299             if {$dheads ne {}} {
5300                 if {[appendrefs branch $dheads idheads] > 1
5301                     && [$ctext get "branch -3c"] eq "h"} {
5302                     # turn "Branch" into "Branches"
5303                     $ctext conf -state normal
5304                     $ctext insert "branch -2c" "es"
5305                     $ctext conf -state disabled
5306                 }
5307             }
5308         }
5309     }
5310     if {[incr tagphase] <= 2} {
5311         after idle dispnexttag
5312     }
5315 proc make_secsel {l} {
5316     global linehtag linentag linedtag canv canv2 canv3
5318     if {![info exists linehtag($l)]} return
5319     $canv delete secsel
5320     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5321                -tags secsel -fill [$canv cget -selectbackground]]
5322     $canv lower $t
5323     $canv2 delete secsel
5324     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5325                -tags secsel -fill [$canv2 cget -selectbackground]]
5326     $canv2 lower $t
5327     $canv3 delete secsel
5328     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5329                -tags secsel -fill [$canv3 cget -selectbackground]]
5330     $canv3 lower $t
5333 proc selectline {l isnew} {
5334     global canv ctext commitinfo selectedline
5335     global canvy0 linespc parents children curview
5336     global currentid sha1entry
5337     global commentend idtags linknum
5338     global mergemax numcommits pending_select
5339     global cmitmode showneartags allcommits
5341     catch {unset pending_select}
5342     $canv delete hover
5343     normalline
5344     unsel_reflist
5345     stopfinding
5346     if {$l < 0 || $l >= $numcommits} return
5347     set y [expr {$canvy0 + $l * $linespc}]
5348     set ymax [lindex [$canv cget -scrollregion] 3]
5349     set ytop [expr {$y - $linespc - 1}]
5350     set ybot [expr {$y + $linespc + 1}]
5351     set wnow [$canv yview]
5352     set wtop [expr {[lindex $wnow 0] * $ymax}]
5353     set wbot [expr {[lindex $wnow 1] * $ymax}]
5354     set wh [expr {$wbot - $wtop}]
5355     set newtop $wtop
5356     if {$ytop < $wtop} {
5357         if {$ybot < $wtop} {
5358             set newtop [expr {$y - $wh / 2.0}]
5359         } else {
5360             set newtop $ytop
5361             if {$newtop > $wtop - $linespc} {
5362                 set newtop [expr {$wtop - $linespc}]
5363             }
5364         }
5365     } elseif {$ybot > $wbot} {
5366         if {$ytop > $wbot} {
5367             set newtop [expr {$y - $wh / 2.0}]
5368         } else {
5369             set newtop [expr {$ybot - $wh}]
5370             if {$newtop < $wtop + $linespc} {
5371                 set newtop [expr {$wtop + $linespc}]
5372             }
5373         }
5374     }
5375     if {$newtop != $wtop} {
5376         if {$newtop < 0} {
5377             set newtop 0
5378         }
5379         allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5380         drawvisible
5381     }
5383     make_secsel $l
5385     set id [commitonrow $l]
5386     if {$isnew} {
5387         addtohistory [list selbyid $id]
5388     }
5390     set selectedline $l
5391     set currentid $id
5392     $sha1entry delete 0 end
5393     $sha1entry insert 0 $id
5394     $sha1entry selection from 0
5395     $sha1entry selection to end
5396     rhighlight_sel $id
5398     $ctext conf -state normal
5399     clear_ctext
5400     set linknum 0
5401     set info $commitinfo($id)
5402     set date [formatdate [lindex $info 2]]
5403     $ctext insert end "[mc "Author"]: [lindex $info 1]  $date\n"
5404     set date [formatdate [lindex $info 4]]
5405     $ctext insert end "[mc "Committer"]: [lindex $info 3]  $date\n"
5406     if {[info exists idtags($id)]} {
5407         $ctext insert end [mc "Tags:"]
5408         foreach tag $idtags($id) {
5409             $ctext insert end " $tag"
5410         }
5411         $ctext insert end "\n"
5412     }
5414     set headers {}
5415     set olds $parents($curview,$id)
5416     if {[llength $olds] > 1} {
5417         set np 0
5418         foreach p $olds {
5419             if {$np >= $mergemax} {
5420                 set tag mmax
5421             } else {
5422                 set tag m$np
5423             }
5424             $ctext insert end "[mc "Parent"]: " $tag
5425             appendwithlinks [commit_descriptor $p] {}
5426             incr np
5427         }
5428     } else {
5429         foreach p $olds {
5430             append headers "[mc "Parent"]: [commit_descriptor $p]"
5431         }
5432     }
5434     foreach c $children($curview,$id) {
5435         append headers "[mc "Child"]:  [commit_descriptor $c]"
5436     }
5438     # make anything that looks like a SHA1 ID be a clickable link
5439     appendwithlinks $headers {}
5440     if {$showneartags} {
5441         if {![info exists allcommits]} {
5442             getallcommits
5443         }
5444         $ctext insert end "[mc "Branch"]: "
5445         $ctext mark set branch "end -1c"
5446         $ctext mark gravity branch left
5447         $ctext insert end "\n[mc "Follows"]: "
5448         $ctext mark set follows "end -1c"
5449         $ctext mark gravity follows left
5450         $ctext insert end "\n[mc "Precedes"]: "
5451         $ctext mark set precedes "end -1c"
5452         $ctext mark gravity precedes left
5453         $ctext insert end "\n"
5454         dispneartags 1
5455     }
5456     $ctext insert end "\n"
5457     set comment [lindex $info 5]
5458     if {[string first "\r" $comment] >= 0} {
5459         set comment [string map {"\r" "\n    "} $comment]
5460     }
5461     appendwithlinks $comment {comment}
5463     $ctext tag remove found 1.0 end
5464     $ctext conf -state disabled
5465     set commentend [$ctext index "end - 1c"]
5467     init_flist [mc "Comments"]
5468     if {$cmitmode eq "tree"} {
5469         gettree $id
5470     } elseif {[llength $olds] <= 1} {
5471         startdiff $id
5472     } else {
5473         mergediff $id
5474     }
5477 proc selfirstline {} {
5478     unmarkmatches
5479     selectline 0 1
5482 proc sellastline {} {
5483     global numcommits
5484     unmarkmatches
5485     set l [expr {$numcommits - 1}]
5486     selectline $l 1
5489 proc selnextline {dir} {
5490     global selectedline
5491     focus .
5492     if {![info exists selectedline]} return
5493     set l [expr {$selectedline + $dir}]
5494     unmarkmatches
5495     selectline $l 1
5498 proc selnextpage {dir} {
5499     global canv linespc selectedline numcommits
5501     set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5502     if {$lpp < 1} {
5503         set lpp 1
5504     }
5505     allcanvs yview scroll [expr {$dir * $lpp}] units
5506     drawvisible
5507     if {![info exists selectedline]} return
5508     set l [expr {$selectedline + $dir * $lpp}]
5509     if {$l < 0} {
5510         set l 0
5511     } elseif {$l >= $numcommits} {
5512         set l [expr $numcommits - 1]
5513     }
5514     unmarkmatches
5515     selectline $l 1
5518 proc unselectline {} {
5519     global selectedline currentid
5521     catch {unset selectedline}
5522     catch {unset currentid}
5523     allcanvs delete secsel
5524     rhighlight_none
5527 proc reselectline {} {
5528     global selectedline
5530     if {[info exists selectedline]} {
5531         selectline $selectedline 0
5532     }
5535 proc addtohistory {cmd} {
5536     global history historyindex curview
5538     set elt [list $curview $cmd]
5539     if {$historyindex > 0
5540         && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5541         return
5542     }
5544     if {$historyindex < [llength $history]} {
5545         set history [lreplace $history $historyindex end $elt]
5546     } else {
5547         lappend history $elt
5548     }
5549     incr historyindex
5550     if {$historyindex > 1} {
5551         .tf.bar.leftbut conf -state normal
5552     } else {
5553         .tf.bar.leftbut conf -state disabled
5554     }
5555     .tf.bar.rightbut conf -state disabled
5558 proc godo {elt} {
5559     global curview
5561     set view [lindex $elt 0]
5562     set cmd [lindex $elt 1]
5563     if {$curview != $view} {
5564         showview $view
5565     }
5566     eval $cmd
5569 proc goback {} {
5570     global history historyindex
5571     focus .
5573     if {$historyindex > 1} {
5574         incr historyindex -1
5575         godo [lindex $history [expr {$historyindex - 1}]]
5576         .tf.bar.rightbut conf -state normal
5577     }
5578     if {$historyindex <= 1} {
5579         .tf.bar.leftbut conf -state disabled
5580     }
5583 proc goforw {} {
5584     global history historyindex
5585     focus .
5587     if {$historyindex < [llength $history]} {
5588         set cmd [lindex $history $historyindex]
5589         incr historyindex
5590         godo $cmd
5591         .tf.bar.leftbut conf -state normal
5592     }
5593     if {$historyindex >= [llength $history]} {
5594         .tf.bar.rightbut conf -state disabled
5595     }
5598 proc gettree {id} {
5599     global treefilelist treeidlist diffids diffmergeid treepending
5600     global nullid nullid2
5602     set diffids $id
5603     catch {unset diffmergeid}
5604     if {![info exists treefilelist($id)]} {
5605         if {![info exists treepending]} {
5606             if {$id eq $nullid} {
5607                 set cmd [list | git ls-files]
5608             } elseif {$id eq $nullid2} {
5609                 set cmd [list | git ls-files --stage -t]
5610             } else {
5611                 set cmd [list | git ls-tree -r $id]
5612             }
5613             if {[catch {set gtf [open $cmd r]}]} {
5614                 return
5615             }
5616             set treepending $id
5617             set treefilelist($id) {}
5618             set treeidlist($id) {}
5619             fconfigure $gtf -blocking 0
5620             filerun $gtf [list gettreeline $gtf $id]
5621         }
5622     } else {
5623         setfilelist $id
5624     }
5627 proc gettreeline {gtf id} {
5628     global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5630     set nl 0
5631     while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5632         if {$diffids eq $nullid} {
5633             set fname $line
5634         } else {
5635             if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5636             set i [string first "\t" $line]
5637             if {$i < 0} continue
5638             set sha1 [lindex $line 2]
5639             set fname [string range $line [expr {$i+1}] end]
5640             if {[string index $fname 0] eq "\""} {
5641                 set fname [lindex $fname 0]
5642             }
5643             lappend treeidlist($id) $sha1
5644         }
5645         lappend treefilelist($id) $fname
5646     }
5647     if {![eof $gtf]} {
5648         return [expr {$nl >= 1000? 2: 1}]
5649     }
5650     close $gtf
5651     unset treepending
5652     if {$cmitmode ne "tree"} {
5653         if {![info exists diffmergeid]} {
5654             gettreediffs $diffids
5655         }
5656     } elseif {$id ne $diffids} {
5657         gettree $diffids
5658     } else {
5659         setfilelist $id
5660     }
5661     return 0
5664 proc showfile {f} {
5665     global treefilelist treeidlist diffids nullid nullid2
5666     global ctext commentend
5668     set i [lsearch -exact $treefilelist($diffids) $f]
5669     if {$i < 0} {
5670         puts "oops, $f not in list for id $diffids"
5671         return
5672     }
5673     if {$diffids eq $nullid} {
5674         if {[catch {set bf [open $f r]} err]} {
5675             puts "oops, can't read $f: $err"
5676             return
5677         }
5678     } else {
5679         set blob [lindex $treeidlist($diffids) $i]
5680         if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5681             puts "oops, error reading blob $blob: $err"
5682             return
5683         }
5684     }
5685     fconfigure $bf -blocking 0
5686     filerun $bf [list getblobline $bf $diffids]
5687     $ctext config -state normal
5688     clear_ctext $commentend
5689     $ctext insert end "\n"
5690     $ctext insert end "$f\n" filesep
5691     $ctext config -state disabled
5692     $ctext yview $commentend
5693     settabs 0
5696 proc getblobline {bf id} {
5697     global diffids cmitmode ctext
5699     if {$id ne $diffids || $cmitmode ne "tree"} {
5700         catch {close $bf}
5701         return 0
5702     }
5703     $ctext config -state normal
5704     set nl 0
5705     while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5706         $ctext insert end "$line\n"
5707     }
5708     if {[eof $bf]} {
5709         # delete last newline
5710         $ctext delete "end - 2c" "end - 1c"
5711         close $bf
5712         return 0
5713     }
5714     $ctext config -state disabled
5715     return [expr {$nl >= 1000? 2: 1}]
5718 proc mergediff {id} {
5719     global diffmergeid mdifffd
5720     global diffids
5721     global parents
5722     global limitdiffs viewfiles curview
5724     set diffmergeid $id
5725     set diffids $id
5726     # this doesn't seem to actually affect anything...
5727     set cmd [concat | git diff-tree --no-commit-id --cc $id]
5728     if {$limitdiffs && $viewfiles($curview) ne {}} {
5729         set cmd [concat $cmd -- $viewfiles($curview)]
5730     }
5731     if {[catch {set mdf [open $cmd r]} err]} {
5732         error_popup "[mc "Error getting merge diffs:"] $err"
5733         return
5734     }
5735     fconfigure $mdf -blocking 0
5736     set mdifffd($id) $mdf
5737     set np [llength $parents($curview,$id)]
5738     settabs $np
5739     filerun $mdf [list getmergediffline $mdf $id $np]
5742 proc getmergediffline {mdf id np} {
5743     global diffmergeid ctext cflist mergemax
5744     global difffilestart mdifffd
5746     $ctext conf -state normal
5747     set nr 0
5748     while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5749         if {![info exists diffmergeid] || $id != $diffmergeid
5750             || $mdf != $mdifffd($id)} {
5751             close $mdf
5752             return 0
5753         }
5754         if {[regexp {^diff --cc (.*)} $line match fname]} {
5755             # start of a new file
5756             $ctext insert end "\n"
5757             set here [$ctext index "end - 1c"]
5758             lappend difffilestart $here
5759             add_flist [list $fname]
5760             set l [expr {(78 - [string length $fname]) / 2}]
5761             set pad [string range "----------------------------------------" 1 $l]
5762             $ctext insert end "$pad $fname $pad\n" filesep
5763         } elseif {[regexp {^@@} $line]} {
5764             $ctext insert end "$line\n" hunksep
5765         } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5766             # do nothing
5767         } else {
5768             # parse the prefix - one ' ', '-' or '+' for each parent
5769             set spaces {}
5770             set minuses {}
5771             set pluses {}
5772             set isbad 0
5773             for {set j 0} {$j < $np} {incr j} {
5774                 set c [string range $line $j $j]
5775                 if {$c == " "} {
5776                     lappend spaces $j
5777                 } elseif {$c == "-"} {
5778                     lappend minuses $j
5779                 } elseif {$c == "+"} {
5780                     lappend pluses $j
5781                 } else {
5782                     set isbad 1
5783                     break
5784                 }
5785             }
5786             set tags {}
5787             set num {}
5788             if {!$isbad && $minuses ne {} && $pluses eq {}} {
5789                 # line doesn't appear in result, parents in $minuses have the line
5790                 set num [lindex $minuses 0]
5791             } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5792                 # line appears in result, parents in $pluses don't have the line
5793                 lappend tags mresult
5794                 set num [lindex $spaces 0]
5795             }
5796             if {$num ne {}} {
5797                 if {$num >= $mergemax} {
5798                     set num "max"
5799                 }
5800                 lappend tags m$num
5801             }
5802             $ctext insert end "$line\n" $tags
5803         }
5804     }
5805     $ctext conf -state disabled
5806     if {[eof $mdf]} {
5807         close $mdf
5808         return 0
5809     }
5810     return [expr {$nr >= 1000? 2: 1}]
5813 proc startdiff {ids} {
5814     global treediffs diffids treepending diffmergeid nullid nullid2
5816     settabs 1
5817     set diffids $ids
5818     catch {unset diffmergeid}
5819     if {![info exists treediffs($ids)] ||
5820         [lsearch -exact $ids $nullid] >= 0 ||
5821         [lsearch -exact $ids $nullid2] >= 0} {
5822         if {![info exists treepending]} {
5823             gettreediffs $ids
5824         }
5825     } else {
5826         addtocflist $ids
5827     }
5830 proc path_filter {filter name} {
5831     foreach p $filter {
5832         set l [string length $p]
5833         if {[string index $p end] eq "/"} {
5834             if {[string compare -length $l $p $name] == 0} {
5835                 return 1
5836             }
5837         } else {
5838             if {[string compare -length $l $p $name] == 0 &&
5839                 ([string length $name] == $l ||
5840                  [string index $name $l] eq "/")} {
5841                 return 1
5842             }
5843         }
5844     }
5845     return 0
5848 proc addtocflist {ids} {
5849     global treediffs
5851     add_flist $treediffs($ids)
5852     getblobdiffs $ids
5855 proc diffcmd {ids flags} {
5856     global nullid nullid2
5858     set i [lsearch -exact $ids $nullid]
5859     set j [lsearch -exact $ids $nullid2]
5860     if {$i >= 0} {
5861         if {[llength $ids] > 1 && $j < 0} {
5862             # comparing working directory with some specific revision
5863             set cmd [concat | git diff-index $flags]
5864             if {$i == 0} {
5865                 lappend cmd -R [lindex $ids 1]
5866             } else {
5867                 lappend cmd [lindex $ids 0]
5868             }
5869         } else {
5870             # comparing working directory with index
5871             set cmd [concat | git diff-files $flags]
5872             if {$j == 1} {
5873                 lappend cmd -R
5874             }
5875         }
5876     } elseif {$j >= 0} {
5877         set cmd [concat | git diff-index --cached $flags]
5878         if {[llength $ids] > 1} {
5879             # comparing index with specific revision
5880             if {$i == 0} {
5881                 lappend cmd -R [lindex $ids 1]
5882             } else {
5883                 lappend cmd [lindex $ids 0]
5884             }
5885         } else {
5886             # comparing index with HEAD
5887             lappend cmd HEAD
5888         }
5889     } else {
5890         set cmd [concat | git diff-tree -r $flags $ids]
5891     }
5892     return $cmd
5895 proc gettreediffs {ids} {
5896     global treediff treepending
5898     set treepending $ids
5899     set treediff {}
5900     if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5901     fconfigure $gdtf -blocking 0
5902     filerun $gdtf [list gettreediffline $gdtf $ids]
5905 proc gettreediffline {gdtf ids} {
5906     global treediff treediffs treepending diffids diffmergeid
5907     global cmitmode viewfiles curview limitdiffs
5909     set nr 0
5910     while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5911         set i [string first "\t" $line]
5912         if {$i >= 0} {
5913             set file [string range $line [expr {$i+1}] end]
5914             if {[string index $file 0] eq "\""} {
5915                 set file [lindex $file 0]
5916             }
5917             lappend treediff $file
5918         }
5919     }
5920     if {![eof $gdtf]} {
5921         return [expr {$nr >= 1000? 2: 1}]
5922     }
5923     close $gdtf
5924     if {$limitdiffs && $viewfiles($curview) ne {}} {
5925         set flist {}
5926         foreach f $treediff {
5927             if {[path_filter $viewfiles($curview) $f]} {
5928                 lappend flist $f
5929             }
5930         }
5931         set treediffs($ids) $flist
5932     } else {
5933         set treediffs($ids) $treediff
5934     }
5935     unset treepending
5936     if {$cmitmode eq "tree"} {
5937         gettree $diffids
5938     } elseif {$ids != $diffids} {
5939         if {![info exists diffmergeid]} {
5940             gettreediffs $diffids
5941         }
5942     } else {
5943         addtocflist $ids
5944     }
5945     return 0
5948 # empty string or positive integer
5949 proc diffcontextvalidate {v} {
5950     return [regexp {^(|[1-9][0-9]*)$} $v]
5953 proc diffcontextchange {n1 n2 op} {
5954     global diffcontextstring diffcontext
5956     if {[string is integer -strict $diffcontextstring]} {
5957         if {$diffcontextstring > 0} {
5958             set diffcontext $diffcontextstring
5959             reselectline
5960         }
5961     }
5964 proc getblobdiffs {ids} {
5965     global blobdifffd diffids env
5966     global diffinhdr treediffs
5967     global diffcontext
5968     global limitdiffs viewfiles curview
5970     set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5971     if {$limitdiffs && $viewfiles($curview) ne {}} {
5972         set cmd [concat $cmd -- $viewfiles($curview)]
5973     }
5974     if {[catch {set bdf [open $cmd r]} err]} {
5975         puts "error getting diffs: $err"
5976         return
5977     }
5978     set diffinhdr 0
5979     fconfigure $bdf -blocking 0
5980     set blobdifffd($ids) $bdf
5981     filerun $bdf [list getblobdiffline $bdf $diffids]
5984 proc setinlist {var i val} {
5985     global $var
5987     while {[llength [set $var]] < $i} {
5988         lappend $var {}
5989     }
5990     if {[llength [set $var]] == $i} {
5991         lappend $var $val
5992     } else {
5993         lset $var $i $val
5994     }
5997 proc makediffhdr {fname ids} {
5998     global ctext curdiffstart treediffs
6000     set i [lsearch -exact $treediffs($ids) $fname]
6001     if {$i >= 0} {
6002         setinlist difffilestart $i $curdiffstart
6003     }
6004     set l [expr {(78 - [string length $fname]) / 2}]
6005     set pad [string range "----------------------------------------" 1 $l]
6006     $ctext insert $curdiffstart "$pad $fname $pad" filesep
6009 proc getblobdiffline {bdf ids} {
6010     global diffids blobdifffd ctext curdiffstart
6011     global diffnexthead diffnextnote difffilestart
6012     global diffinhdr treediffs
6014     set nr 0
6015     $ctext conf -state normal
6016     while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6017         if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6018             close $bdf
6019             return 0
6020         }
6021         if {![string compare -length 11 "diff --git " $line]} {
6022             # trim off "diff --git "
6023             set line [string range $line 11 end]
6024             set diffinhdr 1
6025             # start of a new file
6026             $ctext insert end "\n"
6027             set curdiffstart [$ctext index "end - 1c"]
6028             $ctext insert end "\n" filesep
6029             # If the name hasn't changed the length will be odd,
6030             # the middle char will be a space, and the two bits either
6031             # side will be a/name and b/name, or "a/name" and "b/name".
6032             # If the name has changed we'll get "rename from" and
6033             # "rename to" or "copy from" and "copy to" lines following this,
6034             # and we'll use them to get the filenames.
6035             # This complexity is necessary because spaces in the filename(s)
6036             # don't get escaped.
6037             set l [string length $line]
6038             set i [expr {$l / 2}]
6039             if {!(($l & 1) && [string index $line $i] eq " " &&
6040                   [string range $line 2 [expr {$i - 1}]] eq \
6041                       [string range $line [expr {$i + 3}] end])} {
6042                 continue
6043             }
6044             # unescape if quoted and chop off the a/ from the front
6045             if {[string index $line 0] eq "\""} {
6046                 set fname [string range [lindex $line 0] 2 end]
6047             } else {
6048                 set fname [string range $line 2 [expr {$i - 1}]]
6049             }
6050             makediffhdr $fname $ids
6052         } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6053                        $line match f1l f1c f2l f2c rest]} {
6054             $ctext insert end "$line\n" hunksep
6055             set diffinhdr 0
6057         } elseif {$diffinhdr} {
6058             if {![string compare -length 12 "rename from " $line]} {
6059                 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6060                 if {[string index $fname 0] eq "\""} {
6061                     set fname [lindex $fname 0]
6062                 }
6063                 set i [lsearch -exact $treediffs($ids) $fname]
6064                 if {$i >= 0} {
6065                     setinlist difffilestart $i $curdiffstart
6066                 }
6067             } elseif {![string compare -length 10 $line "rename to "] ||
6068                       ![string compare -length 8 $line "copy to "]} {
6069                 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6070                 if {[string index $fname 0] eq "\""} {
6071                     set fname [lindex $fname 0]
6072                 }
6073                 makediffhdr $fname $ids
6074             } elseif {[string compare -length 3 $line "---"] == 0} {
6075                 # do nothing
6076                 continue
6077             } elseif {[string compare -length 3 $line "+++"] == 0} {
6078                 set diffinhdr 0
6079                 continue
6080             }
6081             $ctext insert end "$line\n" filesep
6083         } else {
6084             set x [string range $line 0 0]
6085             if {$x == "-" || $x == "+"} {
6086                 set tag [expr {$x == "+"}]
6087                 $ctext insert end "$line\n" d$tag
6088             } elseif {$x == " "} {
6089                 $ctext insert end "$line\n"
6090             } else {
6091                 # "\ No newline at end of file",
6092                 # or something else we don't recognize
6093                 $ctext insert end "$line\n" hunksep
6094             }
6095         }
6096     }
6097     $ctext conf -state disabled
6098     if {[eof $bdf]} {
6099         close $bdf
6100         return 0
6101     }
6102     return [expr {$nr >= 1000? 2: 1}]
6105 proc changediffdisp {} {
6106     global ctext diffelide
6108     $ctext tag conf d0 -elide [lindex $diffelide 0]
6109     $ctext tag conf d1 -elide [lindex $diffelide 1]
6112 proc prevfile {} {
6113     global difffilestart ctext
6114     set prev [lindex $difffilestart 0]
6115     set here [$ctext index @0,0]
6116     foreach loc $difffilestart {
6117         if {[$ctext compare $loc >= $here]} {
6118             $ctext yview $prev
6119             return
6120         }
6121         set prev $loc
6122     }
6123     $ctext yview $prev
6126 proc nextfile {} {
6127     global difffilestart ctext
6128     set here [$ctext index @0,0]
6129     foreach loc $difffilestart {
6130         if {[$ctext compare $loc > $here]} {
6131             $ctext yview $loc
6132             return
6133         }
6134     }
6137 proc clear_ctext {{first 1.0}} {
6138     global ctext smarktop smarkbot
6139     global pendinglinks
6141     set l [lindex [split $first .] 0]
6142     if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6143         set smarktop $l
6144     }
6145     if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6146         set smarkbot $l
6147     }
6148     $ctext delete $first end
6149     if {$first eq "1.0"} {
6150         catch {unset pendinglinks}
6151     }
6154 proc settabs {{firstab {}}} {
6155     global firsttabstop tabstop ctext have_tk85
6157     if {$firstab ne {} && $have_tk85} {
6158         set firsttabstop $firstab
6159     }
6160     set w [font measure textfont "0"]
6161     if {$firsttabstop != 0} {
6162         $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6163                                [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6164     } elseif {$have_tk85 || $tabstop != 8} {
6165         $ctext conf -tabs [expr {$tabstop * $w}]
6166     } else {
6167         $ctext conf -tabs {}
6168     }
6171 proc incrsearch {name ix op} {
6172     global ctext searchstring searchdirn
6174     $ctext tag remove found 1.0 end
6175     if {[catch {$ctext index anchor}]} {
6176         # no anchor set, use start of selection, or of visible area
6177         set sel [$ctext tag ranges sel]
6178         if {$sel ne {}} {
6179             $ctext mark set anchor [lindex $sel 0]
6180         } elseif {$searchdirn eq "-forwards"} {
6181             $ctext mark set anchor @0,0
6182         } else {
6183             $ctext mark set anchor @0,[winfo height $ctext]
6184         }
6185     }
6186     if {$searchstring ne {}} {
6187         set here [$ctext search $searchdirn -- $searchstring anchor]
6188         if {$here ne {}} {
6189             $ctext see $here
6190         }
6191         searchmarkvisible 1
6192     }
6195 proc dosearch {} {
6196     global sstring ctext searchstring searchdirn
6198     focus $sstring
6199     $sstring icursor end
6200     set searchdirn -forwards
6201     if {$searchstring ne {}} {
6202         set sel [$ctext tag ranges sel]
6203         if {$sel ne {}} {
6204             set start "[lindex $sel 0] + 1c"
6205         } elseif {[catch {set start [$ctext index anchor]}]} {
6206             set start "@0,0"
6207         }
6208         set match [$ctext search -count mlen -- $searchstring $start]
6209         $ctext tag remove sel 1.0 end
6210         if {$match eq {}} {
6211             bell
6212             return
6213         }
6214         $ctext see $match
6215         set mend "$match + $mlen c"
6216         $ctext tag add sel $match $mend
6217         $ctext mark unset anchor
6218     }
6221 proc dosearchback {} {
6222     global sstring ctext searchstring searchdirn
6224     focus $sstring
6225     $sstring icursor end
6226     set searchdirn -backwards
6227     if {$searchstring ne {}} {
6228         set sel [$ctext tag ranges sel]
6229         if {$sel ne {}} {
6230             set start [lindex $sel 0]
6231         } elseif {[catch {set start [$ctext index anchor]}]} {
6232             set start @0,[winfo height $ctext]
6233         }
6234         set match [$ctext search -backwards -count ml -- $searchstring $start]
6235         $ctext tag remove sel 1.0 end
6236         if {$match eq {}} {
6237             bell
6238             return
6239         }
6240         $ctext see $match
6241         set mend "$match + $ml c"
6242         $ctext tag add sel $match $mend
6243         $ctext mark unset anchor
6244     }
6247 proc searchmark {first last} {
6248     global ctext searchstring
6250     set mend $first.0
6251     while {1} {
6252         set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6253         if {$match eq {}} break
6254         set mend "$match + $mlen c"
6255         $ctext tag add found $match $mend
6256     }
6259 proc searchmarkvisible {doall} {
6260     global ctext smarktop smarkbot
6262     set topline [lindex [split [$ctext index @0,0] .] 0]
6263     set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6264     if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6265         # no overlap with previous
6266         searchmark $topline $botline
6267         set smarktop $topline
6268         set smarkbot $botline
6269     } else {
6270         if {$topline < $smarktop} {
6271             searchmark $topline [expr {$smarktop-1}]
6272             set smarktop $topline
6273         }
6274         if {$botline > $smarkbot} {
6275             searchmark [expr {$smarkbot+1}] $botline
6276             set smarkbot $botline
6277         }
6278     }
6281 proc scrolltext {f0 f1} {
6282     global searchstring
6284     .bleft.sb set $f0 $f1
6285     if {$searchstring ne {}} {
6286         searchmarkvisible 0
6287     }
6290 proc setcoords {} {
6291     global linespc charspc canvx0 canvy0
6292     global xspc1 xspc2 lthickness
6294     set linespc [font metrics mainfont -linespace]
6295     set charspc [font measure mainfont "m"]
6296     set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6297     set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6298     set lthickness [expr {int($linespc / 9) + 1}]
6299     set xspc1(0) $linespc
6300     set xspc2 $linespc
6303 proc redisplay {} {
6304     global canv
6305     global selectedline
6307     set ymax [lindex [$canv cget -scrollregion] 3]
6308     if {$ymax eq {} || $ymax == 0} return
6309     set span [$canv yview]
6310     clear_display
6311     setcanvscroll
6312     allcanvs yview moveto [lindex $span 0]
6313     drawvisible
6314     if {[info exists selectedline]} {
6315         selectline $selectedline 0
6316         allcanvs yview moveto [lindex $span 0]
6317     }
6320 proc parsefont {f n} {
6321     global fontattr
6323     set fontattr($f,family) [lindex $n 0]
6324     set s [lindex $n 1]
6325     if {$s eq {} || $s == 0} {
6326         set s 10
6327     } elseif {$s < 0} {
6328         set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6329     }
6330     set fontattr($f,size) $s
6331     set fontattr($f,weight) normal
6332     set fontattr($f,slant) roman
6333     foreach style [lrange $n 2 end] {
6334         switch -- $style {
6335             "normal" -
6336             "bold"   {set fontattr($f,weight) $style}
6337             "roman" -
6338             "italic" {set fontattr($f,slant) $style}
6339         }
6340     }
6343 proc fontflags {f {isbold 0}} {
6344     global fontattr
6346     return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6347                 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6348                 -slant $fontattr($f,slant)]
6351 proc fontname {f} {
6352     global fontattr
6354     set n [list $fontattr($f,family) $fontattr($f,size)]
6355     if {$fontattr($f,weight) eq "bold"} {
6356         lappend n "bold"
6357     }
6358     if {$fontattr($f,slant) eq "italic"} {
6359         lappend n "italic"
6360     }
6361     return $n
6364 proc incrfont {inc} {
6365     global mainfont textfont ctext canv cflist showrefstop
6366     global stopped entries fontattr
6368     unmarkmatches
6369     set s $fontattr(mainfont,size)
6370     incr s $inc
6371     if {$s < 1} {
6372         set s 1
6373     }
6374     set fontattr(mainfont,size) $s
6375     font config mainfont -size $s
6376     font config mainfontbold -size $s
6377     set mainfont [fontname mainfont]
6378     set s $fontattr(textfont,size)
6379     incr s $inc
6380     if {$s < 1} {
6381         set s 1
6382     }
6383     set fontattr(textfont,size) $s
6384     font config textfont -size $s
6385     font config textfontbold -size $s
6386     set textfont [fontname textfont]
6387     setcoords
6388     settabs
6389     redisplay
6392 proc clearsha1 {} {
6393     global sha1entry sha1string
6394     if {[string length $sha1string] == 40} {
6395         $sha1entry delete 0 end
6396     }
6399 proc sha1change {n1 n2 op} {
6400     global sha1string currentid sha1but
6401     if {$sha1string == {}
6402         || ([info exists currentid] && $sha1string == $currentid)} {
6403         set state disabled
6404     } else {
6405         set state normal
6406     }
6407     if {[$sha1but cget -state] == $state} return
6408     if {$state == "normal"} {
6409         $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
6410     } else {
6411         $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
6412     }
6415 proc gotocommit {} {
6416     global sha1string tagids headids curview varcid
6418     if {$sha1string == {}
6419         || ([info exists currentid] && $sha1string == $currentid)} return
6420     if {[info exists tagids($sha1string)]} {
6421         set id $tagids($sha1string)
6422     } elseif {[info exists headids($sha1string)]} {
6423         set id $headids($sha1string)
6424     } else {
6425         set id [string tolower $sha1string]
6426         if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6427             set matches [array names varcid "$curview,$id*"]
6428             if {$matches ne {}} {
6429                 if {[llength $matches] > 1} {
6430                     error_popup [mc "Short SHA1 id %s is ambiguous" $id]
6431                     return
6432                 }
6433                 set id [lindex [split [lindex $matches 0] ","] 1]
6434             }
6435         }
6436     }
6437     if {[commitinview $id $curview]} {
6438         selectline [rowofcommit $id] 1
6439         return
6440     }
6441     if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6442         set msg [mc "SHA1 id %s is not known" $sha1string]
6443     } else {
6444         set msg [mc "Tag/Head %s is not known" $sha1string]
6445     }
6446     error_popup $msg
6449 proc lineenter {x y id} {
6450     global hoverx hovery hoverid hovertimer
6451     global commitinfo canv
6453     if {![info exists commitinfo($id)] && ![getcommit $id]} return
6454     set hoverx $x
6455     set hovery $y
6456     set hoverid $id
6457     if {[info exists hovertimer]} {
6458         after cancel $hovertimer
6459     }
6460     set hovertimer [after 500 linehover]
6461     $canv delete hover
6464 proc linemotion {x y id} {
6465     global hoverx hovery hoverid hovertimer
6467     if {[info exists hoverid] && $id == $hoverid} {
6468         set hoverx $x
6469         set hovery $y
6470         if {[info exists hovertimer]} {
6471             after cancel $hovertimer
6472         }
6473         set hovertimer [after 500 linehover]
6474     }
6477 proc lineleave {id} {
6478     global hoverid hovertimer canv
6480     if {[info exists hoverid] && $id == $hoverid} {
6481         $canv delete hover
6482         if {[info exists hovertimer]} {
6483             after cancel $hovertimer
6484             unset hovertimer
6485         }
6486         unset hoverid
6487     }
6490 proc linehover {} {
6491     global hoverx hovery hoverid hovertimer
6492     global canv linespc lthickness
6493     global commitinfo
6495     set text [lindex $commitinfo($hoverid) 0]
6496     set ymax [lindex [$canv cget -scrollregion] 3]
6497     if {$ymax == {}} return
6498     set yfrac [lindex [$canv yview] 0]
6499     set x [expr {$hoverx + 2 * $linespc}]
6500     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6501     set x0 [expr {$x - 2 * $lthickness}]
6502     set y0 [expr {$y - 2 * $lthickness}]
6503     set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6504     set y1 [expr {$y + $linespc + 2 * $lthickness}]
6505     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6506                -fill \#ffff80 -outline black -width 1 -tags hover]
6507     $canv raise $t
6508     set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6509                -font mainfont]
6510     $canv raise $t
6513 proc clickisonarrow {id y} {
6514     global lthickness
6516     set ranges [rowranges $id]
6517     set thresh [expr {2 * $lthickness + 6}]
6518     set n [expr {[llength $ranges] - 1}]
6519     for {set i 1} {$i < $n} {incr i} {
6520         set row [lindex $ranges $i]
6521         if {abs([yc $row] - $y) < $thresh} {
6522             return $i
6523         }
6524     }
6525     return {}
6528 proc arrowjump {id n y} {
6529     global canv
6531     # 1 <-> 2, 3 <-> 4, etc...
6532     set n [expr {(($n - 1) ^ 1) + 1}]
6533     set row [lindex [rowranges $id] $n]
6534     set yt [yc $row]
6535     set ymax [lindex [$canv cget -scrollregion] 3]
6536     if {$ymax eq {} || $ymax <= 0} return
6537     set view [$canv yview]
6538     set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6539     set yfrac [expr {$yt / $ymax - $yspan / 2}]
6540     if {$yfrac < 0} {
6541         set yfrac 0
6542     }
6543     allcanvs yview moveto $yfrac
6546 proc lineclick {x y id isnew} {
6547     global ctext commitinfo children canv thickerline curview
6549     if {![info exists commitinfo($id)] && ![getcommit $id]} return
6550     unmarkmatches
6551     unselectline
6552     normalline
6553     $canv delete hover
6554     # draw this line thicker than normal
6555     set thickerline $id
6556     drawlines $id
6557     if {$isnew} {
6558         set ymax [lindex [$canv cget -scrollregion] 3]
6559         if {$ymax eq {}} return
6560         set yfrac [lindex [$canv yview] 0]
6561         set y [expr {$y + $yfrac * $ymax}]
6562     }
6563     set dirn [clickisonarrow $id $y]
6564     if {$dirn ne {}} {
6565         arrowjump $id $dirn $y
6566         return
6567     }
6569     if {$isnew} {
6570         addtohistory [list lineclick $x $y $id 0]
6571     }
6572     # fill the details pane with info about this line
6573     $ctext conf -state normal
6574     clear_ctext
6575     settabs 0
6576     $ctext insert end "[mc "Parent"]:\t"
6577     $ctext insert end $id link0
6578     setlink $id link0
6579     set info $commitinfo($id)
6580     $ctext insert end "\n\t[lindex $info 0]\n"
6581     $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
6582     set date [formatdate [lindex $info 2]]
6583     $ctext insert end "\t[mc "Date"]:\t$date\n"
6584     set kids $children($curview,$id)
6585     if {$kids ne {}} {
6586         $ctext insert end "\n[mc "Children"]:"
6587         set i 0
6588         foreach child $kids {
6589             incr i
6590             if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6591             set info $commitinfo($child)
6592             $ctext insert end "\n\t"
6593             $ctext insert end $child link$i
6594             setlink $child link$i
6595             $ctext insert end "\n\t[lindex $info 0]"
6596             $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
6597             set date [formatdate [lindex $info 2]]
6598             $ctext insert end "\n\t[mc "Date"]:\t$date\n"
6599         }
6600     }
6601     $ctext conf -state disabled
6602     init_flist {}
6605 proc normalline {} {
6606     global thickerline
6607     if {[info exists thickerline]} {
6608         set id $thickerline
6609         unset thickerline
6610         drawlines $id
6611     }
6614 proc selbyid {id} {
6615     global curview
6616     if {[commitinview $id $curview]} {
6617         selectline [rowofcommit $id] 1
6618     }
6621 proc mstime {} {
6622     global startmstime
6623     if {![info exists startmstime]} {
6624         set startmstime [clock clicks -milliseconds]
6625     }
6626     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6629 proc rowmenu {x y id} {
6630     global rowctxmenu selectedline rowmenuid curview
6631     global nullid nullid2 fakerowmenu mainhead
6633     stopfinding
6634     set rowmenuid $id
6635     if {![info exists selectedline]
6636         || [rowofcommit $id] eq $selectedline} {
6637         set state disabled
6638     } else {
6639         set state normal
6640     }
6641     if {$id ne $nullid && $id ne $nullid2} {
6642         set menu $rowctxmenu
6643         $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6644     } else {
6645         set menu $fakerowmenu
6646     }
6647     $menu entryconfigure [mc "Diff this -> selected"] -state $state
6648     $menu entryconfigure [mc "Diff selected -> this"] -state $state
6649     $menu entryconfigure [mc "Make patch"] -state $state
6650     tk_popup $menu $x $y
6653 proc diffvssel {dirn} {
6654     global rowmenuid selectedline
6656     if {![info exists selectedline]} return
6657     if {$dirn} {
6658         set oldid [commitonrow $selectedline]
6659         set newid $rowmenuid
6660     } else {
6661         set oldid $rowmenuid
6662         set newid [commitonrow $selectedline]
6663     }
6664     addtohistory [list doseldiff $oldid $newid]
6665     doseldiff $oldid $newid
6668 proc doseldiff {oldid newid} {
6669     global ctext
6670     global commitinfo
6672     $ctext conf -state normal
6673     clear_ctext
6674     init_flist [mc "Top"]
6675     $ctext insert end "[mc "From"] "
6676     $ctext insert end $oldid link0
6677     setlink $oldid link0
6678     $ctext insert end "\n     "
6679     $ctext insert end [lindex $commitinfo($oldid) 0]
6680     $ctext insert end "\n\n[mc "To"]   "
6681     $ctext insert end $newid link1
6682     setlink $newid link1
6683     $ctext insert end "\n     "
6684     $ctext insert end [lindex $commitinfo($newid) 0]
6685     $ctext insert end "\n"
6686     $ctext conf -state disabled
6687     $ctext tag remove found 1.0 end
6688     startdiff [list $oldid $newid]
6691 proc mkpatch {} {
6692     global rowmenuid currentid commitinfo patchtop patchnum
6694     if {![info exists currentid]} return
6695     set oldid $currentid
6696     set oldhead [lindex $commitinfo($oldid) 0]
6697     set newid $rowmenuid
6698     set newhead [lindex $commitinfo($newid) 0]
6699     set top .patch
6700     set patchtop $top
6701     catch {destroy $top}
6702     toplevel $top
6703     label $top.title -text [mc "Generate patch"]
6704     grid $top.title - -pady 10
6705     label $top.from -text [mc "From:"]
6706     entry $top.fromsha1 -width 40 -relief flat
6707     $top.fromsha1 insert 0 $oldid
6708     $top.fromsha1 conf -state readonly
6709     grid $top.from $top.fromsha1 -sticky w
6710     entry $top.fromhead -width 60 -relief flat
6711     $top.fromhead insert 0 $oldhead
6712     $top.fromhead conf -state readonly
6713     grid x $top.fromhead -sticky w
6714     label $top.to -text [mc "To:"]
6715     entry $top.tosha1 -width 40 -relief flat
6716     $top.tosha1 insert 0 $newid
6717     $top.tosha1 conf -state readonly
6718     grid $top.to $top.tosha1 -sticky w
6719     entry $top.tohead -width 60 -relief flat
6720     $top.tohead insert 0 $newhead
6721     $top.tohead conf -state readonly
6722     grid x $top.tohead -sticky w
6723     button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6724     grid $top.rev x -pady 10
6725     label $top.flab -text [mc "Output file:"]
6726     entry $top.fname -width 60
6727     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6728     incr patchnum
6729     grid $top.flab $top.fname -sticky w
6730     frame $top.buts
6731     button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6732     button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6733     grid $top.buts.gen $top.buts.can
6734     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6735     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6736     grid $top.buts - -pady 10 -sticky ew
6737     focus $top.fname
6740 proc mkpatchrev {} {
6741     global patchtop
6743     set oldid [$patchtop.fromsha1 get]
6744     set oldhead [$patchtop.fromhead get]
6745     set newid [$patchtop.tosha1 get]
6746     set newhead [$patchtop.tohead get]
6747     foreach e [list fromsha1 fromhead tosha1 tohead] \
6748             v [list $newid $newhead $oldid $oldhead] {
6749         $patchtop.$e conf -state normal
6750         $patchtop.$e delete 0 end
6751         $patchtop.$e insert 0 $v
6752         $patchtop.$e conf -state readonly
6753     }
6756 proc mkpatchgo {} {
6757     global patchtop nullid nullid2
6759     set oldid [$patchtop.fromsha1 get]
6760     set newid [$patchtop.tosha1 get]
6761     set fname [$patchtop.fname get]
6762     set cmd [diffcmd [list $oldid $newid] -p]
6763     # trim off the initial "|"
6764     set cmd [lrange $cmd 1 end]
6765     lappend cmd >$fname &
6766     if {[catch {eval exec $cmd} err]} {
6767         error_popup "[mc "Error creating patch:"] $err"
6768     }
6769     catch {destroy $patchtop}
6770     unset patchtop
6773 proc mkpatchcan {} {
6774     global patchtop
6776     catch {destroy $patchtop}
6777     unset patchtop
6780 proc mktag {} {
6781     global rowmenuid mktagtop commitinfo
6783     set top .maketag
6784     set mktagtop $top
6785     catch {destroy $top}
6786     toplevel $top
6787     label $top.title -text [mc "Create tag"]
6788     grid $top.title - -pady 10
6789     label $top.id -text [mc "ID:"]
6790     entry $top.sha1 -width 40 -relief flat
6791     $top.sha1 insert 0 $rowmenuid
6792     $top.sha1 conf -state readonly
6793     grid $top.id $top.sha1 -sticky w
6794     entry $top.head -width 60 -relief flat
6795     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6796     $top.head conf -state readonly
6797     grid x $top.head -sticky w
6798     label $top.tlab -text [mc "Tag name:"]
6799     entry $top.tag -width 60
6800     grid $top.tlab $top.tag -sticky w
6801     frame $top.buts
6802     button $top.buts.gen -text [mc "Create"] -command mktaggo
6803     button $top.buts.can -text [mc "Cancel"] -command mktagcan
6804     grid $top.buts.gen $top.buts.can
6805     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6806     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6807     grid $top.buts - -pady 10 -sticky ew
6808     focus $top.tag
6811 proc domktag {} {
6812     global mktagtop env tagids idtags
6814     set id [$mktagtop.sha1 get]
6815     set tag [$mktagtop.tag get]
6816     if {$tag == {}} {
6817         error_popup [mc "No tag name specified"]
6818         return
6819     }
6820     if {[info exists tagids($tag)]} {
6821         error_popup [mc "Tag \"%s\" already exists" $tag]
6822         return
6823     }
6824     if {[catch {
6825         set dir [gitdir]
6826         set fname [file join $dir "refs/tags" $tag]
6827         set f [open $fname w]
6828         puts $f $id
6829         close $f
6830     } err]} {
6831         error_popup "[mc "Error creating tag:"] $err"
6832         return
6833     }
6835     set tagids($tag) $id
6836     lappend idtags($id) $tag
6837     redrawtags $id
6838     addedtag $id
6839     dispneartags 0
6840     run refill_reflist
6843 proc redrawtags {id} {
6844     global canv linehtag idpos currentid curview
6845     global canvxmax iddrawn
6847     if {![commitinview $id $curview]} return
6848     if {![info exists iddrawn($id)]} return
6849     set row [rowofcommit $id]
6850     $canv delete tag.$id
6851     set xt [eval drawtags $id $idpos($id)]
6852     $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
6853     set text [$canv itemcget $linehtag($row) -text]
6854     set font [$canv itemcget $linehtag($row) -font]
6855     set xr [expr {$xt + [font measure $font $text]}]
6856     if {$xr > $canvxmax} {
6857         set canvxmax $xr
6858         setcanvscroll
6859     }
6860     if {[info exists currentid] && $currentid == $id} {
6861         make_secsel $row
6862     }
6865 proc mktagcan {} {
6866     global mktagtop
6868     catch {destroy $mktagtop}
6869     unset mktagtop
6872 proc mktaggo {} {
6873     domktag
6874     mktagcan
6877 proc writecommit {} {
6878     global rowmenuid wrcomtop commitinfo wrcomcmd
6880     set top .writecommit
6881     set wrcomtop $top
6882     catch {destroy $top}
6883     toplevel $top
6884     label $top.title -text [mc "Write commit to file"]
6885     grid $top.title - -pady 10
6886     label $top.id -text [mc "ID:"]
6887     entry $top.sha1 -width 40 -relief flat
6888     $top.sha1 insert 0 $rowmenuid
6889     $top.sha1 conf -state readonly
6890     grid $top.id $top.sha1 -sticky w
6891     entry $top.head -width 60 -relief flat
6892     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6893     $top.head conf -state readonly
6894     grid x $top.head -sticky w
6895     label $top.clab -text [mc "Command:"]
6896     entry $top.cmd -width 60 -textvariable wrcomcmd
6897     grid $top.clab $top.cmd -sticky w -pady 10
6898     label $top.flab -text [mc "Output file:"]
6899     entry $top.fname -width 60
6900     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6901     grid $top.flab $top.fname -sticky w
6902     frame $top.buts
6903     button $top.buts.gen -text [mc "Write"] -command wrcomgo
6904     button $top.buts.can -text [mc "Cancel"] -command wrcomcan
6905     grid $top.buts.gen $top.buts.can
6906     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6907     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6908     grid $top.buts - -pady 10 -sticky ew
6909     focus $top.fname
6912 proc wrcomgo {} {
6913     global wrcomtop
6915     set id [$wrcomtop.sha1 get]
6916     set cmd "echo $id | [$wrcomtop.cmd get]"
6917     set fname [$wrcomtop.fname get]
6918     if {[catch {exec sh -c $cmd >$fname &} err]} {
6919         error_popup "[mc "Error writing commit:"] $err"
6920     }
6921     catch {destroy $wrcomtop}
6922     unset wrcomtop
6925 proc wrcomcan {} {
6926     global wrcomtop
6928     catch {destroy $wrcomtop}
6929     unset wrcomtop
6932 proc mkbranch {} {
6933     global rowmenuid mkbrtop
6935     set top .makebranch
6936     catch {destroy $top}
6937     toplevel $top
6938     label $top.title -text [mc "Create new branch"]
6939     grid $top.title - -pady 10
6940     label $top.id -text [mc "ID:"]
6941     entry $top.sha1 -width 40 -relief flat
6942     $top.sha1 insert 0 $rowmenuid
6943     $top.sha1 conf -state readonly
6944     grid $top.id $top.sha1 -sticky w
6945     label $top.nlab -text [mc "Name:"]
6946     entry $top.name -width 40
6947     grid $top.nlab $top.name -sticky w
6948     frame $top.buts
6949     button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
6950     button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
6951     grid $top.buts.go $top.buts.can
6952     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6953     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6954     grid $top.buts - -pady 10 -sticky ew
6955     focus $top.name
6958 proc mkbrgo {top} {
6959     global headids idheads
6961     set name [$top.name get]
6962     set id [$top.sha1 get]
6963     if {$name eq {}} {
6964         error_popup [mc "Please specify a name for the new branch"]
6965         return
6966     }
6967     catch {destroy $top}
6968     nowbusy newbranch
6969     update
6970     if {[catch {
6971         exec git branch $name $id
6972     } err]} {
6973         notbusy newbranch
6974         error_popup $err
6975     } else {
6976         set headids($name) $id
6977         lappend idheads($id) $name
6978         addedhead $id $name
6979         notbusy newbranch
6980         redrawtags $id
6981         dispneartags 0
6982         run refill_reflist
6983     }
6986 proc cherrypick {} {
6987     global rowmenuid curview
6988     global mainhead
6990     set oldhead [exec git rev-parse HEAD]
6991     set dheads [descheads $rowmenuid]
6992     if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6993         set ok [confirm_popup [mc "Commit %s is already\
6994                 included in branch %s -- really re-apply it?" \
6995                                    [string range $rowmenuid 0 7] $mainhead]]
6996         if {!$ok} return
6997     }
6998     nowbusy cherrypick [mc "Cherry-picking"]
6999     update
7000     # Unfortunately git-cherry-pick writes stuff to stderr even when
7001     # no error occurs, and exec takes that as an indication of error...
7002     if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7003         notbusy cherrypick
7004         error_popup $err
7005         return
7006     }
7007     set newhead [exec git rev-parse HEAD]
7008     if {$newhead eq $oldhead} {
7009         notbusy cherrypick
7010         error_popup [mc "No changes committed"]
7011         return
7012     }
7013     addnewchild $newhead $oldhead
7014     if {[commitinview $oldhead $curview]} {
7015         insertrow $newhead $oldhead $curview
7016         if {$mainhead ne {}} {
7017             movehead $newhead $mainhead
7018             movedhead $newhead $mainhead
7019         }
7020         redrawtags $oldhead
7021         redrawtags $newhead
7022     }
7023     notbusy cherrypick
7026 proc resethead {} {
7027     global mainheadid mainhead rowmenuid confirm_ok resettype
7029     set confirm_ok 0
7030     set w ".confirmreset"
7031     toplevel $w
7032     wm transient $w .
7033     wm title $w [mc "Confirm reset"]
7034     message $w.m -text \
7035         [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7036         -justify center -aspect 1000
7037     pack $w.m -side top -fill x -padx 20 -pady 20
7038     frame $w.f -relief sunken -border 2
7039     message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7040     grid $w.f.rt -sticky w
7041     set resettype mixed
7042     radiobutton $w.f.soft -value soft -variable resettype -justify left \
7043         -text [mc "Soft: Leave working tree and index untouched"]
7044     grid $w.f.soft -sticky w
7045     radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7046         -text [mc "Mixed: Leave working tree untouched, reset index"]
7047     grid $w.f.mixed -sticky w
7048     radiobutton $w.f.hard -value hard -variable resettype -justify left \
7049         -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7050     grid $w.f.hard -sticky w
7051     pack $w.f -side top -fill x
7052     button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7053     pack $w.ok -side left -fill x -padx 20 -pady 20
7054     button $w.cancel -text [mc Cancel] -command "destroy $w"
7055     pack $w.cancel -side right -fill x -padx 20 -pady 20
7056     bind $w <Visibility> "grab $w; focus $w"
7057     tkwait window $w
7058     if {!$confirm_ok} return
7059     if {[catch {set fd [open \
7060             [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
7061         error_popup $err
7062     } else {
7063         dohidelocalchanges
7064         filerun $fd [list readresetstat $fd]
7065         nowbusy reset [mc "Resetting"]
7066     }
7069 proc readresetstat {fd} {
7070     global mainhead mainheadid showlocalchanges rprogcoord
7072     if {[gets $fd line] >= 0} {
7073         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7074             set rprogcoord [expr {1.0 * $m / $n}]
7075             adjustprogress
7076         }
7077         return 1
7078     }
7079     set rprogcoord 0
7080     adjustprogress
7081     notbusy reset
7082     if {[catch {close $fd} err]} {
7083         error_popup $err
7084     }
7085     set oldhead $mainheadid
7086     set newhead [exec git rev-parse HEAD]
7087     if {$newhead ne $oldhead} {
7088         movehead $newhead $mainhead
7089         movedhead $newhead $mainhead
7090         set mainheadid $newhead
7091         redrawtags $oldhead
7092         redrawtags $newhead
7093     }
7094     if {$showlocalchanges} {
7095         doshowlocalchanges
7096     }
7097     return 0
7100 # context menu for a head
7101 proc headmenu {x y id head} {
7102     global headmenuid headmenuhead headctxmenu mainhead
7104     stopfinding
7105     set headmenuid $id
7106     set headmenuhead $head
7107     set state normal
7108     if {$head eq $mainhead} {
7109         set state disabled
7110     }
7111     $headctxmenu entryconfigure 0 -state $state
7112     $headctxmenu entryconfigure 1 -state $state
7113     tk_popup $headctxmenu $x $y
7116 proc cobranch {} {
7117     global headmenuid headmenuhead mainhead headids
7118     global showlocalchanges mainheadid
7120     # check the tree is clean first??
7121     set oldmainhead $mainhead
7122     nowbusy checkout [mc "Checking out"]
7123     update
7124     dohidelocalchanges
7125     if {[catch {
7126         exec git checkout -q $headmenuhead
7127     } err]} {
7128         notbusy checkout
7129         error_popup $err
7130     } else {
7131         notbusy checkout
7132         set mainhead $headmenuhead
7133         set mainheadid $headmenuid
7134         if {[info exists headids($oldmainhead)]} {
7135             redrawtags $headids($oldmainhead)
7136         }
7137         redrawtags $headmenuid
7138     }
7139     if {$showlocalchanges} {
7140         dodiffindex
7141     }
7144 proc rmbranch {} {
7145     global headmenuid headmenuhead mainhead
7146     global idheads
7148     set head $headmenuhead
7149     set id $headmenuid
7150     # this check shouldn't be needed any more...
7151     if {$head eq $mainhead} {
7152         error_popup [mc "Cannot delete the currently checked-out branch"]
7153         return
7154     }
7155     set dheads [descheads $id]
7156     if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7157         # the stuff on this branch isn't on any other branch
7158         if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7159                         branch.\nReally delete branch %s?" $head $head]]} return
7160     }
7161     nowbusy rmbranch
7162     update
7163     if {[catch {exec git branch -D $head} err]} {
7164         notbusy rmbranch
7165         error_popup $err
7166         return
7167     }
7168     removehead $id $head
7169     removedhead $id $head
7170     redrawtags $id
7171     notbusy rmbranch
7172     dispneartags 0
7173     run refill_reflist
7176 # Display a list of tags and heads
7177 proc showrefs {} {
7178     global showrefstop bgcolor fgcolor selectbgcolor
7179     global bglist fglist reflistfilter reflist maincursor
7181     set top .showrefs
7182     set showrefstop $top
7183     if {[winfo exists $top]} {
7184         raise $top
7185         refill_reflist
7186         return
7187     }
7188     toplevel $top
7189     wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7190     text $top.list -background $bgcolor -foreground $fgcolor \
7191         -selectbackground $selectbgcolor -font mainfont \
7192         -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7193         -width 30 -height 20 -cursor $maincursor \
7194         -spacing1 1 -spacing3 1 -state disabled
7195     $top.list tag configure highlight -background $selectbgcolor
7196     lappend bglist $top.list
7197     lappend fglist $top.list
7198     scrollbar $top.ysb -command "$top.list yview" -orient vertical
7199     scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7200     grid $top.list $top.ysb -sticky nsew
7201     grid $top.xsb x -sticky ew
7202     frame $top.f
7203     label $top.f.l -text "[mc "Filter"]: " -font uifont
7204     entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
7205     set reflistfilter "*"
7206     trace add variable reflistfilter write reflistfilter_change
7207     pack $top.f.e -side right -fill x -expand 1
7208     pack $top.f.l -side left
7209     grid $top.f - -sticky ew -pady 2
7210     button $top.close -command [list destroy $top] -text [mc "Close"] \
7211         -font uifont
7212     grid $top.close -
7213     grid columnconfigure $top 0 -weight 1
7214     grid rowconfigure $top 0 -weight 1
7215     bind $top.list <1> {break}
7216     bind $top.list <B1-Motion> {break}
7217     bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7218     set reflist {}
7219     refill_reflist
7222 proc sel_reflist {w x y} {
7223     global showrefstop reflist headids tagids otherrefids
7225     if {![winfo exists $showrefstop]} return
7226     set l [lindex [split [$w index "@$x,$y"] "."] 0]
7227     set ref [lindex $reflist [expr {$l-1}]]
7228     set n [lindex $ref 0]
7229     switch -- [lindex $ref 1] {
7230         "H" {selbyid $headids($n)}
7231         "T" {selbyid $tagids($n)}
7232         "o" {selbyid $otherrefids($n)}
7233     }
7234     $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7237 proc unsel_reflist {} {
7238     global showrefstop
7240     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7241     $showrefstop.list tag remove highlight 0.0 end
7244 proc reflistfilter_change {n1 n2 op} {
7245     global reflistfilter
7247     after cancel refill_reflist
7248     after 200 refill_reflist
7251 proc refill_reflist {} {
7252     global reflist reflistfilter showrefstop headids tagids otherrefids
7253     global curview commitinterest
7255     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7256     set refs {}
7257     foreach n [array names headids] {
7258         if {[string match $reflistfilter $n]} {
7259             if {[commitinview $headids($n) $curview]} {
7260                 lappend refs [list $n H]
7261             } else {
7262                 set commitinterest($headids($n)) {run refill_reflist}
7263             }
7264         }
7265     }
7266     foreach n [array names tagids] {
7267         if {[string match $reflistfilter $n]} {
7268             if {[commitinview $tagids($n) $curview]} {
7269                 lappend refs [list $n T]
7270             } else {
7271                 set commitinterest($tagids($n)) {run refill_reflist}
7272             }
7273         }
7274     }
7275     foreach n [array names otherrefids] {
7276         if {[string match $reflistfilter $n]} {
7277             if {[commitinview $otherrefids($n) $curview]} {
7278                 lappend refs [list $n o]
7279             } else {
7280                 set commitinterest($otherrefids($n)) {run refill_reflist}
7281             }
7282         }
7283     }
7284     set refs [lsort -index 0 $refs]
7285     if {$refs eq $reflist} return
7287     # Update the contents of $showrefstop.list according to the
7288     # differences between $reflist (old) and $refs (new)
7289     $showrefstop.list conf -state normal
7290     $showrefstop.list insert end "\n"
7291     set i 0
7292     set j 0
7293     while {$i < [llength $reflist] || $j < [llength $refs]} {
7294         if {$i < [llength $reflist]} {
7295             if {$j < [llength $refs]} {
7296                 set cmp [string compare [lindex $reflist $i 0] \
7297                              [lindex $refs $j 0]]
7298                 if {$cmp == 0} {
7299                     set cmp [string compare [lindex $reflist $i 1] \
7300                                  [lindex $refs $j 1]]
7301                 }
7302             } else {
7303                 set cmp -1
7304             }
7305         } else {
7306             set cmp 1
7307         }
7308         switch -- $cmp {
7309             -1 {
7310                 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7311                 incr i
7312             }
7313             0 {
7314                 incr i
7315                 incr j
7316             }
7317             1 {
7318                 set l [expr {$j + 1}]
7319                 $showrefstop.list image create $l.0 -align baseline \
7320                     -image reficon-[lindex $refs $j 1] -padx 2
7321                 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7322                 incr j
7323             }
7324         }
7325     }
7326     set reflist $refs
7327     # delete last newline
7328     $showrefstop.list delete end-2c end-1c
7329     $showrefstop.list conf -state disabled
7332 # Stuff for finding nearby tags
7333 proc getallcommits {} {
7334     global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7335     global idheads idtags idotherrefs allparents tagobjid
7337     if {![info exists allcommits]} {
7338         set nextarc 0
7339         set allcommits 0
7340         set seeds {}
7341         set allcwait 0
7342         set cachedarcs 0
7343         set allccache [file join [gitdir] "gitk.cache"]
7344         if {![catch {
7345             set f [open $allccache r]
7346             set allcwait 1
7347             getcache $f
7348         }]} return
7349     }
7351     if {$allcwait} {
7352         return
7353     }
7354     set cmd [list | git rev-list --parents]
7355     set allcupdate [expr {$seeds ne {}}]
7356     if {!$allcupdate} {
7357         set ids "--all"
7358     } else {
7359         set refs [concat [array names idheads] [array names idtags] \
7360                       [array names idotherrefs]]
7361         set ids {}
7362         set tagobjs {}
7363         foreach name [array names tagobjid] {
7364             lappend tagobjs $tagobjid($name)
7365         }
7366         foreach id [lsort -unique $refs] {
7367             if {![info exists allparents($id)] &&
7368                 [lsearch -exact $tagobjs $id] < 0} {
7369                 lappend ids $id
7370             }
7371         }
7372         if {$ids ne {}} {
7373             foreach id $seeds {
7374                 lappend ids "^$id"
7375             }
7376         }
7377     }
7378     if {$ids ne {}} {
7379         set fd [open [concat $cmd $ids] r]
7380         fconfigure $fd -blocking 0
7381         incr allcommits
7382         nowbusy allcommits
7383         filerun $fd [list getallclines $fd]
7384     } else {
7385         dispneartags 0
7386     }
7389 # Since most commits have 1 parent and 1 child, we group strings of
7390 # such commits into "arcs" joining branch/merge points (BMPs), which
7391 # are commits that either don't have 1 parent or don't have 1 child.
7393 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7394 # arcout(id) - outgoing arcs for BMP
7395 # arcids(a) - list of IDs on arc including end but not start
7396 # arcstart(a) - BMP ID at start of arc
7397 # arcend(a) - BMP ID at end of arc
7398 # growing(a) - arc a is still growing
7399 # arctags(a) - IDs out of arcids (excluding end) that have tags
7400 # archeads(a) - IDs out of arcids (excluding end) that have heads
7401 # The start of an arc is at the descendent end, so "incoming" means
7402 # coming from descendents, and "outgoing" means going towards ancestors.
7404 proc getallclines {fd} {
7405     global allparents allchildren idtags idheads nextarc
7406     global arcnos arcids arctags arcout arcend arcstart archeads growing
7407     global seeds allcommits cachedarcs allcupdate
7408     
7409     set nid 0
7410     while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7411         set id [lindex $line 0]
7412         if {[info exists allparents($id)]} {
7413             # seen it already
7414             continue
7415         }
7416         set cachedarcs 0
7417         set olds [lrange $line 1 end]
7418         set allparents($id) $olds
7419         if {![info exists allchildren($id)]} {
7420             set allchildren($id) {}
7421             set arcnos($id) {}
7422             lappend seeds $id
7423         } else {
7424             set a $arcnos($id)
7425             if {[llength $olds] == 1 && [llength $a] == 1} {
7426                 lappend arcids($a) $id
7427                 if {[info exists idtags($id)]} {
7428                     lappend arctags($a) $id
7429                 }
7430                 if {[info exists idheads($id)]} {
7431                     lappend archeads($a) $id
7432                 }
7433                 if {[info exists allparents($olds)]} {
7434                     # seen parent already
7435                     if {![info exists arcout($olds)]} {
7436                         splitarc $olds
7437                     }
7438                     lappend arcids($a) $olds
7439                     set arcend($a) $olds
7440                     unset growing($a)
7441                 }
7442                 lappend allchildren($olds) $id
7443                 lappend arcnos($olds) $a
7444                 continue
7445             }
7446         }
7447         foreach a $arcnos($id) {
7448             lappend arcids($a) $id
7449             set arcend($a) $id
7450             unset growing($a)
7451         }
7453         set ao {}
7454         foreach p $olds {
7455             lappend allchildren($p) $id
7456             set a [incr nextarc]
7457             set arcstart($a) $id
7458             set archeads($a) {}
7459             set arctags($a) {}
7460             set archeads($a) {}
7461             set arcids($a) {}
7462             lappend ao $a
7463             set growing($a) 1
7464             if {[info exists allparents($p)]} {
7465                 # seen it already, may need to make a new branch
7466                 if {![info exists arcout($p)]} {
7467                     splitarc $p
7468                 }
7469                 lappend arcids($a) $p
7470                 set arcend($a) $p
7471                 unset growing($a)
7472             }
7473             lappend arcnos($p) $a
7474         }
7475         set arcout($id) $ao
7476     }
7477     if {$nid > 0} {
7478         global cached_dheads cached_dtags cached_atags
7479         catch {unset cached_dheads}
7480         catch {unset cached_dtags}
7481         catch {unset cached_atags}
7482     }
7483     if {![eof $fd]} {
7484         return [expr {$nid >= 1000? 2: 1}]
7485     }
7486     set cacheok 1
7487     if {[catch {
7488         fconfigure $fd -blocking 1
7489         close $fd
7490     } err]} {
7491         # got an error reading the list of commits
7492         # if we were updating, try rereading the whole thing again
7493         if {$allcupdate} {
7494             incr allcommits -1
7495             dropcache $err
7496             return
7497         }
7498         error_popup "[mc "Error reading commit topology information;\
7499                 branch and preceding/following tag information\
7500                 will be incomplete."]\n($err)"
7501         set cacheok 0
7502     }
7503     if {[incr allcommits -1] == 0} {
7504         notbusy allcommits
7505         if {$cacheok} {
7506             run savecache
7507         }
7508     }
7509     dispneartags 0
7510     return 0
7513 proc recalcarc {a} {
7514     global arctags archeads arcids idtags idheads
7516     set at {}
7517     set ah {}
7518     foreach id [lrange $arcids($a) 0 end-1] {
7519         if {[info exists idtags($id)]} {
7520             lappend at $id
7521         }
7522         if {[info exists idheads($id)]} {
7523             lappend ah $id
7524         }
7525     }
7526     set arctags($a) $at
7527     set archeads($a) $ah
7530 proc splitarc {p} {
7531     global arcnos arcids nextarc arctags archeads idtags idheads
7532     global arcstart arcend arcout allparents growing
7534     set a $arcnos($p)
7535     if {[llength $a] != 1} {
7536         puts "oops splitarc called but [llength $a] arcs already"
7537         return
7538     }
7539     set a [lindex $a 0]
7540     set i [lsearch -exact $arcids($a) $p]
7541     if {$i < 0} {
7542         puts "oops splitarc $p not in arc $a"
7543         return
7544     }
7545     set na [incr nextarc]
7546     if {[info exists arcend($a)]} {
7547         set arcend($na) $arcend($a)
7548     } else {
7549         set l [lindex $allparents([lindex $arcids($a) end]) 0]
7550         set j [lsearch -exact $arcnos($l) $a]
7551         set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7552     }
7553     set tail [lrange $arcids($a) [expr {$i+1}] end]
7554     set arcids($a) [lrange $arcids($a) 0 $i]
7555     set arcend($a) $p
7556     set arcstart($na) $p
7557     set arcout($p) $na
7558     set arcids($na) $tail
7559     if {[info exists growing($a)]} {
7560         set growing($na) 1
7561         unset growing($a)
7562     }
7564     foreach id $tail {
7565         if {[llength $arcnos($id)] == 1} {
7566             set arcnos($id) $na
7567         } else {
7568             set j [lsearch -exact $arcnos($id) $a]
7569             set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7570         }
7571     }
7573     # reconstruct tags and heads lists
7574     if {$arctags($a) ne {} || $archeads($a) ne {}} {
7575         recalcarc $a
7576         recalcarc $na
7577     } else {
7578         set arctags($na) {}
7579         set archeads($na) {}
7580     }
7583 # Update things for a new commit added that is a child of one
7584 # existing commit.  Used when cherry-picking.
7585 proc addnewchild {id p} {
7586     global allparents allchildren idtags nextarc
7587     global arcnos arcids arctags arcout arcend arcstart archeads growing
7588     global seeds allcommits
7590     if {![info exists allcommits] || ![info exists arcnos($p)]} return
7591     set allparents($id) [list $p]
7592     set allchildren($id) {}
7593     set arcnos($id) {}
7594     lappend seeds $id
7595     lappend allchildren($p) $id
7596     set a [incr nextarc]
7597     set arcstart($a) $id
7598     set archeads($a) {}
7599     set arctags($a) {}
7600     set arcids($a) [list $p]
7601     set arcend($a) $p
7602     if {![info exists arcout($p)]} {
7603         splitarc $p
7604     }
7605     lappend arcnos($p) $a
7606     set arcout($id) [list $a]
7609 # This implements a cache for the topology information.
7610 # The cache saves, for each arc, the start and end of the arc,
7611 # the ids on the arc, and the outgoing arcs from the end.
7612 proc readcache {f} {
7613     global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7614     global idtags idheads allparents cachedarcs possible_seeds seeds growing
7615     global allcwait
7617     set a $nextarc
7618     set lim $cachedarcs
7619     if {$lim - $a > 500} {
7620         set lim [expr {$a + 500}]
7621     }
7622     if {[catch {
7623         if {$a == $lim} {
7624             # finish reading the cache and setting up arctags, etc.
7625             set line [gets $f]
7626             if {$line ne "1"} {error "bad final version"}
7627             close $f
7628             foreach id [array names idtags] {
7629                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7630                     [llength $allparents($id)] == 1} {
7631                     set a [lindex $arcnos($id) 0]
7632                     if {$arctags($a) eq {}} {
7633                         recalcarc $a
7634                     }
7635                 }
7636             }
7637             foreach id [array names idheads] {
7638                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7639                     [llength $allparents($id)] == 1} {
7640                     set a [lindex $arcnos($id) 0]
7641                     if {$archeads($a) eq {}} {
7642                         recalcarc $a
7643                     }
7644                 }
7645             }
7646             foreach id [lsort -unique $possible_seeds] {
7647                 if {$arcnos($id) eq {}} {
7648                     lappend seeds $id
7649                 }
7650             }
7651             set allcwait 0
7652         } else {
7653             while {[incr a] <= $lim} {
7654                 set line [gets $f]
7655                 if {[llength $line] != 3} {error "bad line"}
7656                 set s [lindex $line 0]
7657                 set arcstart($a) $s
7658                 lappend arcout($s) $a
7659                 if {![info exists arcnos($s)]} {
7660                     lappend possible_seeds $s
7661                     set arcnos($s) {}
7662                 }
7663                 set e [lindex $line 1]
7664                 if {$e eq {}} {
7665                     set growing($a) 1
7666                 } else {
7667                     set arcend($a) $e
7668                     if {![info exists arcout($e)]} {
7669                         set arcout($e) {}
7670                     }
7671                 }
7672                 set arcids($a) [lindex $line 2]
7673                 foreach id $arcids($a) {
7674                     lappend allparents($s) $id
7675                     set s $id
7676                     lappend arcnos($id) $a
7677                 }
7678                 if {![info exists allparents($s)]} {
7679                     set allparents($s) {}
7680                 }
7681                 set arctags($a) {}
7682                 set archeads($a) {}
7683             }
7684             set nextarc [expr {$a - 1}]
7685         }
7686     } err]} {
7687         dropcache $err
7688         return 0
7689     }
7690     if {!$allcwait} {
7691         getallcommits
7692     }
7693     return $allcwait
7696 proc getcache {f} {
7697     global nextarc cachedarcs possible_seeds
7699     if {[catch {
7700         set line [gets $f]
7701         if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7702         # make sure it's an integer
7703         set cachedarcs [expr {int([lindex $line 1])}]
7704         if {$cachedarcs < 0} {error "bad number of arcs"}
7705         set nextarc 0
7706         set possible_seeds {}
7707         run readcache $f
7708     } err]} {
7709         dropcache $err
7710     }
7711     return 0
7714 proc dropcache {err} {
7715     global allcwait nextarc cachedarcs seeds
7717     #puts "dropping cache ($err)"
7718     foreach v {arcnos arcout arcids arcstart arcend growing \
7719                    arctags archeads allparents allchildren} {
7720         global $v
7721         catch {unset $v}
7722     }
7723     set allcwait 0
7724     set nextarc 0
7725     set cachedarcs 0
7726     set seeds {}
7727     getallcommits
7730 proc writecache {f} {
7731     global cachearc cachedarcs allccache
7732     global arcstart arcend arcnos arcids arcout
7734     set a $cachearc
7735     set lim $cachedarcs
7736     if {$lim - $a > 1000} {
7737         set lim [expr {$a + 1000}]
7738     }
7739     if {[catch {
7740         while {[incr a] <= $lim} {
7741             if {[info exists arcend($a)]} {
7742                 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7743             } else {
7744                 puts $f [list $arcstart($a) {} $arcids($a)]
7745             }
7746         }
7747     } err]} {
7748         catch {close $f}
7749         catch {file delete $allccache}
7750         #puts "writing cache failed ($err)"
7751         return 0
7752     }
7753     set cachearc [expr {$a - 1}]
7754     if {$a > $cachedarcs} {
7755         puts $f "1"
7756         close $f
7757         return 0
7758     }
7759     return 1
7762 proc savecache {} {
7763     global nextarc cachedarcs cachearc allccache
7765     if {$nextarc == $cachedarcs} return
7766     set cachearc 0
7767     set cachedarcs $nextarc
7768     catch {
7769         set f [open $allccache w]
7770         puts $f [list 1 $cachedarcs]
7771         run writecache $f
7772     }
7775 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7776 # or 0 if neither is true.
7777 proc anc_or_desc {a b} {
7778     global arcout arcstart arcend arcnos cached_isanc
7780     if {$arcnos($a) eq $arcnos($b)} {
7781         # Both are on the same arc(s); either both are the same BMP,
7782         # or if one is not a BMP, the other is also not a BMP or is
7783         # the BMP at end of the arc (and it only has 1 incoming arc).
7784         # Or both can be BMPs with no incoming arcs.
7785         if {$a eq $b || $arcnos($a) eq {}} {
7786             return 0
7787         }
7788         # assert {[llength $arcnos($a)] == 1}
7789         set arc [lindex $arcnos($a) 0]
7790         set i [lsearch -exact $arcids($arc) $a]
7791         set j [lsearch -exact $arcids($arc) $b]
7792         if {$i < 0 || $i > $j} {
7793             return 1
7794         } else {
7795             return -1
7796         }
7797     }
7799     if {![info exists arcout($a)]} {
7800         set arc [lindex $arcnos($a) 0]
7801         if {[info exists arcend($arc)]} {
7802             set aend $arcend($arc)
7803         } else {
7804             set aend {}
7805         }
7806         set a $arcstart($arc)
7807     } else {
7808         set aend $a
7809     }
7810     if {![info exists arcout($b)]} {
7811         set arc [lindex $arcnos($b) 0]
7812         if {[info exists arcend($arc)]} {
7813             set bend $arcend($arc)
7814         } else {
7815             set bend {}
7816         }
7817         set b $arcstart($arc)
7818     } else {
7819         set bend $b
7820     }
7821     if {$a eq $bend} {
7822         return 1
7823     }
7824     if {$b eq $aend} {
7825         return -1
7826     }
7827     if {[info exists cached_isanc($a,$bend)]} {
7828         if {$cached_isanc($a,$bend)} {
7829             return 1
7830         }
7831     }
7832     if {[info exists cached_isanc($b,$aend)]} {
7833         if {$cached_isanc($b,$aend)} {
7834             return -1
7835         }
7836         if {[info exists cached_isanc($a,$bend)]} {
7837             return 0
7838         }
7839     }
7841     set todo [list $a $b]
7842     set anc($a) a
7843     set anc($b) b
7844     for {set i 0} {$i < [llength $todo]} {incr i} {
7845         set x [lindex $todo $i]
7846         if {$anc($x) eq {}} {
7847             continue
7848         }
7849         foreach arc $arcnos($x) {
7850             set xd $arcstart($arc)
7851             if {$xd eq $bend} {
7852                 set cached_isanc($a,$bend) 1
7853                 set cached_isanc($b,$aend) 0
7854                 return 1
7855             } elseif {$xd eq $aend} {
7856                 set cached_isanc($b,$aend) 1
7857                 set cached_isanc($a,$bend) 0
7858                 return -1
7859             }
7860             if {![info exists anc($xd)]} {
7861                 set anc($xd) $anc($x)
7862                 lappend todo $xd
7863             } elseif {$anc($xd) ne $anc($x)} {
7864                 set anc($xd) {}
7865             }
7866         }
7867     }
7868     set cached_isanc($a,$bend) 0
7869     set cached_isanc($b,$aend) 0
7870     return 0
7873 # This identifies whether $desc has an ancestor that is
7874 # a growing tip of the graph and which is not an ancestor of $anc
7875 # and returns 0 if so and 1 if not.
7876 # If we subsequently discover a tag on such a growing tip, and that
7877 # turns out to be a descendent of $anc (which it could, since we
7878 # don't necessarily see children before parents), then $desc
7879 # isn't a good choice to display as a descendent tag of
7880 # $anc (since it is the descendent of another tag which is
7881 # a descendent of $anc).  Similarly, $anc isn't a good choice to
7882 # display as a ancestor tag of $desc.
7884 proc is_certain {desc anc} {
7885     global arcnos arcout arcstart arcend growing problems
7887     set certain {}
7888     if {[llength $arcnos($anc)] == 1} {
7889         # tags on the same arc are certain
7890         if {$arcnos($desc) eq $arcnos($anc)} {
7891             return 1
7892         }
7893         if {![info exists arcout($anc)]} {
7894             # if $anc is partway along an arc, use the start of the arc instead
7895             set a [lindex $arcnos($anc) 0]
7896             set anc $arcstart($a)
7897         }
7898     }
7899     if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7900         set x $desc
7901     } else {
7902         set a [lindex $arcnos($desc) 0]
7903         set x $arcend($a)
7904     }
7905     if {$x == $anc} {
7906         return 1
7907     }
7908     set anclist [list $x]
7909     set dl($x) 1
7910     set nnh 1
7911     set ngrowanc 0
7912     for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7913         set x [lindex $anclist $i]
7914         if {$dl($x)} {
7915             incr nnh -1
7916         }
7917         set done($x) 1
7918         foreach a $arcout($x) {
7919             if {[info exists growing($a)]} {
7920                 if {![info exists growanc($x)] && $dl($x)} {
7921                     set growanc($x) 1
7922                     incr ngrowanc
7923                 }
7924             } else {
7925                 set y $arcend($a)
7926                 if {[info exists dl($y)]} {
7927                     if {$dl($y)} {
7928                         if {!$dl($x)} {
7929                             set dl($y) 0
7930                             if {![info exists done($y)]} {
7931                                 incr nnh -1
7932                             }
7933                             if {[info exists growanc($x)]} {
7934                                 incr ngrowanc -1
7935                             }
7936                             set xl [list $y]
7937                             for {set k 0} {$k < [llength $xl]} {incr k} {
7938                                 set z [lindex $xl $k]
7939                                 foreach c $arcout($z) {
7940                                     if {[info exists arcend($c)]} {
7941                                         set v $arcend($c)
7942                                         if {[info exists dl($v)] && $dl($v)} {
7943                                             set dl($v) 0
7944                                             if {![info exists done($v)]} {
7945                                                 incr nnh -1
7946                                             }
7947                                             if {[info exists growanc($v)]} {
7948                                                 incr ngrowanc -1
7949                                             }
7950                                             lappend xl $v
7951                                         }
7952                                     }
7953                                 }
7954                             }
7955                         }
7956                     }
7957                 } elseif {$y eq $anc || !$dl($x)} {
7958                     set dl($y) 0
7959                     lappend anclist $y
7960                 } else {
7961                     set dl($y) 1
7962                     lappend anclist $y
7963                     incr nnh
7964                 }
7965             }
7966         }
7967     }
7968     foreach x [array names growanc] {
7969         if {$dl($x)} {
7970             return 0
7971         }
7972         return 0
7973     }
7974     return 1
7977 proc validate_arctags {a} {
7978     global arctags idtags
7980     set i -1
7981     set na $arctags($a)
7982     foreach id $arctags($a) {
7983         incr i
7984         if {![info exists idtags($id)]} {
7985             set na [lreplace $na $i $i]
7986             incr i -1
7987         }
7988     }
7989     set arctags($a) $na
7992 proc validate_archeads {a} {
7993     global archeads idheads
7995     set i -1
7996     set na $archeads($a)
7997     foreach id $archeads($a) {
7998         incr i
7999         if {![info exists idheads($id)]} {
8000             set na [lreplace $na $i $i]
8001             incr i -1
8002         }
8003     }
8004     set archeads($a) $na
8007 # Return the list of IDs that have tags that are descendents of id,
8008 # ignoring IDs that are descendents of IDs already reported.
8009 proc desctags {id} {
8010     global arcnos arcstart arcids arctags idtags allparents
8011     global growing cached_dtags
8013     if {![info exists allparents($id)]} {
8014         return {}
8015     }
8016     set t1 [clock clicks -milliseconds]
8017     set argid $id
8018     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8019         # part-way along an arc; check that arc first
8020         set a [lindex $arcnos($id) 0]
8021         if {$arctags($a) ne {}} {
8022             validate_arctags $a
8023             set i [lsearch -exact $arcids($a) $id]
8024             set tid {}
8025             foreach t $arctags($a) {
8026                 set j [lsearch -exact $arcids($a) $t]
8027                 if {$j >= $i} break
8028                 set tid $t
8029             }
8030             if {$tid ne {}} {
8031                 return $tid
8032             }
8033         }
8034         set id $arcstart($a)
8035         if {[info exists idtags($id)]} {
8036             return $id
8037         }
8038     }
8039     if {[info exists cached_dtags($id)]} {
8040         return $cached_dtags($id)
8041     }
8043     set origid $id
8044     set todo [list $id]
8045     set queued($id) 1
8046     set nc 1
8047     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8048         set id [lindex $todo $i]
8049         set done($id) 1
8050         set ta [info exists hastaggedancestor($id)]
8051         if {!$ta} {
8052             incr nc -1
8053         }
8054         # ignore tags on starting node
8055         if {!$ta && $i > 0} {
8056             if {[info exists idtags($id)]} {
8057                 set tagloc($id) $id
8058                 set ta 1
8059             } elseif {[info exists cached_dtags($id)]} {
8060                 set tagloc($id) $cached_dtags($id)
8061                 set ta 1
8062             }
8063         }
8064         foreach a $arcnos($id) {
8065             set d $arcstart($a)
8066             if {!$ta && $arctags($a) ne {}} {
8067                 validate_arctags $a
8068                 if {$arctags($a) ne {}} {
8069                     lappend tagloc($id) [lindex $arctags($a) end]
8070                 }
8071             }
8072             if {$ta || $arctags($a) ne {}} {
8073                 set tomark [list $d]
8074                 for {set j 0} {$j < [llength $tomark]} {incr j} {
8075                     set dd [lindex $tomark $j]
8076                     if {![info exists hastaggedancestor($dd)]} {
8077                         if {[info exists done($dd)]} {
8078                             foreach b $arcnos($dd) {
8079                                 lappend tomark $arcstart($b)
8080                             }
8081                             if {[info exists tagloc($dd)]} {
8082                                 unset tagloc($dd)
8083                             }
8084                         } elseif {[info exists queued($dd)]} {
8085                             incr nc -1
8086                         }
8087                         set hastaggedancestor($dd) 1
8088                     }
8089                 }
8090             }
8091             if {![info exists queued($d)]} {
8092                 lappend todo $d
8093                 set queued($d) 1
8094                 if {![info exists hastaggedancestor($d)]} {
8095                     incr nc
8096                 }
8097             }
8098         }
8099     }
8100     set tags {}
8101     foreach id [array names tagloc] {
8102         if {![info exists hastaggedancestor($id)]} {
8103             foreach t $tagloc($id) {
8104                 if {[lsearch -exact $tags $t] < 0} {
8105                     lappend tags $t
8106                 }
8107             }
8108         }
8109     }
8110     set t2 [clock clicks -milliseconds]
8111     set loopix $i
8113     # remove tags that are descendents of other tags
8114     for {set i 0} {$i < [llength $tags]} {incr i} {
8115         set a [lindex $tags $i]
8116         for {set j 0} {$j < $i} {incr j} {
8117             set b [lindex $tags $j]
8118             set r [anc_or_desc $a $b]
8119             if {$r == 1} {
8120                 set tags [lreplace $tags $j $j]
8121                 incr j -1
8122                 incr i -1
8123             } elseif {$r == -1} {
8124                 set tags [lreplace $tags $i $i]
8125                 incr i -1
8126                 break
8127             }
8128         }
8129     }
8131     if {[array names growing] ne {}} {
8132         # graph isn't finished, need to check if any tag could get
8133         # eclipsed by another tag coming later.  Simply ignore any
8134         # tags that could later get eclipsed.
8135         set ctags {}
8136         foreach t $tags {
8137             if {[is_certain $t $origid]} {
8138                 lappend ctags $t
8139             }
8140         }
8141         if {$tags eq $ctags} {
8142             set cached_dtags($origid) $tags
8143         } else {
8144             set tags $ctags
8145         }
8146     } else {
8147         set cached_dtags($origid) $tags
8148     }
8149     set t3 [clock clicks -milliseconds]
8150     if {0 && $t3 - $t1 >= 100} {
8151         puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8152             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8153     }
8154     return $tags
8157 proc anctags {id} {
8158     global arcnos arcids arcout arcend arctags idtags allparents
8159     global growing cached_atags
8161     if {![info exists allparents($id)]} {
8162         return {}
8163     }
8164     set t1 [clock clicks -milliseconds]
8165     set argid $id
8166     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8167         # part-way along an arc; check that arc first
8168         set a [lindex $arcnos($id) 0]
8169         if {$arctags($a) ne {}} {
8170             validate_arctags $a
8171             set i [lsearch -exact $arcids($a) $id]
8172             foreach t $arctags($a) {
8173                 set j [lsearch -exact $arcids($a) $t]
8174                 if {$j > $i} {
8175                     return $t
8176                 }
8177             }
8178         }
8179         if {![info exists arcend($a)]} {
8180             return {}
8181         }
8182         set id $arcend($a)
8183         if {[info exists idtags($id)]} {
8184             return $id
8185         }
8186     }
8187     if {[info exists cached_atags($id)]} {
8188         return $cached_atags($id)
8189     }
8191     set origid $id
8192     set todo [list $id]
8193     set queued($id) 1
8194     set taglist {}
8195     set nc 1
8196     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8197         set id [lindex $todo $i]
8198         set done($id) 1
8199         set td [info exists hastaggeddescendent($id)]
8200         if {!$td} {
8201             incr nc -1
8202         }
8203         # ignore tags on starting node
8204         if {!$td && $i > 0} {
8205             if {[info exists idtags($id)]} {
8206                 set tagloc($id) $id
8207                 set td 1
8208             } elseif {[info exists cached_atags($id)]} {
8209                 set tagloc($id) $cached_atags($id)
8210                 set td 1
8211             }
8212         }
8213         foreach a $arcout($id) {
8214             if {!$td && $arctags($a) ne {}} {
8215                 validate_arctags $a
8216                 if {$arctags($a) ne {}} {
8217                     lappend tagloc($id) [lindex $arctags($a) 0]
8218                 }
8219             }
8220             if {![info exists arcend($a)]} continue
8221             set d $arcend($a)
8222             if {$td || $arctags($a) ne {}} {
8223                 set tomark [list $d]
8224                 for {set j 0} {$j < [llength $tomark]} {incr j} {
8225                     set dd [lindex $tomark $j]
8226                     if {![info exists hastaggeddescendent($dd)]} {
8227                         if {[info exists done($dd)]} {
8228                             foreach b $arcout($dd) {
8229                                 if {[info exists arcend($b)]} {
8230                                     lappend tomark $arcend($b)
8231                                 }
8232                             }
8233                             if {[info exists tagloc($dd)]} {
8234                                 unset tagloc($dd)
8235                             }
8236                         } elseif {[info exists queued($dd)]} {
8237                             incr nc -1
8238                         }
8239                         set hastaggeddescendent($dd) 1
8240                     }
8241                 }
8242             }
8243             if {![info exists queued($d)]} {
8244                 lappend todo $d
8245                 set queued($d) 1
8246                 if {![info exists hastaggeddescendent($d)]} {
8247                     incr nc
8248                 }
8249             }
8250         }
8251     }
8252     set t2 [clock clicks -milliseconds]
8253     set loopix $i
8254     set tags {}
8255     foreach id [array names tagloc] {
8256         if {![info exists hastaggeddescendent($id)]} {
8257             foreach t $tagloc($id) {
8258                 if {[lsearch -exact $tags $t] < 0} {
8259                     lappend tags $t
8260                 }
8261             }
8262         }
8263     }
8265     # remove tags that are ancestors of other tags
8266     for {set i 0} {$i < [llength $tags]} {incr i} {
8267         set a [lindex $tags $i]
8268         for {set j 0} {$j < $i} {incr j} {
8269             set b [lindex $tags $j]
8270             set r [anc_or_desc $a $b]
8271             if {$r == -1} {
8272                 set tags [lreplace $tags $j $j]
8273                 incr j -1
8274                 incr i -1
8275             } elseif {$r == 1} {
8276                 set tags [lreplace $tags $i $i]
8277                 incr i -1
8278                 break
8279             }
8280         }
8281     }
8283     if {[array names growing] ne {}} {
8284         # graph isn't finished, need to check if any tag could get
8285         # eclipsed by another tag coming later.  Simply ignore any
8286         # tags that could later get eclipsed.
8287         set ctags {}
8288         foreach t $tags {
8289             if {[is_certain $origid $t]} {
8290                 lappend ctags $t
8291             }
8292         }
8293         if {$tags eq $ctags} {
8294             set cached_atags($origid) $tags
8295         } else {
8296             set tags $ctags
8297         }
8298     } else {
8299         set cached_atags($origid) $tags
8300     }
8301     set t3 [clock clicks -milliseconds]
8302     if {0 && $t3 - $t1 >= 100} {
8303         puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8304             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8305     }
8306     return $tags
8309 # Return the list of IDs that have heads that are descendents of id,
8310 # including id itself if it has a head.
8311 proc descheads {id} {
8312     global arcnos arcstart arcids archeads idheads cached_dheads
8313     global allparents
8315     if {![info exists allparents($id)]} {
8316         return {}
8317     }
8318     set aret {}
8319     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8320         # part-way along an arc; check it first
8321         set a [lindex $arcnos($id) 0]
8322         if {$archeads($a) ne {}} {
8323             validate_archeads $a
8324             set i [lsearch -exact $arcids($a) $id]
8325             foreach t $archeads($a) {
8326                 set j [lsearch -exact $arcids($a) $t]
8327                 if {$j > $i} break
8328                 lappend aret $t
8329             }
8330         }
8331         set id $arcstart($a)
8332     }
8333     set origid $id
8334     set todo [list $id]
8335     set seen($id) 1
8336     set ret {}
8337     for {set i 0} {$i < [llength $todo]} {incr i} {
8338         set id [lindex $todo $i]
8339         if {[info exists cached_dheads($id)]} {
8340             set ret [concat $ret $cached_dheads($id)]
8341         } else {
8342             if {[info exists idheads($id)]} {
8343                 lappend ret $id
8344             }
8345             foreach a $arcnos($id) {
8346                 if {$archeads($a) ne {}} {
8347                     validate_archeads $a
8348                     if {$archeads($a) ne {}} {
8349                         set ret [concat $ret $archeads($a)]
8350                     }
8351                 }
8352                 set d $arcstart($a)
8353                 if {![info exists seen($d)]} {
8354                     lappend todo $d
8355                     set seen($d) 1
8356                 }
8357             }
8358         }
8359     }
8360     set ret [lsort -unique $ret]
8361     set cached_dheads($origid) $ret
8362     return [concat $ret $aret]
8365 proc addedtag {id} {
8366     global arcnos arcout cached_dtags cached_atags
8368     if {![info exists arcnos($id)]} return
8369     if {![info exists arcout($id)]} {
8370         recalcarc [lindex $arcnos($id) 0]
8371     }
8372     catch {unset cached_dtags}
8373     catch {unset cached_atags}
8376 proc addedhead {hid head} {
8377     global arcnos arcout cached_dheads
8379     if {![info exists arcnos($hid)]} return
8380     if {![info exists arcout($hid)]} {
8381         recalcarc [lindex $arcnos($hid) 0]
8382     }
8383     catch {unset cached_dheads}
8386 proc removedhead {hid head} {
8387     global cached_dheads
8389     catch {unset cached_dheads}
8392 proc movedhead {hid head} {
8393     global arcnos arcout cached_dheads
8395     if {![info exists arcnos($hid)]} return
8396     if {![info exists arcout($hid)]} {
8397         recalcarc [lindex $arcnos($hid) 0]
8398     }
8399     catch {unset cached_dheads}
8402 proc changedrefs {} {
8403     global cached_dheads cached_dtags cached_atags
8404     global arctags archeads arcnos arcout idheads idtags
8406     foreach id [concat [array names idheads] [array names idtags]] {
8407         if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8408             set a [lindex $arcnos($id) 0]
8409             if {![info exists donearc($a)]} {
8410                 recalcarc $a
8411                 set donearc($a) 1
8412             }
8413         }
8414     }
8415     catch {unset cached_dtags}
8416     catch {unset cached_atags}
8417     catch {unset cached_dheads}
8420 proc rereadrefs {} {
8421     global idtags idheads idotherrefs mainheadid
8423     set refids [concat [array names idtags] \
8424                     [array names idheads] [array names idotherrefs]]
8425     foreach id $refids {
8426         if {![info exists ref($id)]} {
8427             set ref($id) [listrefs $id]
8428         }
8429     }
8430     set oldmainhead $mainheadid
8431     readrefs
8432     changedrefs
8433     set refids [lsort -unique [concat $refids [array names idtags] \
8434                         [array names idheads] [array names idotherrefs]]]
8435     foreach id $refids {
8436         set v [listrefs $id]
8437         if {![info exists ref($id)] || $ref($id) != $v ||
8438             ($id eq $oldmainhead && $id ne $mainheadid) ||
8439             ($id eq $mainheadid && $id ne $oldmainhead)} {
8440             redrawtags $id
8441         }
8442     }
8443     run refill_reflist
8446 proc listrefs {id} {
8447     global idtags idheads idotherrefs
8449     set x {}
8450     if {[info exists idtags($id)]} {
8451         set x $idtags($id)
8452     }
8453     set y {}
8454     if {[info exists idheads($id)]} {
8455         set y $idheads($id)
8456     }
8457     set z {}
8458     if {[info exists idotherrefs($id)]} {
8459         set z $idotherrefs($id)
8460     }
8461     return [list $x $y $z]
8464 proc showtag {tag isnew} {
8465     global ctext tagcontents tagids linknum tagobjid
8467     if {$isnew} {
8468         addtohistory [list showtag $tag 0]
8469     }
8470     $ctext conf -state normal
8471     clear_ctext
8472     settabs 0
8473     set linknum 0
8474     if {![info exists tagcontents($tag)]} {
8475         catch {
8476             set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8477         }
8478     }
8479     if {[info exists tagcontents($tag)]} {
8480         set text $tagcontents($tag)
8481     } else {
8482         set text "[mc "Tag"]: $tag\n[mc "Id"]:  $tagids($tag)"
8483     }
8484     appendwithlinks $text {}
8485     $ctext conf -state disabled
8486     init_flist {}
8489 proc doquit {} {
8490     global stopped
8491     set stopped 100
8492     savestuff .
8493     destroy .
8496 proc mkfontdisp {font top which} {
8497     global fontattr fontpref $font
8499     set fontpref($font) [set $font]
8500     button $top.${font}but -text $which -font optionfont \
8501         -command [list choosefont $font $which]
8502     label $top.$font -relief flat -font $font \
8503         -text $fontattr($font,family) -justify left
8504     grid x $top.${font}but $top.$font -sticky w
8507 proc choosefont {font which} {
8508     global fontparam fontlist fonttop fontattr
8510     set fontparam(which) $which
8511     set fontparam(font) $font
8512     set fontparam(family) [font actual $font -family]
8513     set fontparam(size) $fontattr($font,size)
8514     set fontparam(weight) $fontattr($font,weight)
8515     set fontparam(slant) $fontattr($font,slant)
8516     set top .gitkfont
8517     set fonttop $top
8518     if {![winfo exists $top]} {
8519         font create sample
8520         eval font config sample [font actual $font]
8521         toplevel $top
8522         wm title $top [mc "Gitk font chooser"]
8523         label $top.l -textvariable fontparam(which) -font uifont
8524         pack $top.l -side top
8525         set fontlist [lsort [font families]]
8526         frame $top.f
8527         listbox $top.f.fam -listvariable fontlist \
8528             -yscrollcommand [list $top.f.sb set]
8529         bind $top.f.fam <<ListboxSelect>> selfontfam
8530         scrollbar $top.f.sb -command [list $top.f.fam yview]
8531         pack $top.f.sb -side right -fill y
8532         pack $top.f.fam -side left -fill both -expand 1
8533         pack $top.f -side top -fill both -expand 1
8534         frame $top.g
8535         spinbox $top.g.size -from 4 -to 40 -width 4 \
8536             -textvariable fontparam(size) \
8537             -validatecommand {string is integer -strict %s}
8538         checkbutton $top.g.bold -padx 5 \
8539             -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8540             -variable fontparam(weight) -onvalue bold -offvalue normal
8541         checkbutton $top.g.ital -padx 5 \
8542             -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0  \
8543             -variable fontparam(slant) -onvalue italic -offvalue roman
8544         pack $top.g.size $top.g.bold $top.g.ital -side left
8545         pack $top.g -side top
8546         canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8547             -background white
8548         $top.c create text 100 25 -anchor center -text $which -font sample \
8549             -fill black -tags text
8550         bind $top.c <Configure> [list centertext $top.c]
8551         pack $top.c -side top -fill x
8552         frame $top.buts
8553         button $top.buts.ok -text [mc "OK"] -command fontok -default active \
8554             -font uifont
8555         button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal \
8556             -font uifont
8557         grid $top.buts.ok $top.buts.can
8558         grid columnconfigure $top.buts 0 -weight 1 -uniform a
8559         grid columnconfigure $top.buts 1 -weight 1 -uniform a
8560         pack $top.buts -side bottom -fill x
8561         trace add variable fontparam write chg_fontparam
8562     } else {
8563         raise $top
8564         $top.c itemconf text -text $which
8565     }
8566     set i [lsearch -exact $fontlist $fontparam(family)]
8567     if {$i >= 0} {
8568         $top.f.fam selection set $i
8569         $top.f.fam see $i
8570     }
8573 proc centertext {w} {
8574     $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8577 proc fontok {} {
8578     global fontparam fontpref prefstop
8580     set f $fontparam(font)
8581     set fontpref($f) [list $fontparam(family) $fontparam(size)]
8582     if {$fontparam(weight) eq "bold"} {
8583         lappend fontpref($f) "bold"
8584     }
8585     if {$fontparam(slant) eq "italic"} {
8586         lappend fontpref($f) "italic"
8587     }
8588     set w $prefstop.$f
8589     $w conf -text $fontparam(family) -font $fontpref($f)
8590         
8591     fontcan
8594 proc fontcan {} {
8595     global fonttop fontparam
8597     if {[info exists fonttop]} {
8598         catch {destroy $fonttop}
8599         catch {font delete sample}
8600         unset fonttop
8601         unset fontparam
8602     }
8605 proc selfontfam {} {
8606     global fonttop fontparam
8608     set i [$fonttop.f.fam curselection]
8609     if {$i ne {}} {
8610         set fontparam(family) [$fonttop.f.fam get $i]
8611     }
8614 proc chg_fontparam {v sub op} {
8615     global fontparam
8617     font config sample -$sub $fontparam($sub)
8620 proc doprefs {} {
8621     global maxwidth maxgraphpct
8622     global oldprefs prefstop showneartags showlocalchanges
8623     global bgcolor fgcolor ctext diffcolors selectbgcolor
8624     global uifont tabstop limitdiffs
8626     set top .gitkprefs
8627     set prefstop $top
8628     if {[winfo exists $top]} {
8629         raise $top
8630         return
8631     }
8632     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8633                    limitdiffs tabstop} {
8634         set oldprefs($v) [set $v]
8635     }
8636     toplevel $top
8637     wm title $top [mc "Gitk preferences"]
8638     label $top.ldisp -text [mc "Commit list display options"]
8639     $top.ldisp configure -font uifont
8640     grid $top.ldisp - -sticky w -pady 10
8641     label $top.spacer -text " "
8642     label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8643         -font optionfont
8644     spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8645     grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8646     label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8647         -font optionfont
8648     spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8649     grid x $top.maxpctl $top.maxpct -sticky w
8650     frame $top.showlocal
8651     label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8652     checkbutton $top.showlocal.b -variable showlocalchanges
8653     pack $top.showlocal.b $top.showlocal.l -side left
8654     grid x $top.showlocal -sticky w
8656     label $top.ddisp -text [mc "Diff display options"]
8657     $top.ddisp configure -font uifont
8658     grid $top.ddisp - -sticky w -pady 10
8659     label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8660     spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8661     grid x $top.tabstopl $top.tabstop -sticky w
8662     frame $top.ntag
8663     label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8664     checkbutton $top.ntag.b -variable showneartags
8665     pack $top.ntag.b $top.ntag.l -side left
8666     grid x $top.ntag -sticky w
8667     frame $top.ldiff
8668     label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8669     checkbutton $top.ldiff.b -variable limitdiffs
8670     pack $top.ldiff.b $top.ldiff.l -side left
8671     grid x $top.ldiff -sticky w
8673     label $top.cdisp -text [mc "Colors: press to choose"]
8674     $top.cdisp configure -font uifont
8675     grid $top.cdisp - -sticky w -pady 10
8676     label $top.bg -padx 40 -relief sunk -background $bgcolor
8677     button $top.bgbut -text [mc "Background"] -font optionfont \
8678         -command [list choosecolor bgcolor 0 $top.bg background setbg]
8679     grid x $top.bgbut $top.bg -sticky w
8680     label $top.fg -padx 40 -relief sunk -background $fgcolor
8681     button $top.fgbut -text [mc "Foreground"] -font optionfont \
8682         -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8683     grid x $top.fgbut $top.fg -sticky w
8684     label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8685     button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8686         -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8687                       [list $ctext tag conf d0 -foreground]]
8688     grid x $top.diffoldbut $top.diffold -sticky w
8689     label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8690     button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8691         -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8692                       [list $ctext tag conf d1 -foreground]]
8693     grid x $top.diffnewbut $top.diffnew -sticky w
8694     label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8695     button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8696         -command [list choosecolor diffcolors 2 $top.hunksep \
8697                       "diff hunk header" \
8698                       [list $ctext tag conf hunksep -foreground]]
8699     grid x $top.hunksepbut $top.hunksep -sticky w
8700     label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8701     button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8702         -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8703     grid x $top.selbgbut $top.selbgsep -sticky w
8705     label $top.cfont -text [mc "Fonts: press to choose"]
8706     $top.cfont configure -font uifont
8707     grid $top.cfont - -sticky w -pady 10
8708     mkfontdisp mainfont $top [mc "Main font"]
8709     mkfontdisp textfont $top [mc "Diff display font"]
8710     mkfontdisp uifont $top [mc "User interface font"]
8712     frame $top.buts
8713     button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8714     $top.buts.ok configure -font uifont
8715     button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8716     $top.buts.can configure -font uifont
8717     grid $top.buts.ok $top.buts.can
8718     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8719     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8720     grid $top.buts - - -pady 10 -sticky ew
8721     bind $top <Visibility> "focus $top.buts.ok"
8724 proc choosecolor {v vi w x cmd} {
8725     global $v
8727     set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8728                -title [mc "Gitk: choose color for %s" $x]]
8729     if {$c eq {}} return
8730     $w conf -background $c
8731     lset $v $vi $c
8732     eval $cmd $c
8735 proc setselbg {c} {
8736     global bglist cflist
8737     foreach w $bglist {
8738         $w configure -selectbackground $c
8739     }
8740     $cflist tag configure highlight \
8741         -background [$cflist cget -selectbackground]
8742     allcanvs itemconf secsel -fill $c
8745 proc setbg {c} {
8746     global bglist
8748     foreach w $bglist {
8749         $w conf -background $c
8750     }
8753 proc setfg {c} {
8754     global fglist canv
8756     foreach w $fglist {
8757         $w conf -foreground $c
8758     }
8759     allcanvs itemconf text -fill $c
8760     $canv itemconf circle -outline $c
8763 proc prefscan {} {
8764     global oldprefs prefstop
8766     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8767                    limitdiffs tabstop} {
8768         global $v
8769         set $v $oldprefs($v)
8770     }
8771     catch {destroy $prefstop}
8772     unset prefstop
8773     fontcan
8776 proc prefsok {} {
8777     global maxwidth maxgraphpct
8778     global oldprefs prefstop showneartags showlocalchanges
8779     global fontpref mainfont textfont uifont
8780     global limitdiffs treediffs
8782     catch {destroy $prefstop}
8783     unset prefstop
8784     fontcan
8785     set fontchanged 0
8786     if {$mainfont ne $fontpref(mainfont)} {
8787         set mainfont $fontpref(mainfont)
8788         parsefont mainfont $mainfont
8789         eval font configure mainfont [fontflags mainfont]
8790         eval font configure mainfontbold [fontflags mainfont 1]
8791         setcoords
8792         set fontchanged 1
8793     }
8794     if {$textfont ne $fontpref(textfont)} {
8795         set textfont $fontpref(textfont)
8796         parsefont textfont $textfont
8797         eval font configure textfont [fontflags textfont]
8798         eval font configure textfontbold [fontflags textfont 1]
8799     }
8800     if {$uifont ne $fontpref(uifont)} {
8801         set uifont $fontpref(uifont)
8802         parsefont uifont $uifont
8803         eval font configure uifont [fontflags uifont]
8804     }
8805     settabs
8806     if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8807         if {$showlocalchanges} {
8808             doshowlocalchanges
8809         } else {
8810             dohidelocalchanges
8811         }
8812     }
8813     if {$limitdiffs != $oldprefs(limitdiffs)} {
8814         # treediffs elements are limited by path
8815         catch {unset treediffs}
8816     }
8817     if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8818         || $maxgraphpct != $oldprefs(maxgraphpct)} {
8819         redisplay
8820     } elseif {$showneartags != $oldprefs(showneartags) ||
8821           $limitdiffs != $oldprefs(limitdiffs)} {
8822         reselectline
8823     }
8826 proc formatdate {d} {
8827     global datetimeformat
8828     if {$d ne {}} {
8829         set d [clock format $d -format $datetimeformat]
8830     }
8831     return $d
8834 # This list of encoding names and aliases is distilled from
8835 # http://www.iana.org/assignments/character-sets.
8836 # Not all of them are supported by Tcl.
8837 set encoding_aliases {
8838     { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8839       ISO646-US US-ASCII us IBM367 cp367 csASCII }
8840     { ISO-10646-UTF-1 csISO10646UTF1 }
8841     { ISO_646.basic:1983 ref csISO646basic1983 }
8842     { INVARIANT csINVARIANT }
8843     { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8844     { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8845     { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8846     { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8847     { NATS-DANO iso-ir-9-1 csNATSDANO }
8848     { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8849     { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8850     { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8851     { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8852     { ISO-2022-KR csISO2022KR }
8853     { EUC-KR csEUCKR }
8854     { ISO-2022-JP csISO2022JP }
8855     { ISO-2022-JP-2 csISO2022JP2 }
8856     { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8857       csISO13JISC6220jp }
8858     { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8859     { IT iso-ir-15 ISO646-IT csISO15Italian }
8860     { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8861     { ES iso-ir-17 ISO646-ES csISO17Spanish }
8862     { greek7-old iso-ir-18 csISO18Greek7Old }
8863     { latin-greek iso-ir-19 csISO19LatinGreek }
8864     { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8865     { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8866     { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8867     { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8868     { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8869     { BS_viewdata iso-ir-47 csISO47BSViewdata }
8870     { INIS iso-ir-49 csISO49INIS }
8871     { INIS-8 iso-ir-50 csISO50INIS8 }
8872     { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8873     { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8874     { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8875     { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8876     { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8877     { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8878       csISO60Norwegian1 }
8879     { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8880     { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8881     { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8882     { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8883     { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8884     { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8885     { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8886     { greek7 iso-ir-88 csISO88Greek7 }
8887     { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8888     { iso-ir-90 csISO90 }
8889     { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8890     { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8891       csISO92JISC62991984b }
8892     { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8893     { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8894     { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8895       csISO95JIS62291984handadd }
8896     { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8897     { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8898     { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8899     { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8900       CP819 csISOLatin1 }
8901     { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8902     { T.61-7bit iso-ir-102 csISO102T617bit }
8903     { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8904     { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8905     { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8906     { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8907     { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8908     { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8909     { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8910     { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8911       arabic csISOLatinArabic }
8912     { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8913     { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8914     { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8915       greek greek8 csISOLatinGreek }
8916     { T.101-G2 iso-ir-128 csISO128T101G2 }
8917     { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8918       csISOLatinHebrew }
8919     { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8920     { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8921     { CSN_369103 iso-ir-139 csISO139CSN369103 }
8922     { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8923     { ISO_6937-2-add iso-ir-142 csISOTextComm }
8924     { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8925     { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8926       csISOLatinCyrillic }
8927     { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8928     { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8929     { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8930     { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8931     { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8932     { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8933     { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8934     { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8935     { ISO_10367-box iso-ir-155 csISO10367Box }
8936     { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8937     { latin-lap lap iso-ir-158 csISO158Lap }
8938     { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8939     { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8940     { us-dk csUSDK }
8941     { dk-us csDKUS }
8942     { JIS_X0201 X0201 csHalfWidthKatakana }
8943     { KSC5636 ISO646-KR csKSC5636 }
8944     { ISO-10646-UCS-2 csUnicode }
8945     { ISO-10646-UCS-4 csUCS4 }
8946     { DEC-MCS dec csDECMCS }
8947     { hp-roman8 roman8 r8 csHPRoman8 }
8948     { macintosh mac csMacintosh }
8949     { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8950       csIBM037 }
8951     { IBM038 EBCDIC-INT cp038 csIBM038 }
8952     { IBM273 CP273 csIBM273 }
8953     { IBM274 EBCDIC-BE CP274 csIBM274 }
8954     { IBM275 EBCDIC-BR cp275 csIBM275 }
8955     { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8956     { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8957     { IBM280 CP280 ebcdic-cp-it csIBM280 }
8958     { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8959     { IBM284 CP284 ebcdic-cp-es csIBM284 }
8960     { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8961     { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8962     { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8963     { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8964     { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8965     { IBM424 cp424 ebcdic-cp-he csIBM424 }
8966     { IBM437 cp437 437 csPC8CodePage437 }
8967     { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8968     { IBM775 cp775 csPC775Baltic }
8969     { IBM850 cp850 850 csPC850Multilingual }
8970     { IBM851 cp851 851 csIBM851 }
8971     { IBM852 cp852 852 csPCp852 }
8972     { IBM855 cp855 855 csIBM855 }
8973     { IBM857 cp857 857 csIBM857 }
8974     { IBM860 cp860 860 csIBM860 }
8975     { IBM861 cp861 861 cp-is csIBM861 }
8976     { IBM862 cp862 862 csPC862LatinHebrew }
8977     { IBM863 cp863 863 csIBM863 }
8978     { IBM864 cp864 csIBM864 }
8979     { IBM865 cp865 865 csIBM865 }
8980     { IBM866 cp866 866 csIBM866 }
8981     { IBM868 CP868 cp-ar csIBM868 }
8982     { IBM869 cp869 869 cp-gr csIBM869 }
8983     { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8984     { IBM871 CP871 ebcdic-cp-is csIBM871 }
8985     { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8986     { IBM891 cp891 csIBM891 }
8987     { IBM903 cp903 csIBM903 }
8988     { IBM904 cp904 904 csIBBM904 }
8989     { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8990     { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8991     { IBM1026 CP1026 csIBM1026 }
8992     { EBCDIC-AT-DE csIBMEBCDICATDE }
8993     { EBCDIC-AT-DE-A csEBCDICATDEA }
8994     { EBCDIC-CA-FR csEBCDICCAFR }
8995     { EBCDIC-DK-NO csEBCDICDKNO }
8996     { EBCDIC-DK-NO-A csEBCDICDKNOA }
8997     { EBCDIC-FI-SE csEBCDICFISE }
8998     { EBCDIC-FI-SE-A csEBCDICFISEA }
8999     { EBCDIC-FR csEBCDICFR }
9000     { EBCDIC-IT csEBCDICIT }
9001     { EBCDIC-PT csEBCDICPT }
9002     { EBCDIC-ES csEBCDICES }
9003     { EBCDIC-ES-A csEBCDICESA }
9004     { EBCDIC-ES-S csEBCDICESS }
9005     { EBCDIC-UK csEBCDICUK }
9006     { EBCDIC-US csEBCDICUS }
9007     { UNKNOWN-8BIT csUnknown8BiT }
9008     { MNEMONIC csMnemonic }
9009     { MNEM csMnem }
9010     { VISCII csVISCII }
9011     { VIQR csVIQR }
9012     { KOI8-R csKOI8R }
9013     { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9014     { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9015     { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9016     { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9017     { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9018     { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9019     { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9020     { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9021     { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9022     { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9023     { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9024     { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9025     { IBM1047 IBM-1047 }
9026     { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9027     { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9028     { UNICODE-1-1 csUnicode11 }
9029     { CESU-8 csCESU-8 }
9030     { BOCU-1 csBOCU-1 }
9031     { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9032     { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9033       l8 }
9034     { ISO-8859-15 ISO_8859-15 Latin-9 }
9035     { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9036     { GBK CP936 MS936 windows-936 }
9037     { JIS_Encoding csJISEncoding }
9038     { Shift_JIS MS_Kanji csShiftJIS }
9039     { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9040       EUC-JP }
9041     { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9042     { ISO-10646-UCS-Basic csUnicodeASCII }
9043     { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9044     { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9045     { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9046     { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9047     { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9048     { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9049     { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9050     { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9051     { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9052     { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9053     { Adobe-Standard-Encoding csAdobeStandardEncoding }
9054     { Ventura-US csVenturaUS }
9055     { Ventura-International csVenturaInternational }
9056     { PC8-Danish-Norwegian csPC8DanishNorwegian }
9057     { PC8-Turkish csPC8Turkish }
9058     { IBM-Symbols csIBMSymbols }
9059     { IBM-Thai csIBMThai }
9060     { HP-Legal csHPLegal }
9061     { HP-Pi-font csHPPiFont }
9062     { HP-Math8 csHPMath8 }
9063     { Adobe-Symbol-Encoding csHPPSMath }
9064     { HP-DeskTop csHPDesktop }
9065     { Ventura-Math csVenturaMath }
9066     { Microsoft-Publishing csMicrosoftPublishing }
9067     { Windows-31J csWindows31J }
9068     { GB2312 csGB2312 }
9069     { Big5 csBig5 }
9072 proc tcl_encoding {enc} {
9073     global encoding_aliases
9074     set names [encoding names]
9075     set lcnames [string tolower $names]
9076     set enc [string tolower $enc]
9077     set i [lsearch -exact $lcnames $enc]
9078     if {$i < 0} {
9079         # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9080         if {[regsub {^iso[-_]} $enc iso encx]} {
9081             set i [lsearch -exact $lcnames $encx]
9082         }
9083     }
9084     if {$i < 0} {
9085         foreach l $encoding_aliases {
9086             set ll [string tolower $l]
9087             if {[lsearch -exact $ll $enc] < 0} continue
9088             # look through the aliases for one that tcl knows about
9089             foreach e $ll {
9090                 set i [lsearch -exact $lcnames $e]
9091                 if {$i < 0} {
9092                     if {[regsub {^iso[-_]} $e iso ex]} {
9093                         set i [lsearch -exact $lcnames $ex]
9094                     }
9095                 }
9096                 if {$i >= 0} break
9097             }
9098             break
9099         }
9100     }
9101     if {$i >= 0} {
9102         return [lindex $names $i]
9103     }
9104     return {}
9107 # First check that Tcl/Tk is recent enough
9108 if {[catch {package require Tk 8.4} err]} {
9109     show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9110                      Gitk requires at least Tcl/Tk 8.4."]
9111     exit 1
9114 # defaults...
9115 set datemode 0
9116 set wrcomcmd "git diff-tree --stdin -p --pretty"
9118 set gitencoding {}
9119 catch {
9120     set gitencoding [exec git config --get i18n.commitencoding]
9122 if {$gitencoding == ""} {
9123     set gitencoding "utf-8"
9125 set tclencoding [tcl_encoding $gitencoding]
9126 if {$tclencoding == {}} {
9127     puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9130 set mainfont {Helvetica 9}
9131 set textfont {Courier 9}
9132 set uifont {Helvetica 9 bold}
9133 set tabstop 8
9134 set findmergefiles 0
9135 set maxgraphpct 50
9136 set maxwidth 16
9137 set revlistorder 0
9138 set fastdate 0
9139 set uparrowlen 5
9140 set downarrowlen 5
9141 set mingaplen 100
9142 set cmitmode "patch"
9143 set wrapcomment "none"
9144 set showneartags 1
9145 set maxrefs 20
9146 set maxlinelen 200
9147 set showlocalchanges 1
9148 set limitdiffs 1
9149 set datetimeformat "%Y-%m-%d %H:%M:%S"
9151 set colors {green red blue magenta darkgrey brown orange}
9152 set bgcolor white
9153 set fgcolor black
9154 set diffcolors {red "#00a000" blue}
9155 set diffcontext 3
9156 set selectbgcolor gray85
9158 ## For msgcat loading, first locate the installation location.
9159 if { [info exists ::env(GITK_MSGSDIR)] } {
9160     ## Msgsdir was manually set in the environment.
9161     set gitk_msgsdir $::env(GITK_MSGSDIR)
9162 } else {
9163     ## Let's guess the prefix from argv0.
9164     set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9165     set gitk_libdir [file join $gitk_prefix share gitk lib]
9166     set gitk_msgsdir [file join $gitk_libdir msgs]
9167     unset gitk_prefix
9170 ## Internationalization (i18n) through msgcat and gettext. See
9171 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9172 package require msgcat
9173 namespace import ::msgcat::mc
9174 ## And eventually load the actual message catalog
9175 ::msgcat::mcload $gitk_msgsdir
9177 catch {source ~/.gitk}
9179 font create optionfont -family sans-serif -size -12
9181 parsefont mainfont $mainfont
9182 eval font create mainfont [fontflags mainfont]
9183 eval font create mainfontbold [fontflags mainfont 1]
9185 parsefont textfont $textfont
9186 eval font create textfont [fontflags textfont]
9187 eval font create textfontbold [fontflags textfont 1]
9189 parsefont uifont $uifont
9190 eval font create uifont [fontflags uifont]
9192 # check that we can find a .git directory somewhere...
9193 if {[catch {set gitdir [gitdir]}]} {
9194     show_error {} . [mc "Cannot find a git repository here."]
9195     exit 1
9197 if {![file isdirectory $gitdir]} {
9198     show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
9199     exit 1
9202 set mergeonly 0
9203 set revtreeargs {}
9204 set cmdline_files {}
9205 set i 0
9206 foreach arg $argv {
9207     switch -- $arg {
9208         "" { }
9209         "-d" { set datemode 1 }
9210         "--merge" {
9211             set mergeonly 1
9212             lappend revtreeargs $arg
9213         }
9214         "--" {
9215             set cmdline_files [lrange $argv [expr {$i + 1}] end]
9216             break
9217         }
9218         default {
9219             lappend revtreeargs $arg
9220         }
9221     }
9222     incr i
9225 if {$i >= [llength $argv] && $revtreeargs ne {}} {
9226     # no -- on command line, but some arguments (other than -d)
9227     if {[catch {
9228         set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9229         set cmdline_files [split $f "\n"]
9230         set n [llength $cmdline_files]
9231         set revtreeargs [lrange $revtreeargs 0 end-$n]
9232         # Unfortunately git rev-parse doesn't produce an error when
9233         # something is both a revision and a filename.  To be consistent
9234         # with git log and git rev-list, check revtreeargs for filenames.
9235         foreach arg $revtreeargs {
9236             if {[file exists $arg]} {
9237                 show_error {} . [mc "Ambiguous argument '%s': both revision\
9238                                  and filename" $arg]
9239                 exit 1
9240             }
9241         }
9242     } err]} {
9243         # unfortunately we get both stdout and stderr in $err,
9244         # so look for "fatal:".
9245         set i [string first "fatal:" $err]
9246         if {$i > 0} {
9247             set err [string range $err [expr {$i + 6}] end]
9248         }
9249         show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
9250         exit 1
9251     }
9254 if {$mergeonly} {
9255     # find the list of unmerged files
9256     set mlist {}
9257     set nr_unmerged 0
9258     if {[catch {
9259         set fd [open "| git ls-files -u" r]
9260     } err]} {
9261         show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
9262         exit 1
9263     }
9264     while {[gets $fd line] >= 0} {
9265         set i [string first "\t" $line]
9266         if {$i < 0} continue
9267         set fname [string range $line [expr {$i+1}] end]
9268         if {[lsearch -exact $mlist $fname] >= 0} continue
9269         incr nr_unmerged
9270         if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9271             lappend mlist $fname
9272         }
9273     }
9274     catch {close $fd}
9275     if {$mlist eq {}} {
9276         if {$nr_unmerged == 0} {
9277             show_error {} . [mc "No files selected: --merge specified but\
9278                              no files are unmerged."]
9279         } else {
9280             show_error {} . [mc "No files selected: --merge specified but\
9281                              no unmerged files are within file limit."]
9282         }
9283         exit 1
9284     }
9285     set cmdline_files $mlist
9288 set nullid "0000000000000000000000000000000000000000"
9289 set nullid2 "0000000000000000000000000000000000000001"
9291 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9293 set runq {}
9294 set history {}
9295 set historyindex 0
9296 set fh_serial 0
9297 set nhl_names {}
9298 set highlight_paths {}
9299 set findpattern {}
9300 set searchdirn -forwards
9301 set boldrows {}
9302 set boldnamerows {}
9303 set diffelide {0 0}
9304 set markingmatches 0
9305 set linkentercount 0
9306 set need_redisplay 0
9307 set nrows_drawn 0
9308 set firsttabstop 0
9310 set nextviewnum 1
9311 set curview 0
9312 set selectedview 0
9313 set selectedhlview [mc "None"]
9314 set highlight_related [mc "None"]
9315 set highlight_files {}
9316 set viewfiles(0) {}
9317 set viewperm(0) 0
9318 set viewargs(0) {}
9320 set loginstance 0
9321 set cmdlineok 0
9322 set stopped 0
9323 set stuffsaved 0
9324 set patchnum 0
9325 set lserial 0
9326 setcoords
9327 makewindow
9328 # wait for the window to become visible
9329 tkwait visibility .
9330 wm title . "[file tail $argv0]: [file tail [pwd]]"
9331 readrefs
9333 if {$cmdline_files ne {} || $revtreeargs ne {}} {
9334     # create a view for the files/dirs specified on the command line
9335     set curview 1
9336     set selectedview 1
9337     set nextviewnum 2
9338     set viewname(1) [mc "Command line"]
9339     set viewfiles(1) $cmdline_files
9340     set viewargs(1) $revtreeargs
9341     set viewperm(1) 0
9342     addviewmenu 1
9343     .bar.view entryconf [mc "Edit view..."] -state normal
9344     .bar.view entryconf [mc "Delete view"] -state normal
9347 if {[info exists permviews]} {
9348     foreach v $permviews {
9349         set n $nextviewnum
9350         incr nextviewnum
9351         set viewname($n) [lindex $v 0]
9352         set viewfiles($n) [lindex $v 1]
9353         set viewargs($n) [lindex $v 2]
9354         set viewperm($n) 1
9355         addviewmenu $n
9356     }
9358 getcommits