Code

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