Code

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