Code

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