Code

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