Code

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