Code

gitk: New way of constructing menus that allows for Alt+letter accelerators
[git.git] / gitk
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2008 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 currunq
27     set script $args
28     if {[info exists isonrunq($script)]} return
29     if {$runq eq {} && ![info exists currunq]} {
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 currunq
43     fileevent $fd readable {}
44     if {$runq eq {} && ![info exists currunq]} {
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 currunq
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 currunq [lindex $runq 0]
71         set runq [lrange $runq 1 end]
72         set repeat [eval $script]
73         unset currunq
74         set t1 [clock clicks -milliseconds]
75         set t [expr {$t1 - $t0}]
76         if {$repeat ne {} && $repeat} {
77             if {$fd eq {} || $repeat == 2} {
78                 # script returns 1 if it wants to be readded
79                 # file readers return 2 if they could do more straight away
80                 lappend runq [list $fd $script]
81             } else {
82                 fileevent $fd readable [list filereadable $fd $script]
83             }
84         } elseif {$fd eq {}} {
85             unset isonrunq($script)
86         }
87         set t0 $t1
88         if {$t1 - $tstart >= 80} break
89     }
90     if {$runq ne {}} {
91         after idle dorunq
92     }
93 }
95 proc reg_instance {fd} {
96     global commfd leftover loginstance
98     set i [incr loginstance]
99     set commfd($i) $fd
100     set leftover($i) {}
101     return $i
104 proc unmerged_files {files} {
105     global nr_unmerged
107     # find the list of unmerged files
108     set mlist {}
109     set nr_unmerged 0
110     if {[catch {
111         set fd [open "| git ls-files -u" r]
112     } err]} {
113         show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
114         exit 1
115     }
116     while {[gets $fd line] >= 0} {
117         set i [string first "\t" $line]
118         if {$i < 0} continue
119         set fname [string range $line [expr {$i+1}] end]
120         if {[lsearch -exact $mlist $fname] >= 0} continue
121         incr nr_unmerged
122         if {$files eq {} || [path_filter $files $fname]} {
123             lappend mlist $fname
124         }
125     }
126     catch {close $fd}
127     return $mlist
130 proc parseviewargs {n arglist} {
131     global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
133     set vdatemode($n) 0
134     set vmergeonly($n) 0
135     set glflags {}
136     set diffargs {}
137     set nextisval 0
138     set revargs {}
139     set origargs $arglist
140     set allknown 1
141     set filtered 0
142     set i -1
143     foreach arg $arglist {
144         incr i
145         if {$nextisval} {
146             lappend glflags $arg
147             set nextisval 0
148             continue
149         }
150         switch -glob -- $arg {
151             "-d" -
152             "--date-order" {
153                 set vdatemode($n) 1
154                 # remove from origargs in case we hit an unknown option
155                 set origargs [lreplace $origargs $i $i]
156                 incr i -1
157             }
158             # These request or affect diff output, which we don't want.
159             # Some could be used to set our defaults for diff display.
160             "-[puabwcrRBMC]" -
161             "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162             "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163             "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164             "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165             "--ignore-space-change" - "-U*" - "--unified=*" {
166                 lappend diffargs $arg
167             }
168             # These cause our parsing of git log's output to fail, or else
169             # they're options we want to set ourselves, so ignore them.
170             "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171             "--name-only" - "--name-status" - "--color" - "--color-words" -
172             "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173             "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174             "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175             "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176             "--objects" - "--objects-edge" - "--reverse" {
177             }
178             # These are harmless, and some are even useful
179             "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
180             "--check" - "--exit-code" - "--quiet" - "--topo-order" -
181             "--full-history" - "--dense" - "--sparse" -
182             "--follow" - "--left-right" - "--encoding=*" {
183                 lappend glflags $arg
184             }
185             # These mean that we get a subset of the commits
186             "--diff-filter=*" - "--no-merges" - "--unpacked" -
187             "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
188             "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
189             "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
190             "--remove-empty" - "--first-parent" - "--cherry-pick" -
191             "-S*" - "--pickaxe-all" - "--pickaxe-regex" - {
192                 set filtered 1
193                 lappend glflags $arg
194             }
195             # This appears to be the only one that has a value as a
196             # separate word following it
197             "-n" {
198                 set filtered 1
199                 set nextisval 1
200                 lappend glflags $arg
201             }
202             "--not" {
203                 set notflag [expr {!$notflag}]
204                 lappend revargs $arg
205             }
206             "--all" {
207                 lappend revargs $arg
208             }
209             "--merge" {
210                 set vmergeonly($n) 1
211                 # git rev-parse doesn't understand --merge
212                 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
213             }
214             # Other flag arguments including -<n>
215             "-*" {
216                 if {[string is digit -strict [string range $arg 1 end]]} {
217                     set filtered 1
218                 } else {
219                     # a flag argument that we don't recognize;
220                     # that means we can't optimize
221                     set allknown 0
222                 }
223                 lappend glflags $arg
224             }
225             # Non-flag arguments specify commits or ranges of commits
226             default {
227                 if {[string match "*...*" $arg]} {
228                     lappend revargs --gitk-symmetric-diff-marker
229                 }
230                 lappend revargs $arg
231             }
232         }
233     }
234     set vdflags($n) $diffargs
235     set vflags($n) $glflags
236     set vrevs($n) $revargs
237     set vfiltered($n) $filtered
238     set vorigargs($n) $origargs
239     return $allknown
242 proc parseviewrevs {view revs} {
243     global vposids vnegids
245     if {$revs eq {}} {
246         set revs HEAD
247     }
248     if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
249         # we get stdout followed by stderr in $err
250         # for an unknown rev, git rev-parse echoes it and then errors out
251         set errlines [split $err "\n"]
252         set badrev {}
253         for {set l 0} {$l < [llength $errlines]} {incr l} {
254             set line [lindex $errlines $l]
255             if {!([string length $line] == 40 && [string is xdigit $line])} {
256                 if {[string match "fatal:*" $line]} {
257                     if {[string match "fatal: ambiguous argument*" $line]
258                         && $badrev ne {}} {
259                         if {[llength $badrev] == 1} {
260                             set err "unknown revision $badrev"
261                         } else {
262                             set err "unknown revisions: [join $badrev ", "]"
263                         }
264                     } else {
265                         set err [join [lrange $errlines $l end] "\n"]
266                     }
267                     break
268                 }
269                 lappend badrev $line
270             }
271         }                   
272         error_popup "[mc "Error parsing revisions:"] $err"
273         return {}
274     }
275     set ret {}
276     set pos {}
277     set neg {}
278     set sdm 0
279     foreach id [split $ids "\n"] {
280         if {$id eq "--gitk-symmetric-diff-marker"} {
281             set sdm 4
282         } elseif {[string match "^*" $id]} {
283             if {$sdm != 1} {
284                 lappend ret $id
285                 if {$sdm == 3} {
286                     set sdm 0
287                 }
288             }
289             lappend neg [string range $id 1 end]
290         } else {
291             if {$sdm != 2} {
292                 lappend ret $id
293             } else {
294                 lset ret end [lindex $ret end]...$id
295             }
296             lappend pos $id
297         }
298         incr sdm -1
299     }
300     set vposids($view) $pos
301     set vnegids($view) $neg
302     return $ret
305 # Start off a git log process and arrange to read its output
306 proc start_rev_list {view} {
307     global startmsecs commitidx viewcomplete curview
308     global tclencoding
309     global viewargs viewargscmd viewfiles vfilelimit
310     global showlocalchanges commitinterest
311     global viewactive viewinstances vmergeonly
312     global mainheadid
313     global vcanopt vflags vrevs vorigargs
315     set startmsecs [clock clicks -milliseconds]
316     set commitidx($view) 0
317     # these are set this way for the error exits
318     set viewcomplete($view) 1
319     set viewactive($view) 0
320     varcinit $view
322     set args $viewargs($view)
323     if {$viewargscmd($view) ne {}} {
324         if {[catch {
325             set str [exec sh -c $viewargscmd($view)]
326         } err]} {
327             error_popup "[mc "Error executing --argscmd command:"] $err"
328             return 0
329         }
330         set args [concat $args [split $str "\n"]]
331     }
332     set vcanopt($view) [parseviewargs $view $args]
334     set files $viewfiles($view)
335     if {$vmergeonly($view)} {
336         set files [unmerged_files $files]
337         if {$files eq {}} {
338             global nr_unmerged
339             if {$nr_unmerged == 0} {
340                 error_popup [mc "No files selected: --merge specified but\
341                              no files are unmerged."]
342             } else {
343                 error_popup [mc "No files selected: --merge specified but\
344                              no unmerged files are within file limit."]
345             }
346             return 0
347         }
348     }
349     set vfilelimit($view) $files
351     if {$vcanopt($view)} {
352         set revs [parseviewrevs $view $vrevs($view)]
353         if {$revs eq {}} {
354             return 0
355         }
356         set args [concat $vflags($view) $revs]
357     } else {
358         set args $vorigargs($view)
359     }
361     if {[catch {
362         set fd [open [concat | git log --no-color -z --pretty=raw --parents \
363                          --boundary $args "--" $files] r]
364     } err]} {
365         error_popup "[mc "Error executing git log:"] $err"
366         return 0
367     }
368     set i [reg_instance $fd]
369     set viewinstances($view) [list $i]
370     if {$showlocalchanges && $mainheadid ne {}} {
371         lappend commitinterest($mainheadid) {dodiffindex}
372     }
373     fconfigure $fd -blocking 0 -translation lf -eofchar {}
374     if {$tclencoding != {}} {
375         fconfigure $fd -encoding $tclencoding
376     }
377     filerun $fd [list getcommitlines $fd $i $view 0]
378     nowbusy $view [mc "Reading"]
379     set viewcomplete($view) 0
380     set viewactive($view) 1
381     return 1
384 proc stop_instance {inst} {
385     global commfd leftover
387     set fd $commfd($inst)
388     catch {
389         set pid [pid $fd]
391         if {$::tcl_platform(platform) eq {windows}} {
392             exec kill -f $pid
393         } else {
394             exec kill $pid
395         }
396     }
397     catch {close $fd}
398     nukefile $fd
399     unset commfd($inst)
400     unset leftover($inst)
403 proc stop_backends {} {
404     global commfd
406     foreach inst [array names commfd] {
407         stop_instance $inst
408     }
411 proc stop_rev_list {view} {
412     global viewinstances
414     foreach inst $viewinstances($view) {
415         stop_instance $inst
416     }
417     set viewinstances($view) {}
420 proc reset_pending_select {selid} {
421     global pending_select mainheadid selectheadid
423     if {$selid ne {}} {
424         set pending_select $selid
425     } elseif {$selectheadid ne {}} {
426         set pending_select $selectheadid
427     } else {
428         set pending_select $mainheadid
429     }
432 proc getcommits {selid} {
433     global canv curview need_redisplay viewactive
435     initlayout
436     if {[start_rev_list $curview]} {
437         reset_pending_select $selid
438         show_status [mc "Reading commits..."]
439         set need_redisplay 1
440     } else {
441         show_status [mc "No commits selected"]
442     }
445 proc updatecommits {} {
446     global curview vcanopt vorigargs vfilelimit viewinstances
447     global viewactive viewcomplete tclencoding
448     global startmsecs showneartags showlocalchanges
449     global mainheadid pending_select
450     global isworktree
451     global varcid vposids vnegids vflags vrevs
453     set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
454     set oldmainid $mainheadid
455     rereadrefs
456     if {$showlocalchanges} {
457         if {$mainheadid ne $oldmainid} {
458             dohidelocalchanges
459         }
460         if {[commitinview $mainheadid $curview]} {
461             dodiffindex
462         }
463     }
464     set view $curview
465     if {$vcanopt($view)} {
466         set oldpos $vposids($view)
467         set oldneg $vnegids($view)
468         set revs [parseviewrevs $view $vrevs($view)]
469         if {$revs eq {}} {
470             return
471         }
472         # note: getting the delta when negative refs change is hard,
473         # and could require multiple git log invocations, so in that
474         # case we ask git log for all the commits (not just the delta)
475         if {$oldneg eq $vnegids($view)} {
476             set newrevs {}
477             set npos 0
478             # take out positive refs that we asked for before or
479             # that we have already seen
480             foreach rev $revs {
481                 if {[string length $rev] == 40} {
482                     if {[lsearch -exact $oldpos $rev] < 0
483                         && ![info exists varcid($view,$rev)]} {
484                         lappend newrevs $rev
485                         incr npos
486                     }
487                 } else {
488                     lappend $newrevs $rev
489                 }
490             }
491             if {$npos == 0} return
492             set revs $newrevs
493             set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
494         }
495         set args [concat $vflags($view) $revs --not $oldpos]
496     } else {
497         set args $vorigargs($view)
498     }
499     if {[catch {
500         set fd [open [concat | git log --no-color -z --pretty=raw --parents \
501                           --boundary $args "--" $vfilelimit($view)] r]
502     } err]} {
503         error_popup "[mc "Error executing git log:"] $err"
504         return
505     }
506     if {$viewactive($view) == 0} {
507         set startmsecs [clock clicks -milliseconds]
508     }
509     set i [reg_instance $fd]
510     lappend viewinstances($view) $i
511     fconfigure $fd -blocking 0 -translation lf -eofchar {}
512     if {$tclencoding != {}} {
513         fconfigure $fd -encoding $tclencoding
514     }
515     filerun $fd [list getcommitlines $fd $i $view 1]
516     incr viewactive($view)
517     set viewcomplete($view) 0
518     reset_pending_select {}
519     nowbusy $view "Reading"
520     if {$showneartags} {
521         getallcommits
522     }
525 proc reloadcommits {} {
526     global curview viewcomplete selectedline currentid thickerline
527     global showneartags treediffs commitinterest cached_commitrow
528     global targetid
530     set selid {}
531     if {$selectedline ne {}} {
532         set selid $currentid
533     }
535     if {!$viewcomplete($curview)} {
536         stop_rev_list $curview
537     }
538     resetvarcs $curview
539     set selectedline {}
540     catch {unset currentid}
541     catch {unset thickerline}
542     catch {unset treediffs}
543     readrefs
544     changedrefs
545     if {$showneartags} {
546         getallcommits
547     }
548     clear_display
549     catch {unset commitinterest}
550     catch {unset cached_commitrow}
551     catch {unset targetid}
552     setcanvscroll
553     getcommits $selid
554     return 0
557 # This makes a string representation of a positive integer which
558 # sorts as a string in numerical order
559 proc strrep {n} {
560     if {$n < 16} {
561         return [format "%x" $n]
562     } elseif {$n < 256} {
563         return [format "x%.2x" $n]
564     } elseif {$n < 65536} {
565         return [format "y%.4x" $n]
566     }
567     return [format "z%.8x" $n]
570 # Procedures used in reordering commits from git log (without
571 # --topo-order) into the order for display.
573 proc varcinit {view} {
574     global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
575     global vtokmod varcmod vrowmod varcix vlastins
577     set varcstart($view) {{}}
578     set vupptr($view) {0}
579     set vdownptr($view) {0}
580     set vleftptr($view) {0}
581     set vbackptr($view) {0}
582     set varctok($view) {{}}
583     set varcrow($view) {{}}
584     set vtokmod($view) {}
585     set varcmod($view) 0
586     set vrowmod($view) 0
587     set varcix($view) {{}}
588     set vlastins($view) {0}
591 proc resetvarcs {view} {
592     global varcid varccommits parents children vseedcount ordertok
594     foreach vid [array names varcid $view,*] {
595         unset varcid($vid)
596         unset children($vid)
597         unset parents($vid)
598     }
599     # some commits might have children but haven't been seen yet
600     foreach vid [array names children $view,*] {
601         unset children($vid)
602     }
603     foreach va [array names varccommits $view,*] {
604         unset varccommits($va)
605     }
606     foreach vd [array names vseedcount $view,*] {
607         unset vseedcount($vd)
608     }
609     catch {unset ordertok}
612 # returns a list of the commits with no children
613 proc seeds {v} {
614     global vdownptr vleftptr varcstart
616     set ret {}
617     set a [lindex $vdownptr($v) 0]
618     while {$a != 0} {
619         lappend ret [lindex $varcstart($v) $a]
620         set a [lindex $vleftptr($v) $a]
621     }
622     return $ret
625 proc newvarc {view id} {
626     global varcid varctok parents children vdatemode
627     global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
628     global commitdata commitinfo vseedcount varccommits vlastins
630     set a [llength $varctok($view)]
631     set vid $view,$id
632     if {[llength $children($vid)] == 0 || $vdatemode($view)} {
633         if {![info exists commitinfo($id)]} {
634             parsecommit $id $commitdata($id) 1
635         }
636         set cdate [lindex $commitinfo($id) 4]
637         if {![string is integer -strict $cdate]} {
638             set cdate 0
639         }
640         if {![info exists vseedcount($view,$cdate)]} {
641             set vseedcount($view,$cdate) -1
642         }
643         set c [incr vseedcount($view,$cdate)]
644         set cdate [expr {$cdate ^ 0xffffffff}]
645         set tok "s[strrep $cdate][strrep $c]"
646     } else {
647         set tok {}
648     }
649     set ka 0
650     if {[llength $children($vid)] > 0} {
651         set kid [lindex $children($vid) end]
652         set k $varcid($view,$kid)
653         if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
654             set ki $kid
655             set ka $k
656             set tok [lindex $varctok($view) $k]
657         }
658     }
659     if {$ka != 0} {
660         set i [lsearch -exact $parents($view,$ki) $id]
661         set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
662         append tok [strrep $j]
663     }
664     set c [lindex $vlastins($view) $ka]
665     if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
666         set c $ka
667         set b [lindex $vdownptr($view) $ka]
668     } else {
669         set b [lindex $vleftptr($view) $c]
670     }
671     while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
672         set c $b
673         set b [lindex $vleftptr($view) $c]
674     }
675     if {$c == $ka} {
676         lset vdownptr($view) $ka $a
677         lappend vbackptr($view) 0
678     } else {
679         lset vleftptr($view) $c $a
680         lappend vbackptr($view) $c
681     }
682     lset vlastins($view) $ka $a
683     lappend vupptr($view) $ka
684     lappend vleftptr($view) $b
685     if {$b != 0} {
686         lset vbackptr($view) $b $a
687     }
688     lappend varctok($view) $tok
689     lappend varcstart($view) $id
690     lappend vdownptr($view) 0
691     lappend varcrow($view) {}
692     lappend varcix($view) {}
693     set varccommits($view,$a) {}
694     lappend vlastins($view) 0
695     return $a
698 proc splitvarc {p v} {
699     global varcid varcstart varccommits varctok
700     global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
702     set oa $varcid($v,$p)
703     set ac $varccommits($v,$oa)
704     set i [lsearch -exact $varccommits($v,$oa) $p]
705     if {$i <= 0} return
706     set na [llength $varctok($v)]
707     # "%" sorts before "0"...
708     set tok "[lindex $varctok($v) $oa]%[strrep $i]"
709     lappend varctok($v) $tok
710     lappend varcrow($v) {}
711     lappend varcix($v) {}
712     set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
713     set varccommits($v,$na) [lrange $ac $i end]
714     lappend varcstart($v) $p
715     foreach id $varccommits($v,$na) {
716         set varcid($v,$id) $na
717     }
718     lappend vdownptr($v) [lindex $vdownptr($v) $oa]
719     lappend vlastins($v) [lindex $vlastins($v) $oa]
720     lset vdownptr($v) $oa $na
721     lset vlastins($v) $oa 0
722     lappend vupptr($v) $oa
723     lappend vleftptr($v) 0
724     lappend vbackptr($v) 0
725     for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
726         lset vupptr($v) $b $na
727     }
730 proc renumbervarc {a v} {
731     global parents children varctok varcstart varccommits
732     global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
734     set t1 [clock clicks -milliseconds]
735     set todo {}
736     set isrelated($a) 1
737     set kidchanged($a) 1
738     set ntot 0
739     while {$a != 0} {
740         if {[info exists isrelated($a)]} {
741             lappend todo $a
742             set id [lindex $varccommits($v,$a) end]
743             foreach p $parents($v,$id) {
744                 if {[info exists varcid($v,$p)]} {
745                     set isrelated($varcid($v,$p)) 1
746                 }
747             }
748         }
749         incr ntot
750         set b [lindex $vdownptr($v) $a]
751         if {$b == 0} {
752             while {$a != 0} {
753                 set b [lindex $vleftptr($v) $a]
754                 if {$b != 0} break
755                 set a [lindex $vupptr($v) $a]
756             }
757         }
758         set a $b
759     }
760     foreach a $todo {
761         if {![info exists kidchanged($a)]} continue
762         set id [lindex $varcstart($v) $a]
763         if {[llength $children($v,$id)] > 1} {
764             set children($v,$id) [lsort -command [list vtokcmp $v] \
765                                       $children($v,$id)]
766         }
767         set oldtok [lindex $varctok($v) $a]
768         if {!$vdatemode($v)} {
769             set tok {}
770         } else {
771             set tok $oldtok
772         }
773         set ka 0
774         set kid [last_real_child $v,$id]
775         if {$kid ne {}} {
776             set k $varcid($v,$kid)
777             if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
778                 set ki $kid
779                 set ka $k
780                 set tok [lindex $varctok($v) $k]
781             }
782         }
783         if {$ka != 0} {
784             set i [lsearch -exact $parents($v,$ki) $id]
785             set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
786             append tok [strrep $j]
787         }
788         if {$tok eq $oldtok} {
789             continue
790         }
791         set id [lindex $varccommits($v,$a) end]
792         foreach p $parents($v,$id) {
793             if {[info exists varcid($v,$p)]} {
794                 set kidchanged($varcid($v,$p)) 1
795             } else {
796                 set sortkids($p) 1
797             }
798         }
799         lset varctok($v) $a $tok
800         set b [lindex $vupptr($v) $a]
801         if {$b != $ka} {
802             if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
803                 modify_arc $v $ka
804             }
805             if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
806                 modify_arc $v $b
807             }
808             set c [lindex $vbackptr($v) $a]
809             set d [lindex $vleftptr($v) $a]
810             if {$c == 0} {
811                 lset vdownptr($v) $b $d
812             } else {
813                 lset vleftptr($v) $c $d
814             }
815             if {$d != 0} {
816                 lset vbackptr($v) $d $c
817             }
818             if {[lindex $vlastins($v) $b] == $a} {
819                 lset vlastins($v) $b $c
820             }
821             lset vupptr($v) $a $ka
822             set c [lindex $vlastins($v) $ka]
823             if {$c == 0 || \
824                     [string compare $tok [lindex $varctok($v) $c]] < 0} {
825                 set c $ka
826                 set b [lindex $vdownptr($v) $ka]
827             } else {
828                 set b [lindex $vleftptr($v) $c]
829             }
830             while {$b != 0 && \
831                       [string compare $tok [lindex $varctok($v) $b]] >= 0} {
832                 set c $b
833                 set b [lindex $vleftptr($v) $c]
834             }
835             if {$c == $ka} {
836                 lset vdownptr($v) $ka $a
837                 lset vbackptr($v) $a 0
838             } else {
839                 lset vleftptr($v) $c $a
840                 lset vbackptr($v) $a $c
841             }
842             lset vleftptr($v) $a $b
843             if {$b != 0} {
844                 lset vbackptr($v) $b $a
845             }
846             lset vlastins($v) $ka $a
847         }
848     }
849     foreach id [array names sortkids] {
850         if {[llength $children($v,$id)] > 1} {
851             set children($v,$id) [lsort -command [list vtokcmp $v] \
852                                       $children($v,$id)]
853         }
854     }
855     set t2 [clock clicks -milliseconds]
856     #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
859 # Fix up the graph after we have found out that in view $v,
860 # $p (a commit that we have already seen) is actually the parent
861 # of the last commit in arc $a.
862 proc fix_reversal {p a v} {
863     global varcid varcstart varctok vupptr
865     set pa $varcid($v,$p)
866     if {$p ne [lindex $varcstart($v) $pa]} {
867         splitvarc $p $v
868         set pa $varcid($v,$p)
869     }
870     # seeds always need to be renumbered
871     if {[lindex $vupptr($v) $pa] == 0 ||
872         [string compare [lindex $varctok($v) $a] \
873              [lindex $varctok($v) $pa]] > 0} {
874         renumbervarc $pa $v
875     }
878 proc insertrow {id p v} {
879     global cmitlisted children parents varcid varctok vtokmod
880     global varccommits ordertok commitidx numcommits curview
881     global targetid targetrow
883     readcommit $id
884     set vid $v,$id
885     set cmitlisted($vid) 1
886     set children($vid) {}
887     set parents($vid) [list $p]
888     set a [newvarc $v $id]
889     set varcid($vid) $a
890     if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
891         modify_arc $v $a
892     }
893     lappend varccommits($v,$a) $id
894     set vp $v,$p
895     if {[llength [lappend children($vp) $id]] > 1} {
896         set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
897         catch {unset ordertok}
898     }
899     fix_reversal $p $a $v
900     incr commitidx($v)
901     if {$v == $curview} {
902         set numcommits $commitidx($v)
903         setcanvscroll
904         if {[info exists targetid]} {
905             if {![comes_before $targetid $p]} {
906                 incr targetrow
907             }
908         }
909     }
912 proc insertfakerow {id p} {
913     global varcid varccommits parents children cmitlisted
914     global commitidx varctok vtokmod targetid targetrow curview numcommits
916     set v $curview
917     set a $varcid($v,$p)
918     set i [lsearch -exact $varccommits($v,$a) $p]
919     if {$i < 0} {
920         puts "oops: insertfakerow can't find [shortids $p] on arc $a"
921         return
922     }
923     set children($v,$id) {}
924     set parents($v,$id) [list $p]
925     set varcid($v,$id) $a
926     lappend children($v,$p) $id
927     set cmitlisted($v,$id) 1
928     set numcommits [incr commitidx($v)]
929     # note we deliberately don't update varcstart($v) even if $i == 0
930     set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
931     modify_arc $v $a $i
932     if {[info exists targetid]} {
933         if {![comes_before $targetid $p]} {
934             incr targetrow
935         }
936     }
937     setcanvscroll
938     drawvisible
941 proc removefakerow {id} {
942     global varcid varccommits parents children commitidx
943     global varctok vtokmod cmitlisted currentid selectedline
944     global targetid curview numcommits
946     set v $curview
947     if {[llength $parents($v,$id)] != 1} {
948         puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
949         return
950     }
951     set p [lindex $parents($v,$id) 0]
952     set a $varcid($v,$id)
953     set i [lsearch -exact $varccommits($v,$a) $id]
954     if {$i < 0} {
955         puts "oops: removefakerow can't find [shortids $id] on arc $a"
956         return
957     }
958     unset varcid($v,$id)
959     set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
960     unset parents($v,$id)
961     unset children($v,$id)
962     unset cmitlisted($v,$id)
963     set numcommits [incr commitidx($v) -1]
964     set j [lsearch -exact $children($v,$p) $id]
965     if {$j >= 0} {
966         set children($v,$p) [lreplace $children($v,$p) $j $j]
967     }
968     modify_arc $v $a $i
969     if {[info exist currentid] && $id eq $currentid} {
970         unset currentid
971         set selectedline {}
972     }
973     if {[info exists targetid] && $targetid eq $id} {
974         set targetid $p
975     }
976     setcanvscroll
977     drawvisible
980 proc first_real_child {vp} {
981     global children nullid nullid2
983     foreach id $children($vp) {
984         if {$id ne $nullid && $id ne $nullid2} {
985             return $id
986         }
987     }
988     return {}
991 proc last_real_child {vp} {
992     global children nullid nullid2
994     set kids $children($vp)
995     for {set i [llength $kids]} {[incr i -1] >= 0} {} {
996         set id [lindex $kids $i]
997         if {$id ne $nullid && $id ne $nullid2} {
998             return $id
999         }
1000     }
1001     return {}
1004 proc vtokcmp {v a b} {
1005     global varctok varcid
1007     return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1008                 [lindex $varctok($v) $varcid($v,$b)]]
1011 # This assumes that if lim is not given, the caller has checked that
1012 # arc a's token is less than $vtokmod($v)
1013 proc modify_arc {v a {lim {}}} {
1014     global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1016     if {$lim ne {}} {
1017         set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1018         if {$c > 0} return
1019         if {$c == 0} {
1020             set r [lindex $varcrow($v) $a]
1021             if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1022         }
1023     }
1024     set vtokmod($v) [lindex $varctok($v) $a]
1025     set varcmod($v) $a
1026     if {$v == $curview} {
1027         while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1028             set a [lindex $vupptr($v) $a]
1029             set lim {}
1030         }
1031         set r 0
1032         if {$a != 0} {
1033             if {$lim eq {}} {
1034                 set lim [llength $varccommits($v,$a)]
1035             }
1036             set r [expr {[lindex $varcrow($v) $a] + $lim}]
1037         }
1038         set vrowmod($v) $r
1039         undolayout $r
1040     }
1043 proc update_arcrows {v} {
1044     global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1045     global varcid vrownum varcorder varcix varccommits
1046     global vupptr vdownptr vleftptr varctok
1047     global displayorder parentlist curview cached_commitrow
1049     if {$vrowmod($v) == $commitidx($v)} return
1050     if {$v == $curview} {
1051         if {[llength $displayorder] > $vrowmod($v)} {
1052             set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1053             set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1054         }
1055         catch {unset cached_commitrow}
1056     }
1057     set narctot [expr {[llength $varctok($v)] - 1}]
1058     set a $varcmod($v)
1059     while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1060         # go up the tree until we find something that has a row number,
1061         # or we get to a seed
1062         set a [lindex $vupptr($v) $a]
1063     }
1064     if {$a == 0} {
1065         set a [lindex $vdownptr($v) 0]
1066         if {$a == 0} return
1067         set vrownum($v) {0}
1068         set varcorder($v) [list $a]
1069         lset varcix($v) $a 0
1070         lset varcrow($v) $a 0
1071         set arcn 0
1072         set row 0
1073     } else {
1074         set arcn [lindex $varcix($v) $a]
1075         if {[llength $vrownum($v)] > $arcn + 1} {
1076             set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1077             set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1078         }
1079         set row [lindex $varcrow($v) $a]
1080     }
1081     while {1} {
1082         set p $a
1083         incr row [llength $varccommits($v,$a)]
1084         # go down if possible
1085         set b [lindex $vdownptr($v) $a]
1086         if {$b == 0} {
1087             # if not, go left, or go up until we can go left
1088             while {$a != 0} {
1089                 set b [lindex $vleftptr($v) $a]
1090                 if {$b != 0} break
1091                 set a [lindex $vupptr($v) $a]
1092             }
1093             if {$a == 0} break
1094         }
1095         set a $b
1096         incr arcn
1097         lappend vrownum($v) $row
1098         lappend varcorder($v) $a
1099         lset varcix($v) $a $arcn
1100         lset varcrow($v) $a $row
1101     }
1102     set vtokmod($v) [lindex $varctok($v) $p]
1103     set varcmod($v) $p
1104     set vrowmod($v) $row
1105     if {[info exists currentid]} {
1106         set selectedline [rowofcommit $currentid]
1107     }
1110 # Test whether view $v contains commit $id
1111 proc commitinview {id v} {
1112     global varcid
1114     return [info exists varcid($v,$id)]
1117 # Return the row number for commit $id in the current view
1118 proc rowofcommit {id} {
1119     global varcid varccommits varcrow curview cached_commitrow
1120     global varctok vtokmod
1122     set v $curview
1123     if {![info exists varcid($v,$id)]} {
1124         puts "oops rowofcommit no arc for [shortids $id]"
1125         return {}
1126     }
1127     set a $varcid($v,$id)
1128     if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1129         update_arcrows $v
1130     }
1131     if {[info exists cached_commitrow($id)]} {
1132         return $cached_commitrow($id)
1133     }
1134     set i [lsearch -exact $varccommits($v,$a) $id]
1135     if {$i < 0} {
1136         puts "oops didn't find commit [shortids $id] in arc $a"
1137         return {}
1138     }
1139     incr i [lindex $varcrow($v) $a]
1140     set cached_commitrow($id) $i
1141     return $i
1144 # Returns 1 if a is on an earlier row than b, otherwise 0
1145 proc comes_before {a b} {
1146     global varcid varctok curview
1148     set v $curview
1149     if {$a eq $b || ![info exists varcid($v,$a)] || \
1150             ![info exists varcid($v,$b)]} {
1151         return 0
1152     }
1153     if {$varcid($v,$a) != $varcid($v,$b)} {
1154         return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1155                            [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1156     }
1157     return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1160 proc bsearch {l elt} {
1161     if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1162         return 0
1163     }
1164     set lo 0
1165     set hi [llength $l]
1166     while {$hi - $lo > 1} {
1167         set mid [expr {int(($lo + $hi) / 2)}]
1168         set t [lindex $l $mid]
1169         if {$elt < $t} {
1170             set hi $mid
1171         } elseif {$elt > $t} {
1172             set lo $mid
1173         } else {
1174             return $mid
1175         }
1176     }
1177     return $lo
1180 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1181 proc make_disporder {start end} {
1182     global vrownum curview commitidx displayorder parentlist
1183     global varccommits varcorder parents vrowmod varcrow
1184     global d_valid_start d_valid_end
1186     if {$end > $vrowmod($curview)} {
1187         update_arcrows $curview
1188     }
1189     set ai [bsearch $vrownum($curview) $start]
1190     set start [lindex $vrownum($curview) $ai]
1191     set narc [llength $vrownum($curview)]
1192     for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1193         set a [lindex $varcorder($curview) $ai]
1194         set l [llength $displayorder]
1195         set al [llength $varccommits($curview,$a)]
1196         if {$l < $r + $al} {
1197             if {$l < $r} {
1198                 set pad [ntimes [expr {$r - $l}] {}]
1199                 set displayorder [concat $displayorder $pad]
1200                 set parentlist [concat $parentlist $pad]
1201             } elseif {$l > $r} {
1202                 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1203                 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1204             }
1205             foreach id $varccommits($curview,$a) {
1206                 lappend displayorder $id
1207                 lappend parentlist $parents($curview,$id)
1208             }
1209         } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1210             set i $r
1211             foreach id $varccommits($curview,$a) {
1212                 lset displayorder $i $id
1213                 lset parentlist $i $parents($curview,$id)
1214                 incr i
1215             }
1216         }
1217         incr r $al
1218     }
1221 proc commitonrow {row} {
1222     global displayorder
1224     set id [lindex $displayorder $row]
1225     if {$id eq {}} {
1226         make_disporder $row [expr {$row + 1}]
1227         set id [lindex $displayorder $row]
1228     }
1229     return $id
1232 proc closevarcs {v} {
1233     global varctok varccommits varcid parents children
1234     global cmitlisted commitidx commitinterest vtokmod
1236     set missing_parents 0
1237     set scripts {}
1238     set narcs [llength $varctok($v)]
1239     for {set a 1} {$a < $narcs} {incr a} {
1240         set id [lindex $varccommits($v,$a) end]
1241         foreach p $parents($v,$id) {
1242             if {[info exists varcid($v,$p)]} continue
1243             # add p as a new commit
1244             incr missing_parents
1245             set cmitlisted($v,$p) 0
1246             set parents($v,$p) {}
1247             if {[llength $children($v,$p)] == 1 &&
1248                 [llength $parents($v,$id)] == 1} {
1249                 set b $a
1250             } else {
1251                 set b [newvarc $v $p]
1252             }
1253             set varcid($v,$p) $b
1254             if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1255                 modify_arc $v $b
1256             }
1257             lappend varccommits($v,$b) $p
1258             incr commitidx($v)
1259             if {[info exists commitinterest($p)]} {
1260                 foreach script $commitinterest($p) {
1261                     lappend scripts [string map [list "%I" $p] $script]
1262                 }
1263                 unset commitinterest($id)
1264             }
1265         }
1266     }
1267     if {$missing_parents > 0} {
1268         foreach s $scripts {
1269             eval $s
1270         }
1271     }
1274 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1275 # Assumes we already have an arc for $rwid.
1276 proc rewrite_commit {v id rwid} {
1277     global children parents varcid varctok vtokmod varccommits
1279     foreach ch $children($v,$id) {
1280         # make $rwid be $ch's parent in place of $id
1281         set i [lsearch -exact $parents($v,$ch) $id]
1282         if {$i < 0} {
1283             puts "oops rewrite_commit didn't find $id in parent list for $ch"
1284         }
1285         set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1286         # add $ch to $rwid's children and sort the list if necessary
1287         if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1288             set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1289                                         $children($v,$rwid)]
1290         }
1291         # fix the graph after joining $id to $rwid
1292         set a $varcid($v,$ch)
1293         fix_reversal $rwid $a $v
1294         # parentlist is wrong for the last element of arc $a
1295         # even if displayorder is right, hence the 3rd arg here
1296         modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1297     }
1300 proc getcommitlines {fd inst view updating}  {
1301     global cmitlisted commitinterest leftover
1302     global commitidx commitdata vdatemode
1303     global parents children curview hlview
1304     global idpending ordertok
1305     global varccommits varcid varctok vtokmod vfilelimit
1307     set stuff [read $fd 500000]
1308     # git log doesn't terminate the last commit with a null...
1309     if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1310         set stuff "\0"
1311     }
1312     if {$stuff == {}} {
1313         if {![eof $fd]} {
1314             return 1
1315         }
1316         global commfd viewcomplete viewactive viewname
1317         global viewinstances
1318         unset commfd($inst)
1319         set i [lsearch -exact $viewinstances($view) $inst]
1320         if {$i >= 0} {
1321             set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1322         }
1323         # set it blocking so we wait for the process to terminate
1324         fconfigure $fd -blocking 1
1325         if {[catch {close $fd} err]} {
1326             set fv {}
1327             if {$view != $curview} {
1328                 set fv " for the \"$viewname($view)\" view"
1329             }
1330             if {[string range $err 0 4] == "usage"} {
1331                 set err "Gitk: error reading commits$fv:\
1332                         bad arguments to git log."
1333                 if {$viewname($view) eq "Command line"} {
1334                     append err \
1335                         "  (Note: arguments to gitk are passed to git log\
1336                          to allow selection of commits to be displayed.)"
1337                 }
1338             } else {
1339                 set err "Error reading commits$fv: $err"
1340             }
1341             error_popup $err
1342         }
1343         if {[incr viewactive($view) -1] <= 0} {
1344             set viewcomplete($view) 1
1345             # Check if we have seen any ids listed as parents that haven't
1346             # appeared in the list
1347             closevarcs $view
1348             notbusy $view
1349         }
1350         if {$view == $curview} {
1351             run chewcommits
1352         }
1353         return 0
1354     }
1355     set start 0
1356     set gotsome 0
1357     set scripts {}
1358     while 1 {
1359         set i [string first "\0" $stuff $start]
1360         if {$i < 0} {
1361             append leftover($inst) [string range $stuff $start end]
1362             break
1363         }
1364         if {$start == 0} {
1365             set cmit $leftover($inst)
1366             append cmit [string range $stuff 0 [expr {$i - 1}]]
1367             set leftover($inst) {}
1368         } else {
1369             set cmit [string range $stuff $start [expr {$i - 1}]]
1370         }
1371         set start [expr {$i + 1}]
1372         set j [string first "\n" $cmit]
1373         set ok 0
1374         set listed 1
1375         if {$j >= 0 && [string match "commit *" $cmit]} {
1376             set ids [string range $cmit 7 [expr {$j - 1}]]
1377             if {[string match {[-^<>]*} $ids]} {
1378                 switch -- [string index $ids 0] {
1379                     "-" {set listed 0}
1380                     "^" {set listed 2}
1381                     "<" {set listed 3}
1382                     ">" {set listed 4}
1383                 }
1384                 set ids [string range $ids 1 end]
1385             }
1386             set ok 1
1387             foreach id $ids {
1388                 if {[string length $id] != 40} {
1389                     set ok 0
1390                     break
1391                 }
1392             }
1393         }
1394         if {!$ok} {
1395             set shortcmit $cmit
1396             if {[string length $shortcmit] > 80} {
1397                 set shortcmit "[string range $shortcmit 0 80]..."
1398             }
1399             error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1400             exit 1
1401         }
1402         set id [lindex $ids 0]
1403         set vid $view,$id
1405         if {!$listed && $updating && ![info exists varcid($vid)] &&
1406             $vfilelimit($view) ne {}} {
1407             # git log doesn't rewrite parents for unlisted commits
1408             # when doing path limiting, so work around that here
1409             # by working out the rewritten parent with git rev-list
1410             # and if we already know about it, using the rewritten
1411             # parent as a substitute parent for $id's children.
1412             if {![catch {
1413                 set rwid [exec git rev-list --first-parent --max-count=1 \
1414                               $id -- $vfilelimit($view)]
1415             }]} {
1416                 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1417                     # use $rwid in place of $id
1418                     rewrite_commit $view $id $rwid
1419                     continue
1420                 }
1421             }
1422         }
1424         set a 0
1425         if {[info exists varcid($vid)]} {
1426             if {$cmitlisted($vid) || !$listed} continue
1427             set a $varcid($vid)
1428         }
1429         if {$listed} {
1430             set olds [lrange $ids 1 end]
1431         } else {
1432             set olds {}
1433         }
1434         set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1435         set cmitlisted($vid) $listed
1436         set parents($vid) $olds
1437         if {![info exists children($vid)]} {
1438             set children($vid) {}
1439         } elseif {$a == 0 && [llength $children($vid)] == 1} {
1440             set k [lindex $children($vid) 0]
1441             if {[llength $parents($view,$k)] == 1 &&
1442                 (!$vdatemode($view) ||
1443                  $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1444                 set a $varcid($view,$k)
1445             }
1446         }
1447         if {$a == 0} {
1448             # new arc
1449             set a [newvarc $view $id]
1450         }
1451         if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1452             modify_arc $view $a
1453         }
1454         if {![info exists varcid($vid)]} {
1455             set varcid($vid) $a
1456             lappend varccommits($view,$a) $id
1457             incr commitidx($view)
1458         }
1460         set i 0
1461         foreach p $olds {
1462             if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1463                 set vp $view,$p
1464                 if {[llength [lappend children($vp) $id]] > 1 &&
1465                     [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1466                     set children($vp) [lsort -command [list vtokcmp $view] \
1467                                            $children($vp)]
1468                     catch {unset ordertok}
1469                 }
1470                 if {[info exists varcid($view,$p)]} {
1471                     fix_reversal $p $a $view
1472                 }
1473             }
1474             incr i
1475         }
1477         if {[info exists commitinterest($id)]} {
1478             foreach script $commitinterest($id) {
1479                 lappend scripts [string map [list "%I" $id] $script]
1480             }
1481             unset commitinterest($id)
1482         }
1483         set gotsome 1
1484     }
1485     if {$gotsome} {
1486         global numcommits hlview
1488         if {$view == $curview} {
1489             set numcommits $commitidx($view)
1490             run chewcommits
1491         }
1492         if {[info exists hlview] && $view == $hlview} {
1493             # we never actually get here...
1494             run vhighlightmore
1495         }
1496         foreach s $scripts {
1497             eval $s
1498         }
1499     }
1500     return 2
1503 proc chewcommits {} {
1504     global curview hlview viewcomplete
1505     global pending_select
1507     layoutmore
1508     if {$viewcomplete($curview)} {
1509         global commitidx varctok
1510         global numcommits startmsecs
1512         if {[info exists pending_select]} {
1513             update
1514             reset_pending_select {}
1516             if {[commitinview $pending_select $curview]} {
1517                 selectline [rowofcommit $pending_select] 1
1518             } else {
1519                 set row [first_real_row]
1520                 selectline $row 1
1521             }
1522         }
1523         if {$commitidx($curview) > 0} {
1524             #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1525             #puts "overall $ms ms for $numcommits commits"
1526             #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1527         } else {
1528             show_status [mc "No commits selected"]
1529         }
1530         notbusy layout
1531     }
1532     return 0
1535 proc readcommit {id} {
1536     if {[catch {set contents [exec git cat-file commit $id]}]} return
1537     parsecommit $id $contents 0
1540 proc parsecommit {id contents listed} {
1541     global commitinfo cdate
1543     set inhdr 1
1544     set comment {}
1545     set headline {}
1546     set auname {}
1547     set audate {}
1548     set comname {}
1549     set comdate {}
1550     set hdrend [string first "\n\n" $contents]
1551     if {$hdrend < 0} {
1552         # should never happen...
1553         set hdrend [string length $contents]
1554     }
1555     set header [string range $contents 0 [expr {$hdrend - 1}]]
1556     set comment [string range $contents [expr {$hdrend + 2}] end]
1557     foreach line [split $header "\n"] {
1558         set tag [lindex $line 0]
1559         if {$tag == "author"} {
1560             set audate [lindex $line end-1]
1561             set auname [lrange $line 1 end-2]
1562         } elseif {$tag == "committer"} {
1563             set comdate [lindex $line end-1]
1564             set comname [lrange $line 1 end-2]
1565         }
1566     }
1567     set headline {}
1568     # take the first non-blank line of the comment as the headline
1569     set headline [string trimleft $comment]
1570     set i [string first "\n" $headline]
1571     if {$i >= 0} {
1572         set headline [string range $headline 0 $i]
1573     }
1574     set headline [string trimright $headline]
1575     set i [string first "\r" $headline]
1576     if {$i >= 0} {
1577         set headline [string trimright [string range $headline 0 $i]]
1578     }
1579     if {!$listed} {
1580         # git log indents the comment by 4 spaces;
1581         # if we got this via git cat-file, add the indentation
1582         set newcomment {}
1583         foreach line [split $comment "\n"] {
1584             append newcomment "    "
1585             append newcomment $line
1586             append newcomment "\n"
1587         }
1588         set comment $newcomment
1589     }
1590     if {$comdate != {}} {
1591         set cdate($id) $comdate
1592     }
1593     set commitinfo($id) [list $headline $auname $audate \
1594                              $comname $comdate $comment]
1597 proc getcommit {id} {
1598     global commitdata commitinfo
1600     if {[info exists commitdata($id)]} {
1601         parsecommit $id $commitdata($id) 1
1602     } else {
1603         readcommit $id
1604         if {![info exists commitinfo($id)]} {
1605             set commitinfo($id) [list [mc "No commit information available"]]
1606         }
1607     }
1608     return 1
1611 proc readrefs {} {
1612     global tagids idtags headids idheads tagobjid
1613     global otherrefids idotherrefs mainhead mainheadid
1614     global selecthead selectheadid
1616     foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1617         catch {unset $v}
1618     }
1619     set refd [open [list | git show-ref -d] r]
1620     while {[gets $refd line] >= 0} {
1621         if {[string index $line 40] ne " "} continue
1622         set id [string range $line 0 39]
1623         set ref [string range $line 41 end]
1624         if {![string match "refs/*" $ref]} continue
1625         set name [string range $ref 5 end]
1626         if {[string match "remotes/*" $name]} {
1627             if {![string match "*/HEAD" $name]} {
1628                 set headids($name) $id
1629                 lappend idheads($id) $name
1630             }
1631         } elseif {[string match "heads/*" $name]} {
1632             set name [string range $name 6 end]
1633             set headids($name) $id
1634             lappend idheads($id) $name
1635         } elseif {[string match "tags/*" $name]} {
1636             # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1637             # which is what we want since the former is the commit ID
1638             set name [string range $name 5 end]
1639             if {[string match "*^{}" $name]} {
1640                 set name [string range $name 0 end-3]
1641             } else {
1642                 set tagobjid($name) $id
1643             }
1644             set tagids($name) $id
1645             lappend idtags($id) $name
1646         } else {
1647             set otherrefids($name) $id
1648             lappend idotherrefs($id) $name
1649         }
1650     }
1651     catch {close $refd}
1652     set mainhead {}
1653     set mainheadid {}
1654     catch {
1655         set mainheadid [exec git rev-parse HEAD]
1656         set thehead [exec git symbolic-ref HEAD]
1657         if {[string match "refs/heads/*" $thehead]} {
1658             set mainhead [string range $thehead 11 end]
1659         }
1660     }
1661     set selectheadid {}
1662     if {$selecthead ne {}} {
1663         catch {
1664             set selectheadid [exec git rev-parse --verify $selecthead]
1665         }
1666     }
1669 # skip over fake commits
1670 proc first_real_row {} {
1671     global nullid nullid2 numcommits
1673     for {set row 0} {$row < $numcommits} {incr row} {
1674         set id [commitonrow $row]
1675         if {$id ne $nullid && $id ne $nullid2} {
1676             break
1677         }
1678     }
1679     return $row
1682 # update things for a head moved to a child of its previous location
1683 proc movehead {id name} {
1684     global headids idheads
1686     removehead $headids($name) $name
1687     set headids($name) $id
1688     lappend idheads($id) $name
1691 # update things when a head has been removed
1692 proc removehead {id name} {
1693     global headids idheads
1695     if {$idheads($id) eq $name} {
1696         unset idheads($id)
1697     } else {
1698         set i [lsearch -exact $idheads($id) $name]
1699         if {$i >= 0} {
1700             set idheads($id) [lreplace $idheads($id) $i $i]
1701         }
1702     }
1703     unset headids($name)
1706 proc show_error {w top msg} {
1707     message $w.m -text $msg -justify center -aspect 400
1708     pack $w.m -side top -fill x -padx 20 -pady 20
1709     button $w.ok -text [mc OK] -command "destroy $top"
1710     pack $w.ok -side bottom -fill x
1711     bind $top <Visibility> "grab $top; focus $top"
1712     bind $top <Key-Return> "destroy $top"
1713     tkwait window $top
1716 proc error_popup msg {
1717     set w .error
1718     toplevel $w
1719     wm transient $w .
1720     show_error $w $w $msg
1723 proc confirm_popup msg {
1724     global confirm_ok
1725     set confirm_ok 0
1726     set w .confirm
1727     toplevel $w
1728     wm transient $w .
1729     message $w.m -text $msg -justify center -aspect 400
1730     pack $w.m -side top -fill x -padx 20 -pady 20
1731     button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1732     pack $w.ok -side left -fill x
1733     button $w.cancel -text [mc Cancel] -command "destroy $w"
1734     pack $w.cancel -side right -fill x
1735     bind $w <Visibility> "grab $w; focus $w"
1736     tkwait window $w
1737     return $confirm_ok
1740 proc setoptions {} {
1741     option add *Panedwindow.showHandle 1 startupFile
1742     option add *Panedwindow.sashRelief raised startupFile
1743     option add *Button.font uifont startupFile
1744     option add *Checkbutton.font uifont startupFile
1745     option add *Radiobutton.font uifont startupFile
1746     option add *Menu.font uifont startupFile
1747     option add *Menubutton.font uifont startupFile
1748     option add *Label.font uifont startupFile
1749     option add *Message.font uifont startupFile
1750     option add *Entry.font uifont startupFile
1753 proc makemenu {m items} {
1754     menu $m
1755     foreach i $items {
1756         set name [mc [lindex $i 0]]
1757         set type [lindex $i 1]
1758         set thing [lindex $i 2]
1759         set params [list $type]
1760         if {$name ne {}} {
1761             set u [string first "&" [string map {&& x} $name]]
1762             lappend params -label [string map {&& & & {}} $name]
1763             if {$u >= 0} {
1764                 lappend params -underline $u
1765             }
1766         }
1767         switch -- $type {
1768             "cascade" {
1769                 set submenu [string tolower [string map {& ""} [lindex $i 0]]]
1770                 lappend params -menu $m.$submenu
1771             }
1772             "command" {
1773                 lappend params -command $thing
1774             }
1775             "radiobutton" {
1776                 lappend params -variable [lindex $thing 0] \
1777                     -value [lindex $thing 1]
1778             }
1779         }
1780         eval $m add $params [lrange $i 3 end]
1781         if {$type eq "cascade"} {
1782             makemenu $m.$submenu $thing
1783         }
1784     }
1787 # translate string and remove ampersands
1788 proc mca {str} {
1789     return [string map {&& & & {}} [mc $str]]
1792 proc makewindow {} {
1793     global canv canv2 canv3 linespc charspc ctext cflist cscroll
1794     global tabstop
1795     global findtype findtypemenu findloc findstring fstring geometry
1796     global entries sha1entry sha1string sha1but
1797     global diffcontextstring diffcontext
1798     global ignorespace
1799     global maincursor textcursor curtextcursor
1800     global rowctxmenu fakerowmenu mergemax wrapcomment
1801     global highlight_files gdttype
1802     global searchstring sstring
1803     global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1804     global headctxmenu progresscanv progressitem progresscoords statusw
1805     global fprogitem fprogcoord lastprogupdate progupdatepending
1806     global rprogitem rprogcoord rownumsel numcommits
1807     global have_tk85
1809     makemenu .bar {
1810         {"File" cascade {
1811             {"Update" command updatecommits -accelerator F5}
1812             {"Reload" command reloadcommits}
1813             {"Reread references" command rereadrefs}
1814             {"List references" command showrefs}
1815             {"Quit" command doquit}
1816         }}
1817         {"Edit" cascade {
1818             {"Preferences" command doprefs}
1819         }}
1820         {"View" cascade {
1821             {"New view..." command {newview 0}}
1822             {"Edit view..." command editview -state disabled}
1823             {"Delete view" command delview -state disabled}
1824             {"" separator}
1825             {"All files" radiobutton {selectedview 0} -command {showview 0}}
1826         }}
1827         {"Help" cascade {
1828             {"About gitk" command about}
1829             {"Key bindings" command keys}
1830         }}
1831     }
1832     . configure -menu .bar
1834     # the gui has upper and lower half, parts of a paned window.
1835     panedwindow .ctop -orient vertical
1837     # possibly use assumed geometry
1838     if {![info exists geometry(pwsash0)]} {
1839         set geometry(topheight) [expr {15 * $linespc}]
1840         set geometry(topwidth) [expr {80 * $charspc}]
1841         set geometry(botheight) [expr {15 * $linespc}]
1842         set geometry(botwidth) [expr {50 * $charspc}]
1843         set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1844         set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1845     }
1847     # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1848     frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1849     frame .tf.histframe
1850     panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1852     # create three canvases
1853     set cscroll .tf.histframe.csb
1854     set canv .tf.histframe.pwclist.canv
1855     canvas $canv \
1856         -selectbackground $selectbgcolor \
1857         -background $bgcolor -bd 0 \
1858         -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1859     .tf.histframe.pwclist add $canv
1860     set canv2 .tf.histframe.pwclist.canv2
1861     canvas $canv2 \
1862         -selectbackground $selectbgcolor \
1863         -background $bgcolor -bd 0 -yscrollincr $linespc
1864     .tf.histframe.pwclist add $canv2
1865     set canv3 .tf.histframe.pwclist.canv3
1866     canvas $canv3 \
1867         -selectbackground $selectbgcolor \
1868         -background $bgcolor -bd 0 -yscrollincr $linespc
1869     .tf.histframe.pwclist add $canv3
1870     eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1871     eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1873     # a scroll bar to rule them
1874     scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1875     pack $cscroll -side right -fill y
1876     bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1877     lappend bglist $canv $canv2 $canv3
1878     pack .tf.histframe.pwclist -fill both -expand 1 -side left
1880     # we have two button bars at bottom of top frame. Bar 1
1881     frame .tf.bar
1882     frame .tf.lbar -height 15
1884     set sha1entry .tf.bar.sha1
1885     set entries $sha1entry
1886     set sha1but .tf.bar.sha1label
1887     button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1888         -command gotocommit -width 8
1889     $sha1but conf -disabledforeground [$sha1but cget -foreground]
1890     pack .tf.bar.sha1label -side left
1891     entry $sha1entry -width 40 -font textfont -textvariable sha1string
1892     trace add variable sha1string write sha1change
1893     pack $sha1entry -side left -pady 2
1895     image create bitmap bm-left -data {
1896         #define left_width 16
1897         #define left_height 16
1898         static unsigned char left_bits[] = {
1899         0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1900         0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1901         0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1902     }
1903     image create bitmap bm-right -data {
1904         #define right_width 16
1905         #define right_height 16
1906         static unsigned char right_bits[] = {
1907         0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1908         0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1909         0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1910     }
1911     button .tf.bar.leftbut -image bm-left -command goback \
1912         -state disabled -width 26
1913     pack .tf.bar.leftbut -side left -fill y
1914     button .tf.bar.rightbut -image bm-right -command goforw \
1915         -state disabled -width 26
1916     pack .tf.bar.rightbut -side left -fill y
1918     label .tf.bar.rowlabel -text [mc "Row"]
1919     set rownumsel {}
1920     label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1921         -relief sunken -anchor e
1922     label .tf.bar.rowlabel2 -text "/"
1923     label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1924         -relief sunken -anchor e
1925     pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1926         -side left
1927     global selectedline
1928     trace add variable selectedline write selectedline_change
1930     # Status label and progress bar
1931     set statusw .tf.bar.status
1932     label $statusw -width 15 -relief sunken
1933     pack $statusw -side left -padx 5
1934     set h [expr {[font metrics uifont -linespace] + 2}]
1935     set progresscanv .tf.bar.progress
1936     canvas $progresscanv -relief sunken -height $h -borderwidth 2
1937     set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1938     set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1939     set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1940     pack $progresscanv -side right -expand 1 -fill x
1941     set progresscoords {0 0}
1942     set fprogcoord 0
1943     set rprogcoord 0
1944     bind $progresscanv <Configure> adjustprogress
1945     set lastprogupdate [clock clicks -milliseconds]
1946     set progupdatepending 0
1948     # build up the bottom bar of upper window
1949     label .tf.lbar.flabel -text "[mc "Find"] "
1950     button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1951     button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1952     label .tf.lbar.flab2 -text " [mc "commit"] "
1953     pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1954         -side left -fill y
1955     set gdttype [mc "containing:"]
1956     set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1957                 [mc "containing:"] \
1958                 [mc "touching paths:"] \
1959                 [mc "adding/removing string:"]]
1960     trace add variable gdttype write gdttype_change
1961     pack .tf.lbar.gdttype -side left -fill y
1963     set findstring {}
1964     set fstring .tf.lbar.findstring
1965     lappend entries $fstring
1966     entry $fstring -width 30 -font textfont -textvariable findstring
1967     trace add variable findstring write find_change
1968     set findtype [mc "Exact"]
1969     set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1970                       findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1971     trace add variable findtype write findcom_change
1972     set findloc [mc "All fields"]
1973     tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1974         [mc "Comments"] [mc "Author"] [mc "Committer"]
1975     trace add variable findloc write find_change
1976     pack .tf.lbar.findloc -side right
1977     pack .tf.lbar.findtype -side right
1978     pack $fstring -side left -expand 1 -fill x
1980     # Finish putting the upper half of the viewer together
1981     pack .tf.lbar -in .tf -side bottom -fill x
1982     pack .tf.bar -in .tf -side bottom -fill x
1983     pack .tf.histframe -fill both -side top -expand 1
1984     .ctop add .tf
1985     .ctop paneconfigure .tf -height $geometry(topheight)
1986     .ctop paneconfigure .tf -width $geometry(topwidth)
1988     # now build up the bottom
1989     panedwindow .pwbottom -orient horizontal
1991     # lower left, a text box over search bar, scroll bar to the right
1992     # if we know window height, then that will set the lower text height, otherwise
1993     # we set lower text height which will drive window height
1994     if {[info exists geometry(main)]} {
1995         frame .bleft -width $geometry(botwidth)
1996     } else {
1997         frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1998     }
1999     frame .bleft.top
2000     frame .bleft.mid
2001     frame .bleft.bottom
2003     button .bleft.top.search -text [mc "Search"] -command dosearch
2004     pack .bleft.top.search -side left -padx 5
2005     set sstring .bleft.top.sstring
2006     entry $sstring -width 20 -font textfont -textvariable searchstring
2007     lappend entries $sstring
2008     trace add variable searchstring write incrsearch
2009     pack $sstring -side left -expand 1 -fill x
2010     radiobutton .bleft.mid.diff -text [mc "Diff"] \
2011         -command changediffdisp -variable diffelide -value {0 0}
2012     radiobutton .bleft.mid.old -text [mc "Old version"] \
2013         -command changediffdisp -variable diffelide -value {0 1}
2014     radiobutton .bleft.mid.new -text [mc "New version"] \
2015         -command changediffdisp -variable diffelide -value {1 0}
2016     label .bleft.mid.labeldiffcontext -text "      [mc "Lines of context"]: "
2017     pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2018     spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2019         -from 1 -increment 1 -to 10000000 \
2020         -validate all -validatecommand "diffcontextvalidate %P" \
2021         -textvariable diffcontextstring
2022     .bleft.mid.diffcontext set $diffcontext
2023     trace add variable diffcontextstring write diffcontextchange
2024     lappend entries .bleft.mid.diffcontext
2025     pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2026     checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2027         -command changeignorespace -variable ignorespace
2028     pack .bleft.mid.ignspace -side left -padx 5
2029     set ctext .bleft.bottom.ctext
2030     text $ctext -background $bgcolor -foreground $fgcolor \
2031         -state disabled -font textfont \
2032         -yscrollcommand scrolltext -wrap none \
2033         -xscrollcommand ".bleft.bottom.sbhorizontal set"
2034     if {$have_tk85} {
2035         $ctext conf -tabstyle wordprocessor
2036     }
2037     scrollbar .bleft.bottom.sb -command "$ctext yview"
2038     scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2039         -width 10
2040     pack .bleft.top -side top -fill x
2041     pack .bleft.mid -side top -fill x
2042     grid $ctext .bleft.bottom.sb -sticky nsew
2043     grid .bleft.bottom.sbhorizontal -sticky ew
2044     grid columnconfigure .bleft.bottom 0 -weight 1
2045     grid rowconfigure .bleft.bottom 0 -weight 1
2046     grid rowconfigure .bleft.bottom 1 -weight 0
2047     pack .bleft.bottom -side top -fill both -expand 1
2048     lappend bglist $ctext
2049     lappend fglist $ctext
2051     $ctext tag conf comment -wrap $wrapcomment
2052     $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2053     $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2054     $ctext tag conf d0 -fore [lindex $diffcolors 0]
2055     $ctext tag conf d1 -fore [lindex $diffcolors 1]
2056     $ctext tag conf m0 -fore red
2057     $ctext tag conf m1 -fore blue
2058     $ctext tag conf m2 -fore green
2059     $ctext tag conf m3 -fore purple
2060     $ctext tag conf m4 -fore brown
2061     $ctext tag conf m5 -fore "#009090"
2062     $ctext tag conf m6 -fore magenta
2063     $ctext tag conf m7 -fore "#808000"
2064     $ctext tag conf m8 -fore "#009000"
2065     $ctext tag conf m9 -fore "#ff0080"
2066     $ctext tag conf m10 -fore cyan
2067     $ctext tag conf m11 -fore "#b07070"
2068     $ctext tag conf m12 -fore "#70b0f0"
2069     $ctext tag conf m13 -fore "#70f0b0"
2070     $ctext tag conf m14 -fore "#f0b070"
2071     $ctext tag conf m15 -fore "#ff70b0"
2072     $ctext tag conf mmax -fore darkgrey
2073     set mergemax 16
2074     $ctext tag conf mresult -font textfontbold
2075     $ctext tag conf msep -font textfontbold
2076     $ctext tag conf found -back yellow
2078     .pwbottom add .bleft
2079     .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2081     # lower right
2082     frame .bright
2083     frame .bright.mode
2084     radiobutton .bright.mode.patch -text [mc "Patch"] \
2085         -command reselectline -variable cmitmode -value "patch"
2086     radiobutton .bright.mode.tree -text [mc "Tree"] \
2087         -command reselectline -variable cmitmode -value "tree"
2088     grid .bright.mode.patch .bright.mode.tree -sticky ew
2089     pack .bright.mode -side top -fill x
2090     set cflist .bright.cfiles
2091     set indent [font measure mainfont "nn"]
2092     text $cflist \
2093         -selectbackground $selectbgcolor \
2094         -background $bgcolor -foreground $fgcolor \
2095         -font mainfont \
2096         -tabs [list $indent [expr {2 * $indent}]] \
2097         -yscrollcommand ".bright.sb set" \
2098         -cursor [. cget -cursor] \
2099         -spacing1 1 -spacing3 1
2100     lappend bglist $cflist
2101     lappend fglist $cflist
2102     scrollbar .bright.sb -command "$cflist yview"
2103     pack .bright.sb -side right -fill y
2104     pack $cflist -side left -fill both -expand 1
2105     $cflist tag configure highlight \
2106         -background [$cflist cget -selectbackground]
2107     $cflist tag configure bold -font mainfontbold
2109     .pwbottom add .bright
2110     .ctop add .pwbottom
2112     # restore window width & height if known
2113     if {[info exists geometry(main)]} {
2114         if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2115             if {$w > [winfo screenwidth .]} {
2116                 set w [winfo screenwidth .]
2117             }
2118             if {$h > [winfo screenheight .]} {
2119                 set h [winfo screenheight .]
2120             }
2121             wm geometry . "${w}x$h"
2122         }
2123     }
2125     if {[tk windowingsystem] eq {aqua}} {
2126         set M1B M1
2127     } else {
2128         set M1B Control
2129     }
2131     bind .pwbottom <Configure> {resizecdetpanes %W %w}
2132     pack .ctop -fill both -expand 1
2133     bindall <1> {selcanvline %W %x %y}
2134     #bindall <B1-Motion> {selcanvline %W %x %y}
2135     if {[tk windowingsystem] == "win32"} {
2136         bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2137         bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2138     } else {
2139         bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2140         bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2141         if {[tk windowingsystem] eq "aqua"} {
2142             bindall <MouseWheel> {
2143                 set delta [expr {- (%D)}]
2144                 allcanvs yview scroll $delta units
2145             }
2146         }
2147     }
2148     bindall <2> "canvscan mark %W %x %y"
2149     bindall <B2-Motion> "canvscan dragto %W %x %y"
2150     bindkey <Home> selfirstline
2151     bindkey <End> sellastline
2152     bind . <Key-Up> "selnextline -1"
2153     bind . <Key-Down> "selnextline 1"
2154     bind . <Shift-Key-Up> "dofind -1 0"
2155     bind . <Shift-Key-Down> "dofind 1 0"
2156     bindkey <Key-Right> "goforw"
2157     bindkey <Key-Left> "goback"
2158     bind . <Key-Prior> "selnextpage -1"
2159     bind . <Key-Next> "selnextpage 1"
2160     bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2161     bind . <$M1B-End> "allcanvs yview moveto 1.0"
2162     bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2163     bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2164     bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2165     bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2166     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2167     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2168     bindkey <Key-space> "$ctext yview scroll 1 pages"
2169     bindkey p "selnextline -1"
2170     bindkey n "selnextline 1"
2171     bindkey z "goback"
2172     bindkey x "goforw"
2173     bindkey i "selnextline -1"
2174     bindkey k "selnextline 1"
2175     bindkey j "goback"
2176     bindkey l "goforw"
2177     bindkey b prevfile
2178     bindkey d "$ctext yview scroll 18 units"
2179     bindkey u "$ctext yview scroll -18 units"
2180     bindkey / {dofind 1 1}
2181     bindkey <Key-Return> {dofind 1 1}
2182     bindkey ? {dofind -1 1}
2183     bindkey f nextfile
2184     bindkey <F5> updatecommits
2185     bind . <$M1B-q> doquit
2186     bind . <$M1B-f> {dofind 1 1}
2187     bind . <$M1B-g> {dofind 1 0}
2188     bind . <$M1B-r> dosearchback
2189     bind . <$M1B-s> dosearch
2190     bind . <$M1B-equal> {incrfont 1}
2191     bind . <$M1B-plus> {incrfont 1}
2192     bind . <$M1B-KP_Add> {incrfont 1}
2193     bind . <$M1B-minus> {incrfont -1}
2194     bind . <$M1B-KP_Subtract> {incrfont -1}
2195     wm protocol . WM_DELETE_WINDOW doquit
2196     bind . <Destroy> {stop_backends}
2197     bind . <Button-1> "click %W"
2198     bind $fstring <Key-Return> {dofind 1 1}
2199     bind $sha1entry <Key-Return> {gotocommit; break}
2200     bind $sha1entry <<PasteSelection>> clearsha1
2201     bind $cflist <1> {sel_flist %W %x %y; break}
2202     bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2203     bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2204     global ctxbut
2205     bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2207     set maincursor [. cget -cursor]
2208     set textcursor [$ctext cget -cursor]
2209     set curtextcursor $textcursor
2211     set rowctxmenu .rowctxmenu
2212     makemenu $rowctxmenu {
2213         {"Diff this -> selected" command {diffvssel 0}}
2214         {"Diff selected -> this" command {diffvssel 1}}
2215         {"Make patch" command mkpatch}
2216         {"Create tag" command mktag}
2217         {"Write commit to file" command writecommit}
2218         {"Create new branch" command mkbranch}
2219         {"Cherry-pick this commit" command cherrypick}
2220         {"Reset HEAD branch to here" command resethead}
2221     }
2222     $rowctxmenu configure -tearoff 0
2224     set fakerowmenu .fakerowmenu
2225     makemenu $fakerowmenu {
2226         {"Diff this -> selected" command {diffvssel 0}}
2227         {"Diff selected -> this" command {diffvssel 1}}
2228         {"Make patch" command mkpatch}
2229     }
2230     $fakerowmenu configure -tearoff 0
2232     set headctxmenu .headctxmenu
2233     makemenu $headctxmenu {
2234         {"Check out this branch" command cobranch}
2235         {"Remove this branch" command rmbranch}
2236     }
2237     $headctxmenu configure -tearoff 0
2239     global flist_menu
2240     set flist_menu .flistctxmenu
2241     makemenu $flist_menu {
2242         {"Highlight this too" command {flist_hl 0}}
2243         {"Highlight this only" command {flist_hl 1}}
2244         {"External diff" command {external_diff}}
2245         {"Blame parent commit" command {external_blame 1}}
2246     }
2247     $flist_menu configure -tearoff 0
2250 # Windows sends all mouse wheel events to the current focused window, not
2251 # the one where the mouse hovers, so bind those events here and redirect
2252 # to the correct window
2253 proc windows_mousewheel_redirector {W X Y D} {
2254     global canv canv2 canv3
2255     set w [winfo containing -displayof $W $X $Y]
2256     if {$w ne ""} {
2257         set u [expr {$D < 0 ? 5 : -5}]
2258         if {$w == $canv || $w == $canv2 || $w == $canv3} {
2259             allcanvs yview scroll $u units
2260         } else {
2261             catch {
2262                 $w yview scroll $u units
2263             }
2264         }
2265     }
2268 # Update row number label when selectedline changes
2269 proc selectedline_change {n1 n2 op} {
2270     global selectedline rownumsel
2272     if {$selectedline eq {}} {
2273         set rownumsel {}
2274     } else {
2275         set rownumsel [expr {$selectedline + 1}]
2276     }
2279 # mouse-2 makes all windows scan vertically, but only the one
2280 # the cursor is in scans horizontally
2281 proc canvscan {op w x y} {
2282     global canv canv2 canv3
2283     foreach c [list $canv $canv2 $canv3] {
2284         if {$c == $w} {
2285             $c scan $op $x $y
2286         } else {
2287             $c scan $op 0 $y
2288         }
2289     }
2292 proc scrollcanv {cscroll f0 f1} {
2293     $cscroll set $f0 $f1
2294     drawvisible
2295     flushhighlights
2298 # when we make a key binding for the toplevel, make sure
2299 # it doesn't get triggered when that key is pressed in the
2300 # find string entry widget.
2301 proc bindkey {ev script} {
2302     global entries
2303     bind . $ev $script
2304     set escript [bind Entry $ev]
2305     if {$escript == {}} {
2306         set escript [bind Entry <Key>]
2307     }
2308     foreach e $entries {
2309         bind $e $ev "$escript; break"
2310     }
2313 # set the focus back to the toplevel for any click outside
2314 # the entry widgets
2315 proc click {w} {
2316     global ctext entries
2317     foreach e [concat $entries $ctext] {
2318         if {$w == $e} return
2319     }
2320     focus .
2323 # Adjust the progress bar for a change in requested extent or canvas size
2324 proc adjustprogress {} {
2325     global progresscanv progressitem progresscoords
2326     global fprogitem fprogcoord lastprogupdate progupdatepending
2327     global rprogitem rprogcoord
2329     set w [expr {[winfo width $progresscanv] - 4}]
2330     set x0 [expr {$w * [lindex $progresscoords 0]}]
2331     set x1 [expr {$w * [lindex $progresscoords 1]}]
2332     set h [winfo height $progresscanv]
2333     $progresscanv coords $progressitem $x0 0 $x1 $h
2334     $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2335     $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2336     set now [clock clicks -milliseconds]
2337     if {$now >= $lastprogupdate + 100} {
2338         set progupdatepending 0
2339         update
2340     } elseif {!$progupdatepending} {
2341         set progupdatepending 1
2342         after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2343     }
2346 proc doprogupdate {} {
2347     global lastprogupdate progupdatepending
2349     if {$progupdatepending} {
2350         set progupdatepending 0
2351         set lastprogupdate [clock clicks -milliseconds]
2352         update
2353     }
2356 proc savestuff {w} {
2357     global canv canv2 canv3 mainfont textfont uifont tabstop
2358     global stuffsaved findmergefiles maxgraphpct
2359     global maxwidth showneartags showlocalchanges
2360     global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2361     global cmitmode wrapcomment datetimeformat limitdiffs
2362     global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2363     global autoselect extdifftool perfile_attrs
2365     if {$stuffsaved} return
2366     if {![winfo viewable .]} return
2367     catch {
2368         set f [open "~/.gitk-new" w]
2369         puts $f [list set mainfont $mainfont]
2370         puts $f [list set textfont $textfont]
2371         puts $f [list set uifont $uifont]
2372         puts $f [list set tabstop $tabstop]
2373         puts $f [list set findmergefiles $findmergefiles]
2374         puts $f [list set maxgraphpct $maxgraphpct]
2375         puts $f [list set maxwidth $maxwidth]
2376         puts $f [list set cmitmode $cmitmode]
2377         puts $f [list set wrapcomment $wrapcomment]
2378         puts $f [list set autoselect $autoselect]
2379         puts $f [list set showneartags $showneartags]
2380         puts $f [list set showlocalchanges $showlocalchanges]
2381         puts $f [list set datetimeformat $datetimeformat]
2382         puts $f [list set limitdiffs $limitdiffs]
2383         puts $f [list set bgcolor $bgcolor]
2384         puts $f [list set fgcolor $fgcolor]
2385         puts $f [list set colors $colors]
2386         puts $f [list set diffcolors $diffcolors]
2387         puts $f [list set diffcontext $diffcontext]
2388         puts $f [list set selectbgcolor $selectbgcolor]
2389         puts $f [list set extdifftool $extdifftool]
2390         puts $f [list set perfile_attrs $perfile_attrs]
2392         puts $f "set geometry(main) [wm geometry .]"
2393         puts $f "set geometry(topwidth) [winfo width .tf]"
2394         puts $f "set geometry(topheight) [winfo height .tf]"
2395         puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2396         puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2397         puts $f "set geometry(botwidth) [winfo width .bleft]"
2398         puts $f "set geometry(botheight) [winfo height .bleft]"
2400         puts -nonewline $f "set permviews {"
2401         for {set v 0} {$v < $nextviewnum} {incr v} {
2402             if {$viewperm($v)} {
2403                 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2404             }
2405         }
2406         puts $f "}"
2407         close $f
2408         file rename -force "~/.gitk-new" "~/.gitk"
2409     }
2410     set stuffsaved 1
2413 proc resizeclistpanes {win w} {
2414     global oldwidth
2415     if {[info exists oldwidth($win)]} {
2416         set s0 [$win sash coord 0]
2417         set s1 [$win sash coord 1]
2418         if {$w < 60} {
2419             set sash0 [expr {int($w/2 - 2)}]
2420             set sash1 [expr {int($w*5/6 - 2)}]
2421         } else {
2422             set factor [expr {1.0 * $w / $oldwidth($win)}]
2423             set sash0 [expr {int($factor * [lindex $s0 0])}]
2424             set sash1 [expr {int($factor * [lindex $s1 0])}]
2425             if {$sash0 < 30} {
2426                 set sash0 30
2427             }
2428             if {$sash1 < $sash0 + 20} {
2429                 set sash1 [expr {$sash0 + 20}]
2430             }
2431             if {$sash1 > $w - 10} {
2432                 set sash1 [expr {$w - 10}]
2433                 if {$sash0 > $sash1 - 20} {
2434                     set sash0 [expr {$sash1 - 20}]
2435                 }
2436             }
2437         }
2438         $win sash place 0 $sash0 [lindex $s0 1]
2439         $win sash place 1 $sash1 [lindex $s1 1]
2440     }
2441     set oldwidth($win) $w
2444 proc resizecdetpanes {win w} {
2445     global oldwidth
2446     if {[info exists oldwidth($win)]} {
2447         set s0 [$win sash coord 0]
2448         if {$w < 60} {
2449             set sash0 [expr {int($w*3/4 - 2)}]
2450         } else {
2451             set factor [expr {1.0 * $w / $oldwidth($win)}]
2452             set sash0 [expr {int($factor * [lindex $s0 0])}]
2453             if {$sash0 < 45} {
2454                 set sash0 45
2455             }
2456             if {$sash0 > $w - 15} {
2457                 set sash0 [expr {$w - 15}]
2458             }
2459         }
2460         $win sash place 0 $sash0 [lindex $s0 1]
2461     }
2462     set oldwidth($win) $w
2465 proc allcanvs args {
2466     global canv canv2 canv3
2467     eval $canv $args
2468     eval $canv2 $args
2469     eval $canv3 $args
2472 proc bindall {event action} {
2473     global canv canv2 canv3
2474     bind $canv $event $action
2475     bind $canv2 $event $action
2476     bind $canv3 $event $action
2479 proc about {} {
2480     global uifont
2481     set w .about
2482     if {[winfo exists $w]} {
2483         raise $w
2484         return
2485     }
2486     toplevel $w
2487     wm title $w [mc "About gitk"]
2488     message $w.m -text [mc "
2489 Gitk - a commit viewer for git
2491 Copyright © 2005-2008 Paul Mackerras
2493 Use and redistribute under the terms of the GNU General Public License"] \
2494             -justify center -aspect 400 -border 2 -bg white -relief groove
2495     pack $w.m -side top -fill x -padx 2 -pady 2
2496     button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2497     pack $w.ok -side bottom
2498     bind $w <Visibility> "focus $w.ok"
2499     bind $w <Key-Escape> "destroy $w"
2500     bind $w <Key-Return> "destroy $w"
2503 proc keys {} {
2504     set w .keys
2505     if {[winfo exists $w]} {
2506         raise $w
2507         return
2508     }
2509     if {[tk windowingsystem] eq {aqua}} {
2510         set M1T Cmd
2511     } else {
2512         set M1T Ctrl
2513     }
2514     toplevel $w
2515     wm title $w [mc "Gitk key bindings"]
2516     message $w.m -text "
2517 [mc "Gitk key bindings:"]
2519 [mc "<%s-Q>             Quit" $M1T]
2520 [mc "<Home>             Move to first commit"]
2521 [mc "<End>              Move to last commit"]
2522 [mc "<Up>, p, i Move up one commit"]
2523 [mc "<Down>, n, k       Move down one commit"]
2524 [mc "<Left>, z, j       Go back in history list"]
2525 [mc "<Right>, x, l      Go forward in history list"]
2526 [mc "<PageUp>   Move up one page in commit list"]
2527 [mc "<PageDown> Move down one page in commit list"]
2528 [mc "<%s-Home>  Scroll to top of commit list" $M1T]
2529 [mc "<%s-End>   Scroll to bottom of commit list" $M1T]
2530 [mc "<%s-Up>    Scroll commit list up one line" $M1T]
2531 [mc "<%s-Down>  Scroll commit list down one line" $M1T]
2532 [mc "<%s-PageUp>        Scroll commit list up one page" $M1T]
2533 [mc "<%s-PageDown>      Scroll commit list down one page" $M1T]
2534 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2535 [mc "<Shift-Down>       Find forwards (downwards, earlier commits)"]
2536 [mc "<Delete>, b        Scroll diff view up one page"]
2537 [mc "<Backspace>        Scroll diff view up one page"]
2538 [mc "<Space>            Scroll diff view down one page"]
2539 [mc "u          Scroll diff view up 18 lines"]
2540 [mc "d          Scroll diff view down 18 lines"]
2541 [mc "<%s-F>             Find" $M1T]
2542 [mc "<%s-G>             Move to next find hit" $M1T]
2543 [mc "<Return>   Move to next find hit"]
2544 [mc "/          Move to next find hit, or redo find"]
2545 [mc "?          Move to previous find hit"]
2546 [mc "f          Scroll diff view to next file"]
2547 [mc "<%s-S>             Search for next hit in diff view" $M1T]
2548 [mc "<%s-R>             Search for previous hit in diff view" $M1T]
2549 [mc "<%s-KP+>   Increase font size" $M1T]
2550 [mc "<%s-plus>  Increase font size" $M1T]
2551 [mc "<%s-KP->   Decrease font size" $M1T]
2552 [mc "<%s-minus> Decrease font size" $M1T]
2553 [mc "<F5>               Update"]
2554 " \
2555             -justify left -bg white -border 2 -relief groove
2556     pack $w.m -side top -fill both -padx 2 -pady 2
2557     button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2558     pack $w.ok -side bottom
2559     bind $w <Visibility> "focus $w.ok"
2560     bind $w <Key-Escape> "destroy $w"
2561     bind $w <Key-Return> "destroy $w"
2564 # Procedures for manipulating the file list window at the
2565 # bottom right of the overall window.
2567 proc treeview {w l openlevs} {
2568     global treecontents treediropen treeheight treeparent treeindex
2570     set ix 0
2571     set treeindex() 0
2572     set lev 0
2573     set prefix {}
2574     set prefixend -1
2575     set prefendstack {}
2576     set htstack {}
2577     set ht 0
2578     set treecontents() {}
2579     $w conf -state normal
2580     foreach f $l {
2581         while {[string range $f 0 $prefixend] ne $prefix} {
2582             if {$lev <= $openlevs} {
2583                 $w mark set e:$treeindex($prefix) "end -1c"
2584                 $w mark gravity e:$treeindex($prefix) left
2585             }
2586             set treeheight($prefix) $ht
2587             incr ht [lindex $htstack end]
2588             set htstack [lreplace $htstack end end]
2589             set prefixend [lindex $prefendstack end]
2590             set prefendstack [lreplace $prefendstack end end]
2591             set prefix [string range $prefix 0 $prefixend]
2592             incr lev -1
2593         }
2594         set tail [string range $f [expr {$prefixend+1}] end]
2595         while {[set slash [string first "/" $tail]] >= 0} {
2596             lappend htstack $ht
2597             set ht 0
2598             lappend prefendstack $prefixend
2599             incr prefixend [expr {$slash + 1}]
2600             set d [string range $tail 0 $slash]
2601             lappend treecontents($prefix) $d
2602             set oldprefix $prefix
2603             append prefix $d
2604             set treecontents($prefix) {}
2605             set treeindex($prefix) [incr ix]
2606             set treeparent($prefix) $oldprefix
2607             set tail [string range $tail [expr {$slash+1}] end]
2608             if {$lev <= $openlevs} {
2609                 set ht 1
2610                 set treediropen($prefix) [expr {$lev < $openlevs}]
2611                 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2612                 $w mark set d:$ix "end -1c"
2613                 $w mark gravity d:$ix left
2614                 set str "\n"
2615                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2616                 $w insert end $str
2617                 $w image create end -align center -image $bm -padx 1 \
2618                     -name a:$ix
2619                 $w insert end $d [highlight_tag $prefix]
2620                 $w mark set s:$ix "end -1c"
2621                 $w mark gravity s:$ix left
2622             }
2623             incr lev
2624         }
2625         if {$tail ne {}} {
2626             if {$lev <= $openlevs} {
2627                 incr ht
2628                 set str "\n"
2629                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2630                 $w insert end $str
2631                 $w insert end $tail [highlight_tag $f]
2632             }
2633             lappend treecontents($prefix) $tail
2634         }
2635     }
2636     while {$htstack ne {}} {
2637         set treeheight($prefix) $ht
2638         incr ht [lindex $htstack end]
2639         set htstack [lreplace $htstack end end]
2640         set prefixend [lindex $prefendstack end]
2641         set prefendstack [lreplace $prefendstack end end]
2642         set prefix [string range $prefix 0 $prefixend]
2643     }
2644     $w conf -state disabled
2647 proc linetoelt {l} {
2648     global treeheight treecontents
2650     set y 2
2651     set prefix {}
2652     while {1} {
2653         foreach e $treecontents($prefix) {
2654             if {$y == $l} {
2655                 return "$prefix$e"
2656             }
2657             set n 1
2658             if {[string index $e end] eq "/"} {
2659                 set n $treeheight($prefix$e)
2660                 if {$y + $n > $l} {
2661                     append prefix $e
2662                     incr y
2663                     break
2664                 }
2665             }
2666             incr y $n
2667         }
2668     }
2671 proc highlight_tree {y prefix} {
2672     global treeheight treecontents cflist
2674     foreach e $treecontents($prefix) {
2675         set path $prefix$e
2676         if {[highlight_tag $path] ne {}} {
2677             $cflist tag add bold $y.0 "$y.0 lineend"
2678         }
2679         incr y
2680         if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2681             set y [highlight_tree $y $path]
2682         }
2683     }
2684     return $y
2687 proc treeclosedir {w dir} {
2688     global treediropen treeheight treeparent treeindex
2690     set ix $treeindex($dir)
2691     $w conf -state normal
2692     $w delete s:$ix e:$ix
2693     set treediropen($dir) 0
2694     $w image configure a:$ix -image tri-rt
2695     $w conf -state disabled
2696     set n [expr {1 - $treeheight($dir)}]
2697     while {$dir ne {}} {
2698         incr treeheight($dir) $n
2699         set dir $treeparent($dir)
2700     }
2703 proc treeopendir {w dir} {
2704     global treediropen treeheight treeparent treecontents treeindex
2706     set ix $treeindex($dir)
2707     $w conf -state normal
2708     $w image configure a:$ix -image tri-dn
2709     $w mark set e:$ix s:$ix
2710     $w mark gravity e:$ix right
2711     set lev 0
2712     set str "\n"
2713     set n [llength $treecontents($dir)]
2714     for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2715         incr lev
2716         append str "\t"
2717         incr treeheight($x) $n
2718     }
2719     foreach e $treecontents($dir) {
2720         set de $dir$e
2721         if {[string index $e end] eq "/"} {
2722             set iy $treeindex($de)
2723             $w mark set d:$iy e:$ix
2724             $w mark gravity d:$iy left
2725             $w insert e:$ix $str
2726             set treediropen($de) 0
2727             $w image create e:$ix -align center -image tri-rt -padx 1 \
2728                 -name a:$iy
2729             $w insert e:$ix $e [highlight_tag $de]
2730             $w mark set s:$iy e:$ix
2731             $w mark gravity s:$iy left
2732             set treeheight($de) 1
2733         } else {
2734             $w insert e:$ix $str
2735             $w insert e:$ix $e [highlight_tag $de]
2736         }
2737     }
2738     $w mark gravity e:$ix right
2739     $w conf -state disabled
2740     set treediropen($dir) 1
2741     set top [lindex [split [$w index @0,0] .] 0]
2742     set ht [$w cget -height]
2743     set l [lindex [split [$w index s:$ix] .] 0]
2744     if {$l < $top} {
2745         $w yview $l.0
2746     } elseif {$l + $n + 1 > $top + $ht} {
2747         set top [expr {$l + $n + 2 - $ht}]
2748         if {$l < $top} {
2749             set top $l
2750         }
2751         $w yview $top.0
2752     }
2755 proc treeclick {w x y} {
2756     global treediropen cmitmode ctext cflist cflist_top
2758     if {$cmitmode ne "tree"} return
2759     if {![info exists cflist_top]} return
2760     set l [lindex [split [$w index "@$x,$y"] "."] 0]
2761     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2762     $cflist tag add highlight $l.0 "$l.0 lineend"
2763     set cflist_top $l
2764     if {$l == 1} {
2765         $ctext yview 1.0
2766         return
2767     }
2768     set e [linetoelt $l]
2769     if {[string index $e end] ne "/"} {
2770         showfile $e
2771     } elseif {$treediropen($e)} {
2772         treeclosedir $w $e
2773     } else {
2774         treeopendir $w $e
2775     }
2778 proc setfilelist {id} {
2779     global treefilelist cflist
2781     treeview $cflist $treefilelist($id) 0
2784 image create bitmap tri-rt -background black -foreground blue -data {
2785     #define tri-rt_width 13
2786     #define tri-rt_height 13
2787     static unsigned char tri-rt_bits[] = {
2788        0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2789        0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2790        0x00, 0x00};
2791 } -maskdata {
2792     #define tri-rt-mask_width 13
2793     #define tri-rt-mask_height 13
2794     static unsigned char tri-rt-mask_bits[] = {
2795        0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2796        0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2797        0x08, 0x00};
2799 image create bitmap tri-dn -background black -foreground blue -data {
2800     #define tri-dn_width 13
2801     #define tri-dn_height 13
2802     static unsigned char tri-dn_bits[] = {
2803        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2804        0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2805        0x00, 0x00};
2806 } -maskdata {
2807     #define tri-dn-mask_width 13
2808     #define tri-dn-mask_height 13
2809     static unsigned char tri-dn-mask_bits[] = {
2810        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2811        0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2812        0x00, 0x00};
2815 image create bitmap reficon-T -background black -foreground yellow -data {
2816     #define tagicon_width 13
2817     #define tagicon_height 9
2818     static unsigned char tagicon_bits[] = {
2819        0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2820        0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2821 } -maskdata {
2822     #define tagicon-mask_width 13
2823     #define tagicon-mask_height 9
2824     static unsigned char tagicon-mask_bits[] = {
2825        0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2826        0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2828 set rectdata {
2829     #define headicon_width 13
2830     #define headicon_height 9
2831     static unsigned char headicon_bits[] = {
2832        0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2833        0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2835 set rectmask {
2836     #define headicon-mask_width 13
2837     #define headicon-mask_height 9
2838     static unsigned char headicon-mask_bits[] = {
2839        0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2840        0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2842 image create bitmap reficon-H -background black -foreground green \
2843     -data $rectdata -maskdata $rectmask
2844 image create bitmap reficon-o -background black -foreground "#ddddff" \
2845     -data $rectdata -maskdata $rectmask
2847 proc init_flist {first} {
2848     global cflist cflist_top difffilestart
2850     $cflist conf -state normal
2851     $cflist delete 0.0 end
2852     if {$first ne {}} {
2853         $cflist insert end $first
2854         set cflist_top 1
2855         $cflist tag add highlight 1.0 "1.0 lineend"
2856     } else {
2857         catch {unset cflist_top}
2858     }
2859     $cflist conf -state disabled
2860     set difffilestart {}
2863 proc highlight_tag {f} {
2864     global highlight_paths
2866     foreach p $highlight_paths {
2867         if {[string match $p $f]} {
2868             return "bold"
2869         }
2870     }
2871     return {}
2874 proc highlight_filelist {} {
2875     global cmitmode cflist
2877     $cflist conf -state normal
2878     if {$cmitmode ne "tree"} {
2879         set end [lindex [split [$cflist index end] .] 0]
2880         for {set l 2} {$l < $end} {incr l} {
2881             set line [$cflist get $l.0 "$l.0 lineend"]
2882             if {[highlight_tag $line] ne {}} {
2883                 $cflist tag add bold $l.0 "$l.0 lineend"
2884             }
2885         }
2886     } else {
2887         highlight_tree 2 {}
2888     }
2889     $cflist conf -state disabled
2892 proc unhighlight_filelist {} {
2893     global cflist
2895     $cflist conf -state normal
2896     $cflist tag remove bold 1.0 end
2897     $cflist conf -state disabled
2900 proc add_flist {fl} {
2901     global cflist
2903     $cflist conf -state normal
2904     foreach f $fl {
2905         $cflist insert end "\n"
2906         $cflist insert end $f [highlight_tag $f]
2907     }
2908     $cflist conf -state disabled
2911 proc sel_flist {w x y} {
2912     global ctext difffilestart cflist cflist_top cmitmode
2914     if {$cmitmode eq "tree"} return
2915     if {![info exists cflist_top]} return
2916     set l [lindex [split [$w index "@$x,$y"] "."] 0]
2917     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2918     $cflist tag add highlight $l.0 "$l.0 lineend"
2919     set cflist_top $l
2920     if {$l == 1} {
2921         $ctext yview 1.0
2922     } else {
2923         catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2924     }
2927 proc pop_flist_menu {w X Y x y} {
2928     global ctext cflist cmitmode flist_menu flist_menu_file
2929     global treediffs diffids
2931     stopfinding
2932     set l [lindex [split [$w index "@$x,$y"] "."] 0]
2933     if {$l <= 1} return
2934     if {$cmitmode eq "tree"} {
2935         set e [linetoelt $l]
2936         if {[string index $e end] eq "/"} return
2937     } else {
2938         set e [lindex $treediffs($diffids) [expr {$l-2}]]
2939     }
2940     set flist_menu_file $e
2941     set xdiffstate "normal"
2942     if {$cmitmode eq "tree"} {
2943         set xdiffstate "disabled"
2944     }
2945     # Disable "External diff" item in tree mode
2946     $flist_menu entryconf 2 -state $xdiffstate
2947     tk_popup $flist_menu $X $Y
2950 proc flist_hl {only} {
2951     global flist_menu_file findstring gdttype
2953     set x [shellquote $flist_menu_file]
2954     if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2955         set findstring $x
2956     } else {
2957         append findstring " " $x
2958     }
2959     set gdttype [mc "touching paths:"]
2962 proc save_file_from_commit {filename output what} {
2963     global nullfile
2965     if {[catch {exec git show $filename -- > $output} err]} {
2966         if {[string match "fatal: bad revision *" $err]} {
2967             return $nullfile
2968         }
2969         error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
2970         return {}
2971     }
2972     return $output
2975 proc external_diff_get_one_file {diffid filename diffdir} {
2976     global nullid nullid2 nullfile
2977     global gitdir
2979     if {$diffid == $nullid} {
2980         set difffile [file join [file dirname $gitdir] $filename]
2981         if {[file exists $difffile]} {
2982             return $difffile
2983         }
2984         return $nullfile
2985     }
2986     if {$diffid == $nullid2} {
2987         set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2988         return [save_file_from_commit :$filename $difffile index]
2989     }
2990     set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2991     return [save_file_from_commit $diffid:$filename $difffile \
2992                "revision $diffid"]
2995 proc external_diff {} {
2996     global gitktmpdir nullid nullid2
2997     global flist_menu_file
2998     global diffids
2999     global diffnum
3000     global gitdir extdifftool
3002     if {[llength $diffids] == 1} {
3003         # no reference commit given
3004         set diffidto [lindex $diffids 0]
3005         if {$diffidto eq $nullid} {
3006             # diffing working copy with index
3007             set diffidfrom $nullid2
3008         } elseif {$diffidto eq $nullid2} {
3009             # diffing index with HEAD
3010             set diffidfrom "HEAD"
3011         } else {
3012             # use first parent commit
3013             global parentlist selectedline
3014             set diffidfrom [lindex $parentlist $selectedline 0]
3015         }
3016     } else {
3017         set diffidfrom [lindex $diffids 0]
3018         set diffidto [lindex $diffids 1]
3019     }
3021     # make sure that several diffs wont collide
3022     if {![info exists gitktmpdir]} {
3023         set gitktmpdir [file join [file dirname $gitdir] \
3024                             [format ".gitk-tmp.%s" [pid]]]
3025         if {[catch {file mkdir $gitktmpdir} err]} {
3026             error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3027             unset gitktmpdir
3028             return
3029         }
3030         set diffnum 0
3031     }
3032     incr diffnum
3033     set diffdir [file join $gitktmpdir $diffnum]
3034     if {[catch {file mkdir $diffdir} err]} {
3035         error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3036         return
3037     }
3039     # gather files to diff
3040     set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3041     set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3043     if {$difffromfile ne {} && $difftofile ne {}} {
3044         set cmd [concat | [shellsplit $extdifftool] \
3045                      [list $difffromfile $difftofile]]
3046         if {[catch {set fl [open $cmd r]} err]} {
3047             file delete -force $diffdir
3048             error_popup "$extdifftool: [mc "command failed:"] $err"
3049         } else {
3050             fconfigure $fl -blocking 0
3051             filerun $fl [list delete_at_eof $fl $diffdir]
3052         }
3053     }
3056 proc external_blame {parent_idx} {
3057     global flist_menu_file
3058     global nullid nullid2
3059     global parentlist selectedline currentid
3061     if {$parent_idx > 0} {
3062         set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3063     } else {
3064         set base_commit $currentid
3065     }
3067     if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3068         error_popup [mc "No such commit"]
3069         return
3070     }
3072     if {[catch {exec git gui blame $base_commit $flist_menu_file &} err]} {
3073         error_popup "[mc "git gui blame: command failed:"] $err"
3074     }
3077 # delete $dir when we see eof on $f (presumably because the child has exited)
3078 proc delete_at_eof {f dir} {
3079     while {[gets $f line] >= 0} {}
3080     if {[eof $f]} {
3081         if {[catch {close $f} err]} {
3082             error_popup "[mc "External diff viewer failed:"] $err"
3083         }
3084         file delete -force $dir
3085         return 0
3086     }
3087     return 1
3090 # Functions for adding and removing shell-type quoting
3092 proc shellquote {str} {
3093     if {![string match "*\['\"\\ \t]*" $str]} {
3094         return $str
3095     }
3096     if {![string match "*\['\"\\]*" $str]} {
3097         return "\"$str\""
3098     }
3099     if {![string match "*'*" $str]} {
3100         return "'$str'"
3101     }
3102     return "\"[string map {\" \\\" \\ \\\\} $str]\""
3105 proc shellarglist {l} {
3106     set str {}
3107     foreach a $l {
3108         if {$str ne {}} {
3109             append str " "
3110         }
3111         append str [shellquote $a]
3112     }
3113     return $str
3116 proc shelldequote {str} {
3117     set ret {}
3118     set used -1
3119     while {1} {
3120         incr used
3121         if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3122             append ret [string range $str $used end]
3123             set used [string length $str]
3124             break
3125         }
3126         set first [lindex $first 0]
3127         set ch [string index $str $first]
3128         if {$first > $used} {
3129             append ret [string range $str $used [expr {$first - 1}]]
3130             set used $first
3131         }
3132         if {$ch eq " " || $ch eq "\t"} break
3133         incr used
3134         if {$ch eq "'"} {
3135             set first [string first "'" $str $used]
3136             if {$first < 0} {
3137                 error "unmatched single-quote"
3138             }
3139             append ret [string range $str $used [expr {$first - 1}]]
3140             set used $first
3141             continue
3142         }
3143         if {$ch eq "\\"} {
3144             if {$used >= [string length $str]} {
3145                 error "trailing backslash"
3146             }
3147             append ret [string index $str $used]
3148             continue
3149         }
3150         # here ch == "\""
3151         while {1} {
3152             if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3153                 error "unmatched double-quote"
3154             }
3155             set first [lindex $first 0]
3156             set ch [string index $str $first]
3157             if {$first > $used} {
3158                 append ret [string range $str $used [expr {$first - 1}]]
3159                 set used $first
3160             }
3161             if {$ch eq "\""} break
3162             incr used
3163             append ret [string index $str $used]
3164             incr used
3165         }
3166     }
3167     return [list $used $ret]
3170 proc shellsplit {str} {
3171     set l {}
3172     while {1} {
3173         set str [string trimleft $str]
3174         if {$str eq {}} break
3175         set dq [shelldequote $str]
3176         set n [lindex $dq 0]
3177         set word [lindex $dq 1]
3178         set str [string range $str $n end]
3179         lappend l $word
3180     }
3181     return $l
3184 # Code to implement multiple views
3186 proc newview {ishighlight} {
3187     global nextviewnum newviewname newviewperm newishighlight
3188     global newviewargs revtreeargs viewargscmd newviewargscmd curview
3190     set newishighlight $ishighlight
3191     set top .gitkview
3192     if {[winfo exists $top]} {
3193         raise $top
3194         return
3195     }
3196     set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3197     set newviewperm($nextviewnum) 0
3198     set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3199     set newviewargscmd($nextviewnum) $viewargscmd($curview)
3200     vieweditor $top $nextviewnum [mc "Gitk view definition"]
3203 proc editview {} {
3204     global curview
3205     global viewname viewperm newviewname newviewperm
3206     global viewargs newviewargs viewargscmd newviewargscmd
3208     set top .gitkvedit-$curview
3209     if {[winfo exists $top]} {
3210         raise $top
3211         return
3212     }
3213     set newviewname($curview) $viewname($curview)
3214     set newviewperm($curview) $viewperm($curview)
3215     set newviewargs($curview) [shellarglist $viewargs($curview)]
3216     set newviewargscmd($curview) $viewargscmd($curview)
3217     vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3220 proc vieweditor {top n title} {
3221     global newviewname newviewperm viewfiles bgcolor
3223     toplevel $top
3224     wm title $top $title
3225     label $top.nl -text [mc "Name"]
3226     entry $top.name -width 20 -textvariable newviewname($n)
3227     grid $top.nl $top.name -sticky w -pady 5
3228     checkbutton $top.perm -text [mc "Remember this view"] \
3229         -variable newviewperm($n)
3230     grid $top.perm - -pady 5 -sticky w
3231     message $top.al -aspect 1000 \
3232         -text [mc "Commits to include (arguments to git log):"]
3233     grid $top.al - -sticky w -pady 5
3234     entry $top.args -width 50 -textvariable newviewargs($n) \
3235         -background $bgcolor
3236     grid $top.args - -sticky ew -padx 5
3238     message $top.ac -aspect 1000 \
3239         -text [mc "Command to generate more commits to include:"]
3240     grid $top.ac - -sticky w -pady 5
3241     entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3242         -background white
3243     grid $top.argscmd - -sticky ew -padx 5
3245     message $top.l -aspect 1000 \
3246         -text [mc "Enter files and directories to include, one per line:"]
3247     grid $top.l - -sticky w
3248     text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3249     if {[info exists viewfiles($n)]} {
3250         foreach f $viewfiles($n) {
3251             $top.t insert end $f
3252             $top.t insert end "\n"
3253         }
3254         $top.t delete {end - 1c} end
3255         $top.t mark set insert 0.0
3256     }
3257     grid $top.t - -sticky ew -padx 5
3258     frame $top.buts
3259     button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3260     button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3261     grid $top.buts.ok $top.buts.can
3262     grid columnconfigure $top.buts 0 -weight 1 -uniform a
3263     grid columnconfigure $top.buts 1 -weight 1 -uniform a
3264     grid $top.buts - -pady 10 -sticky ew
3265     focus $top.t
3268 proc doviewmenu {m first cmd op argv} {
3269     set nmenu [$m index end]
3270     for {set i $first} {$i <= $nmenu} {incr i} {
3271         if {[$m entrycget $i -command] eq $cmd} {
3272             eval $m $op $i $argv
3273             break
3274         }
3275     }
3278 proc allviewmenus {n op args} {
3279     # global viewhlmenu
3281     doviewmenu .bar.view 5 [list showview $n] $op $args
3282     # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3285 proc newviewok {top n} {
3286     global nextviewnum newviewperm newviewname newishighlight
3287     global viewname viewfiles viewperm selectedview curview
3288     global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3290     if {[catch {
3291         set newargs [shellsplit $newviewargs($n)]
3292     } err]} {
3293         error_popup "[mc "Error in commit selection arguments:"] $err"
3294         wm raise $top
3295         focus $top
3296         return
3297     }
3298     set files {}
3299     foreach f [split [$top.t get 0.0 end] "\n"] {
3300         set ft [string trim $f]
3301         if {$ft ne {}} {
3302             lappend files $ft
3303         }
3304     }
3305     if {![info exists viewfiles($n)]} {
3306         # creating a new view
3307         incr nextviewnum
3308         set viewname($n) $newviewname($n)
3309         set viewperm($n) $newviewperm($n)
3310         set viewfiles($n) $files
3311         set viewargs($n) $newargs
3312         set viewargscmd($n) $newviewargscmd($n)
3313         addviewmenu $n
3314         if {!$newishighlight} {
3315             run showview $n
3316         } else {
3317             run addvhighlight $n
3318         }
3319     } else {
3320         # editing an existing view
3321         set viewperm($n) $newviewperm($n)
3322         if {$newviewname($n) ne $viewname($n)} {
3323             set viewname($n) $newviewname($n)
3324             doviewmenu .bar.view 5 [list showview $n] \
3325                 entryconf [list -label $viewname($n)]
3326             # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3327                 # entryconf [list -label $viewname($n) -value $viewname($n)]
3328         }
3329         if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3330                 $newviewargscmd($n) ne $viewargscmd($n)} {
3331             set viewfiles($n) $files
3332             set viewargs($n) $newargs
3333             set viewargscmd($n) $newviewargscmd($n)
3334             if {$curview == $n} {
3335                 run reloadcommits
3336             }
3337         }
3338     }
3339     catch {destroy $top}
3342 proc delview {} {
3343     global curview viewperm hlview selectedhlview
3345     if {$curview == 0} return
3346     if {[info exists hlview] && $hlview == $curview} {
3347         set selectedhlview [mc "None"]
3348         unset hlview
3349     }
3350     allviewmenus $curview delete
3351     set viewperm($curview) 0
3352     showview 0
3355 proc addviewmenu {n} {
3356     global viewname viewhlmenu
3358     .bar.view add radiobutton -label $viewname($n) \
3359         -command [list showview $n] -variable selectedview -value $n
3360     #$viewhlmenu add radiobutton -label $viewname($n) \
3361     #   -command [list addvhighlight $n] -variable selectedhlview
3364 proc showview {n} {
3365     global curview cached_commitrow ordertok
3366     global displayorder parentlist rowidlist rowisopt rowfinal
3367     global colormap rowtextx nextcolor canvxmax
3368     global numcommits viewcomplete
3369     global selectedline currentid canv canvy0
3370     global treediffs
3371     global pending_select mainheadid
3372     global commitidx
3373     global selectedview
3374     global hlview selectedhlview commitinterest
3376     if {$n == $curview} return
3377     set selid {}
3378     set ymax [lindex [$canv cget -scrollregion] 3]
3379     set span [$canv yview]
3380     set ytop [expr {[lindex $span 0] * $ymax}]
3381     set ybot [expr {[lindex $span 1] * $ymax}]
3382     set yscreen [expr {($ybot - $ytop) / 2}]
3383     if {$selectedline ne {}} {
3384         set selid $currentid
3385         set y [yc $selectedline]
3386         if {$ytop < $y && $y < $ybot} {
3387             set yscreen [expr {$y - $ytop}]
3388         }
3389     } elseif {[info exists pending_select]} {
3390         set selid $pending_select
3391         unset pending_select
3392     }
3393     unselectline
3394     normalline
3395     catch {unset treediffs}
3396     clear_display
3397     if {[info exists hlview] && $hlview == $n} {
3398         unset hlview
3399         set selectedhlview [mc "None"]
3400     }
3401     catch {unset commitinterest}
3402     catch {unset cached_commitrow}
3403     catch {unset ordertok}
3405     set curview $n
3406     set selectedview $n
3407     .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3408     .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3410     run refill_reflist
3411     if {![info exists viewcomplete($n)]} {
3412         getcommits $selid
3413         return
3414     }
3416     set displayorder {}
3417     set parentlist {}
3418     set rowidlist {}
3419     set rowisopt {}
3420     set rowfinal {}
3421     set numcommits $commitidx($n)
3423     catch {unset colormap}
3424     catch {unset rowtextx}
3425     set nextcolor 0
3426     set canvxmax [$canv cget -width]
3427     set curview $n
3428     set row 0
3429     setcanvscroll
3430     set yf 0
3431     set row {}
3432     if {$selid ne {} && [commitinview $selid $n]} {
3433         set row [rowofcommit $selid]
3434         # try to get the selected row in the same position on the screen
3435         set ymax [lindex [$canv cget -scrollregion] 3]
3436         set ytop [expr {[yc $row] - $yscreen}]
3437         if {$ytop < 0} {
3438             set ytop 0
3439         }
3440         set yf [expr {$ytop * 1.0 / $ymax}]
3441     }
3442     allcanvs yview moveto $yf
3443     drawvisible
3444     if {$row ne {}} {
3445         selectline $row 0
3446     } elseif {!$viewcomplete($n)} {
3447         reset_pending_select $selid
3448     } else {
3449         reset_pending_select {}
3451         if {[commitinview $pending_select $curview]} {
3452             selectline [rowofcommit $pending_select] 1
3453         } else {
3454             set row [first_real_row]
3455             if {$row < $numcommits} {
3456                 selectline $row 0
3457             }
3458         }
3459     }
3460     if {!$viewcomplete($n)} {
3461         if {$numcommits == 0} {
3462             show_status [mc "Reading commits..."]
3463         }
3464     } elseif {$numcommits == 0} {
3465         show_status [mc "No commits selected"]
3466     }
3469 # Stuff relating to the highlighting facility
3471 proc ishighlighted {id} {
3472     global vhighlights fhighlights nhighlights rhighlights
3474     if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3475         return $nhighlights($id)
3476     }
3477     if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3478         return $vhighlights($id)
3479     }
3480     if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3481         return $fhighlights($id)
3482     }
3483     if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3484         return $rhighlights($id)
3485     }
3486     return 0
3489 proc bolden {row font} {
3490     global canv linehtag selectedline boldrows
3492     lappend boldrows $row
3493     $canv itemconf $linehtag($row) -font $font
3494     if {$row == $selectedline} {
3495         $canv delete secsel
3496         set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3497                    -outline {{}} -tags secsel \
3498                    -fill [$canv cget -selectbackground]]
3499         $canv lower $t
3500     }
3503 proc bolden_name {row font} {
3504     global canv2 linentag selectedline boldnamerows
3506     lappend boldnamerows $row
3507     $canv2 itemconf $linentag($row) -font $font
3508     if {$row == $selectedline} {
3509         $canv2 delete secsel
3510         set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3511                    -outline {{}} -tags secsel \
3512                    -fill [$canv2 cget -selectbackground]]
3513         $canv2 lower $t
3514     }
3517 proc unbolden {} {
3518     global boldrows
3520     set stillbold {}
3521     foreach row $boldrows {
3522         if {![ishighlighted [commitonrow $row]]} {
3523             bolden $row mainfont
3524         } else {
3525             lappend stillbold $row
3526         }
3527     }
3528     set boldrows $stillbold
3531 proc addvhighlight {n} {
3532     global hlview viewcomplete curview vhl_done commitidx
3534     if {[info exists hlview]} {
3535         delvhighlight
3536     }
3537     set hlview $n
3538     if {$n != $curview && ![info exists viewcomplete($n)]} {
3539         start_rev_list $n
3540     }
3541     set vhl_done $commitidx($hlview)
3542     if {$vhl_done > 0} {
3543         drawvisible
3544     }
3547 proc delvhighlight {} {
3548     global hlview vhighlights
3550     if {![info exists hlview]} return
3551     unset hlview
3552     catch {unset vhighlights}
3553     unbolden
3556 proc vhighlightmore {} {
3557     global hlview vhl_done commitidx vhighlights curview
3559     set max $commitidx($hlview)
3560     set vr [visiblerows]
3561     set r0 [lindex $vr 0]
3562     set r1 [lindex $vr 1]
3563     for {set i $vhl_done} {$i < $max} {incr i} {
3564         set id [commitonrow $i $hlview]
3565         if {[commitinview $id $curview]} {
3566             set row [rowofcommit $id]
3567             if {$r0 <= $row && $row <= $r1} {
3568                 if {![highlighted $row]} {
3569                     bolden $row mainfontbold
3570                 }
3571                 set vhighlights($id) 1
3572             }
3573         }
3574     }
3575     set vhl_done $max
3576     return 0
3579 proc askvhighlight {row id} {
3580     global hlview vhighlights iddrawn
3582     if {[commitinview $id $hlview]} {
3583         if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3584             bolden $row mainfontbold
3585         }
3586         set vhighlights($id) 1
3587     } else {
3588         set vhighlights($id) 0
3589     }
3592 proc hfiles_change {} {
3593     global highlight_files filehighlight fhighlights fh_serial
3594     global highlight_paths gdttype
3596     if {[info exists filehighlight]} {
3597         # delete previous highlights
3598         catch {close $filehighlight}
3599         unset filehighlight
3600         catch {unset fhighlights}
3601         unbolden
3602         unhighlight_filelist
3603     }
3604     set highlight_paths {}
3605     after cancel do_file_hl $fh_serial
3606     incr fh_serial
3607     if {$highlight_files ne {}} {
3608         after 300 do_file_hl $fh_serial
3609     }
3612 proc gdttype_change {name ix op} {
3613     global gdttype highlight_files findstring findpattern
3615     stopfinding
3616     if {$findstring ne {}} {
3617         if {$gdttype eq [mc "containing:"]} {
3618             if {$highlight_files ne {}} {
3619                 set highlight_files {}
3620                 hfiles_change
3621             }
3622             findcom_change
3623         } else {
3624             if {$findpattern ne {}} {
3625                 set findpattern {}
3626                 findcom_change
3627             }
3628             set highlight_files $findstring
3629             hfiles_change
3630         }
3631         drawvisible
3632     }
3633     # enable/disable findtype/findloc menus too
3636 proc find_change {name ix op} {
3637     global gdttype findstring highlight_files
3639     stopfinding
3640     if {$gdttype eq [mc "containing:"]} {
3641         findcom_change
3642     } else {
3643         if {$highlight_files ne $findstring} {
3644             set highlight_files $findstring
3645             hfiles_change
3646         }
3647     }
3648     drawvisible
3651 proc findcom_change args {
3652     global nhighlights boldnamerows
3653     global findpattern findtype findstring gdttype
3655     stopfinding
3656     # delete previous highlights, if any
3657     foreach row $boldnamerows {
3658         bolden_name $row mainfont
3659     }
3660     set boldnamerows {}
3661     catch {unset nhighlights}
3662     unbolden
3663     unmarkmatches
3664     if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3665         set findpattern {}
3666     } elseif {$findtype eq [mc "Regexp"]} {
3667         set findpattern $findstring
3668     } else {
3669         set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3670                    $findstring]
3671         set findpattern "*$e*"
3672     }
3675 proc makepatterns {l} {
3676     set ret {}
3677     foreach e $l {
3678         set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3679         if {[string index $ee end] eq "/"} {
3680             lappend ret "$ee*"
3681         } else {
3682             lappend ret $ee
3683             lappend ret "$ee/*"
3684         }
3685     }
3686     return $ret
3689 proc do_file_hl {serial} {
3690     global highlight_files filehighlight highlight_paths gdttype fhl_list
3692     if {$gdttype eq [mc "touching paths:"]} {
3693         if {[catch {set paths [shellsplit $highlight_files]}]} return
3694         set highlight_paths [makepatterns $paths]
3695         highlight_filelist
3696         set gdtargs [concat -- $paths]
3697     } elseif {$gdttype eq [mc "adding/removing string:"]} {
3698         set gdtargs [list "-S$highlight_files"]
3699     } else {
3700         # must be "containing:", i.e. we're searching commit info
3701         return
3702     }
3703     set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3704     set filehighlight [open $cmd r+]
3705     fconfigure $filehighlight -blocking 0
3706     filerun $filehighlight readfhighlight
3707     set fhl_list {}
3708     drawvisible
3709     flushhighlights
3712 proc flushhighlights {} {
3713     global filehighlight fhl_list
3715     if {[info exists filehighlight]} {
3716         lappend fhl_list {}
3717         puts $filehighlight ""
3718         flush $filehighlight
3719     }
3722 proc askfilehighlight {row id} {
3723     global filehighlight fhighlights fhl_list
3725     lappend fhl_list $id
3726     set fhighlights($id) -1
3727     puts $filehighlight $id
3730 proc readfhighlight {} {
3731     global filehighlight fhighlights curview iddrawn
3732     global fhl_list find_dirn
3734     if {![info exists filehighlight]} {
3735         return 0
3736     }
3737     set nr 0
3738     while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3739         set line [string trim $line]
3740         set i [lsearch -exact $fhl_list $line]
3741         if {$i < 0} continue
3742         for {set j 0} {$j < $i} {incr j} {
3743             set id [lindex $fhl_list $j]
3744             set fhighlights($id) 0
3745         }
3746         set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3747         if {$line eq {}} continue
3748         if {![commitinview $line $curview]} continue
3749         set row [rowofcommit $line]
3750         if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3751             bolden $row mainfontbold
3752         }
3753         set fhighlights($line) 1
3754     }
3755     if {[eof $filehighlight]} {
3756         # strange...
3757         puts "oops, git diff-tree died"
3758         catch {close $filehighlight}
3759         unset filehighlight
3760         return 0
3761     }
3762     if {[info exists find_dirn]} {
3763         run findmore
3764     }
3765     return 1
3768 proc doesmatch {f} {
3769     global findtype findpattern
3771     if {$findtype eq [mc "Regexp"]} {
3772         return [regexp $findpattern $f]
3773     } elseif {$findtype eq [mc "IgnCase"]} {
3774         return [string match -nocase $findpattern $f]
3775     } else {
3776         return [string match $findpattern $f]
3777     }
3780 proc askfindhighlight {row id} {
3781     global nhighlights commitinfo iddrawn
3782     global findloc
3783     global markingmatches
3785     if {![info exists commitinfo($id)]} {
3786         getcommit $id
3787     }
3788     set info $commitinfo($id)
3789     set isbold 0
3790     set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3791     foreach f $info ty $fldtypes {
3792         if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3793             [doesmatch $f]} {
3794             if {$ty eq [mc "Author"]} {
3795                 set isbold 2
3796                 break
3797             }
3798             set isbold 1
3799         }
3800     }
3801     if {$isbold && [info exists iddrawn($id)]} {
3802         if {![ishighlighted $id]} {
3803             bolden $row mainfontbold
3804             if {$isbold > 1} {
3805                 bolden_name $row mainfontbold
3806             }
3807         }
3808         if {$markingmatches} {
3809             markrowmatches $row $id
3810         }
3811     }
3812     set nhighlights($id) $isbold
3815 proc markrowmatches {row id} {
3816     global canv canv2 linehtag linentag commitinfo findloc
3818     set headline [lindex $commitinfo($id) 0]
3819     set author [lindex $commitinfo($id) 1]
3820     $canv delete match$row
3821     $canv2 delete match$row
3822     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3823         set m [findmatches $headline]
3824         if {$m ne {}} {
3825             markmatches $canv $row $headline $linehtag($row) $m \
3826                 [$canv itemcget $linehtag($row) -font] $row
3827         }
3828     }
3829     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3830         set m [findmatches $author]
3831         if {$m ne {}} {
3832             markmatches $canv2 $row $author $linentag($row) $m \
3833                 [$canv2 itemcget $linentag($row) -font] $row
3834         }
3835     }
3838 proc vrel_change {name ix op} {
3839     global highlight_related
3841     rhighlight_none
3842     if {$highlight_related ne [mc "None"]} {
3843         run drawvisible
3844     }
3847 # prepare for testing whether commits are descendents or ancestors of a
3848 proc rhighlight_sel {a} {
3849     global descendent desc_todo ancestor anc_todo
3850     global highlight_related
3852     catch {unset descendent}
3853     set desc_todo [list $a]
3854     catch {unset ancestor}
3855     set anc_todo [list $a]
3856     if {$highlight_related ne [mc "None"]} {
3857         rhighlight_none
3858         run drawvisible
3859     }
3862 proc rhighlight_none {} {
3863     global rhighlights
3865     catch {unset rhighlights}
3866     unbolden
3869 proc is_descendent {a} {
3870     global curview children descendent desc_todo
3872     set v $curview
3873     set la [rowofcommit $a]
3874     set todo $desc_todo
3875     set leftover {}
3876     set done 0
3877     for {set i 0} {$i < [llength $todo]} {incr i} {
3878         set do [lindex $todo $i]
3879         if {[rowofcommit $do] < $la} {
3880             lappend leftover $do
3881             continue
3882         }
3883         foreach nk $children($v,$do) {
3884             if {![info exists descendent($nk)]} {
3885                 set descendent($nk) 1
3886                 lappend todo $nk
3887                 if {$nk eq $a} {
3888                     set done 1
3889                 }
3890             }
3891         }
3892         if {$done} {
3893             set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3894             return
3895         }
3896     }
3897     set descendent($a) 0
3898     set desc_todo $leftover
3901 proc is_ancestor {a} {
3902     global curview parents ancestor anc_todo
3904     set v $curview
3905     set la [rowofcommit $a]
3906     set todo $anc_todo
3907     set leftover {}
3908     set done 0
3909     for {set i 0} {$i < [llength $todo]} {incr i} {
3910         set do [lindex $todo $i]
3911         if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3912             lappend leftover $do
3913             continue
3914         }
3915         foreach np $parents($v,$do) {
3916             if {![info exists ancestor($np)]} {
3917                 set ancestor($np) 1
3918                 lappend todo $np
3919                 if {$np eq $a} {
3920                     set done 1
3921                 }
3922             }
3923         }
3924         if {$done} {
3925             set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3926             return
3927         }
3928     }
3929     set ancestor($a) 0
3930     set anc_todo $leftover
3933 proc askrelhighlight {row id} {
3934     global descendent highlight_related iddrawn rhighlights
3935     global selectedline ancestor
3937     if {$selectedline eq {}} return
3938     set isbold 0
3939     if {$highlight_related eq [mc "Descendant"] ||
3940         $highlight_related eq [mc "Not descendant"]} {
3941         if {![info exists descendent($id)]} {
3942             is_descendent $id
3943         }
3944         if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3945             set isbold 1
3946         }
3947     } elseif {$highlight_related eq [mc "Ancestor"] ||
3948               $highlight_related eq [mc "Not ancestor"]} {
3949         if {![info exists ancestor($id)]} {
3950             is_ancestor $id
3951         }
3952         if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3953             set isbold 1
3954         }
3955     }
3956     if {[info exists iddrawn($id)]} {
3957         if {$isbold && ![ishighlighted $id]} {
3958             bolden $row mainfontbold
3959         }
3960     }
3961     set rhighlights($id) $isbold
3964 # Graph layout functions
3966 proc shortids {ids} {
3967     set res {}
3968     foreach id $ids {
3969         if {[llength $id] > 1} {
3970             lappend res [shortids $id]
3971         } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3972             lappend res [string range $id 0 7]
3973         } else {
3974             lappend res $id
3975         }
3976     }
3977     return $res
3980 proc ntimes {n o} {
3981     set ret {}
3982     set o [list $o]
3983     for {set mask 1} {$mask <= $n} {incr mask $mask} {
3984         if {($n & $mask) != 0} {
3985             set ret [concat $ret $o]
3986         }
3987         set o [concat $o $o]
3988     }
3989     return $ret
3992 proc ordertoken {id} {
3993     global ordertok curview varcid varcstart varctok curview parents children
3994     global nullid nullid2
3996     if {[info exists ordertok($id)]} {
3997         return $ordertok($id)
3998     }
3999     set origid $id
4000     set todo {}
4001     while {1} {
4002         if {[info exists varcid($curview,$id)]} {
4003             set a $varcid($curview,$id)
4004             set p [lindex $varcstart($curview) $a]
4005         } else {
4006             set p [lindex $children($curview,$id) 0]
4007         }
4008         if {[info exists ordertok($p)]} {
4009             set tok $ordertok($p)
4010             break
4011         }
4012         set id [first_real_child $curview,$p]
4013         if {$id eq {}} {
4014             # it's a root
4015             set tok [lindex $varctok($curview) $varcid($curview,$p)]
4016             break
4017         }
4018         if {[llength $parents($curview,$id)] == 1} {
4019             lappend todo [list $p {}]
4020         } else {
4021             set j [lsearch -exact $parents($curview,$id) $p]
4022             if {$j < 0} {
4023                 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4024             }
4025             lappend todo [list $p [strrep $j]]
4026         }
4027     }
4028     for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4029         set p [lindex $todo $i 0]
4030         append tok [lindex $todo $i 1]
4031         set ordertok($p) $tok
4032     }
4033     set ordertok($origid) $tok
4034     return $tok
4037 # Work out where id should go in idlist so that order-token
4038 # values increase from left to right
4039 proc idcol {idlist id {i 0}} {
4040     set t [ordertoken $id]
4041     if {$i < 0} {
4042         set i 0
4043     }
4044     if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4045         if {$i > [llength $idlist]} {
4046             set i [llength $idlist]
4047         }
4048         while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4049         incr i
4050     } else {
4051         if {$t > [ordertoken [lindex $idlist $i]]} {
4052             while {[incr i] < [llength $idlist] &&
4053                    $t >= [ordertoken [lindex $idlist $i]]} {}
4054         }
4055     }
4056     return $i
4059 proc initlayout {} {
4060     global rowidlist rowisopt rowfinal displayorder parentlist
4061     global numcommits canvxmax canv
4062     global nextcolor
4063     global colormap rowtextx
4065     set numcommits 0
4066     set displayorder {}
4067     set parentlist {}
4068     set nextcolor 0
4069     set rowidlist {}
4070     set rowisopt {}
4071     set rowfinal {}
4072     set canvxmax [$canv cget -width]
4073     catch {unset colormap}
4074     catch {unset rowtextx}
4075     setcanvscroll
4078 proc setcanvscroll {} {
4079     global canv canv2 canv3 numcommits linespc canvxmax canvy0
4080     global lastscrollset lastscrollrows
4082     set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4083     $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4084     $canv2 conf -scrollregion [list 0 0 0 $ymax]
4085     $canv3 conf -scrollregion [list 0 0 0 $ymax]
4086     set lastscrollset [clock clicks -milliseconds]
4087     set lastscrollrows $numcommits
4090 proc visiblerows {} {
4091     global canv numcommits linespc
4093     set ymax [lindex [$canv cget -scrollregion] 3]
4094     if {$ymax eq {} || $ymax == 0} return
4095     set f [$canv yview]
4096     set y0 [expr {int([lindex $f 0] * $ymax)}]
4097     set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4098     if {$r0 < 0} {
4099         set r0 0
4100     }
4101     set y1 [expr {int([lindex $f 1] * $ymax)}]
4102     set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4103     if {$r1 >= $numcommits} {
4104         set r1 [expr {$numcommits - 1}]
4105     }
4106     return [list $r0 $r1]
4109 proc layoutmore {} {
4110     global commitidx viewcomplete curview
4111     global numcommits pending_select curview
4112     global lastscrollset lastscrollrows commitinterest
4114     if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4115         [clock clicks -milliseconds] - $lastscrollset > 500} {
4116         setcanvscroll
4117     }
4118     if {[info exists pending_select] &&
4119         [commitinview $pending_select $curview]} {
4120         update
4121         selectline [rowofcommit $pending_select] 1
4122     }
4123     drawvisible
4126 proc doshowlocalchanges {} {
4127     global curview mainheadid
4129     if {$mainheadid eq {}} return
4130     if {[commitinview $mainheadid $curview]} {
4131         dodiffindex
4132     } else {
4133         lappend commitinterest($mainheadid) {dodiffindex}
4134     }
4137 proc dohidelocalchanges {} {
4138     global nullid nullid2 lserial curview
4140     if {[commitinview $nullid $curview]} {
4141         removefakerow $nullid
4142     }
4143     if {[commitinview $nullid2 $curview]} {
4144         removefakerow $nullid2
4145     }
4146     incr lserial
4149 # spawn off a process to do git diff-index --cached HEAD
4150 proc dodiffindex {} {
4151     global lserial showlocalchanges
4152     global isworktree
4154     if {!$showlocalchanges || !$isworktree} return
4155     incr lserial
4156     set fd [open "|git diff-index --cached HEAD" r]
4157     fconfigure $fd -blocking 0
4158     set i [reg_instance $fd]
4159     filerun $fd [list readdiffindex $fd $lserial $i]
4162 proc readdiffindex {fd serial inst} {
4163     global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4165     set isdiff 1
4166     if {[gets $fd line] < 0} {
4167         if {![eof $fd]} {
4168             return 1
4169         }
4170         set isdiff 0
4171     }
4172     # we only need to see one line and we don't really care what it says...
4173     stop_instance $inst
4175     if {$serial != $lserial} {
4176         return 0
4177     }
4179     # now see if there are any local changes not checked in to the index
4180     set fd [open "|git diff-files" r]
4181     fconfigure $fd -blocking 0
4182     set i [reg_instance $fd]
4183     filerun $fd [list readdifffiles $fd $serial $i]
4185     if {$isdiff && ![commitinview $nullid2 $curview]} {
4186         # add the line for the changes in the index to the graph
4187         set hl [mc "Local changes checked in to index but not committed"]
4188         set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
4189         set commitdata($nullid2) "\n    $hl\n"
4190         if {[commitinview $nullid $curview]} {
4191             removefakerow $nullid
4192         }
4193         insertfakerow $nullid2 $mainheadid
4194     } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4195         removefakerow $nullid2
4196     }
4197     return 0
4200 proc readdifffiles {fd serial inst} {
4201     global mainheadid nullid nullid2 curview
4202     global commitinfo commitdata lserial
4204     set isdiff 1
4205     if {[gets $fd line] < 0} {
4206         if {![eof $fd]} {
4207             return 1
4208         }
4209         set isdiff 0
4210     }
4211     # we only need to see one line and we don't really care what it says...
4212     stop_instance $inst
4214     if {$serial != $lserial} {
4215         return 0
4216     }
4218     if {$isdiff && ![commitinview $nullid $curview]} {
4219         # add the line for the local diff to the graph
4220         set hl [mc "Local uncommitted changes, not checked in to index"]
4221         set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
4222         set commitdata($nullid) "\n    $hl\n"
4223         if {[commitinview $nullid2 $curview]} {
4224             set p $nullid2
4225         } else {
4226             set p $mainheadid
4227         }
4228         insertfakerow $nullid $p
4229     } elseif {!$isdiff && [commitinview $nullid $curview]} {
4230         removefakerow $nullid
4231     }
4232     return 0
4235 proc nextuse {id row} {
4236     global curview children
4238     if {[info exists children($curview,$id)]} {
4239         foreach kid $children($curview,$id) {
4240             if {![commitinview $kid $curview]} {
4241                 return -1
4242             }
4243             if {[rowofcommit $kid] > $row} {
4244                 return [rowofcommit $kid]
4245             }
4246         }
4247     }
4248     if {[commitinview $id $curview]} {
4249         return [rowofcommit $id]
4250     }
4251     return -1
4254 proc prevuse {id row} {
4255     global curview children
4257     set ret -1
4258     if {[info exists children($curview,$id)]} {
4259         foreach kid $children($curview,$id) {
4260             if {![commitinview $kid $curview]} break
4261             if {[rowofcommit $kid] < $row} {
4262                 set ret [rowofcommit $kid]
4263             }
4264         }
4265     }
4266     return $ret
4269 proc make_idlist {row} {
4270     global displayorder parentlist uparrowlen downarrowlen mingaplen
4271     global commitidx curview children
4273     set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4274     if {$r < 0} {
4275         set r 0
4276     }
4277     set ra [expr {$row - $downarrowlen}]
4278     if {$ra < 0} {
4279         set ra 0
4280     }
4281     set rb [expr {$row + $uparrowlen}]
4282     if {$rb > $commitidx($curview)} {
4283         set rb $commitidx($curview)
4284     }
4285     make_disporder $r [expr {$rb + 1}]
4286     set ids {}
4287     for {} {$r < $ra} {incr r} {
4288         set nextid [lindex $displayorder [expr {$r + 1}]]
4289         foreach p [lindex $parentlist $r] {
4290             if {$p eq $nextid} continue
4291             set rn [nextuse $p $r]
4292             if {$rn >= $row &&
4293                 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4294                 lappend ids [list [ordertoken $p] $p]
4295             }
4296         }
4297     }
4298     for {} {$r < $row} {incr r} {
4299         set nextid [lindex $displayorder [expr {$r + 1}]]
4300         foreach p [lindex $parentlist $r] {
4301             if {$p eq $nextid} continue
4302             set rn [nextuse $p $r]
4303             if {$rn < 0 || $rn >= $row} {
4304                 lappend ids [list [ordertoken $p] $p]
4305             }
4306         }
4307     }
4308     set id [lindex $displayorder $row]
4309     lappend ids [list [ordertoken $id] $id]
4310     while {$r < $rb} {
4311         foreach p [lindex $parentlist $r] {
4312             set firstkid [lindex $children($curview,$p) 0]
4313             if {[rowofcommit $firstkid] < $row} {
4314                 lappend ids [list [ordertoken $p] $p]
4315             }
4316         }
4317         incr r
4318         set id [lindex $displayorder $r]
4319         if {$id ne {}} {
4320             set firstkid [lindex $children($curview,$id) 0]
4321             if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4322                 lappend ids [list [ordertoken $id] $id]
4323             }
4324         }
4325     }
4326     set idlist {}
4327     foreach idx [lsort -unique $ids] {
4328         lappend idlist [lindex $idx 1]
4329     }
4330     return $idlist
4333 proc rowsequal {a b} {
4334     while {[set i [lsearch -exact $a {}]] >= 0} {
4335         set a [lreplace $a $i $i]
4336     }
4337     while {[set i [lsearch -exact $b {}]] >= 0} {
4338         set b [lreplace $b $i $i]
4339     }
4340     return [expr {$a eq $b}]
4343 proc makeupline {id row rend col} {
4344     global rowidlist uparrowlen downarrowlen mingaplen
4346     for {set r $rend} {1} {set r $rstart} {
4347         set rstart [prevuse $id $r]
4348         if {$rstart < 0} return
4349         if {$rstart < $row} break
4350     }
4351     if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4352         set rstart [expr {$rend - $uparrowlen - 1}]
4353     }
4354     for {set r $rstart} {[incr r] <= $row} {} {
4355         set idlist [lindex $rowidlist $r]
4356         if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4357             set col [idcol $idlist $id $col]
4358             lset rowidlist $r [linsert $idlist $col $id]
4359             changedrow $r
4360         }
4361     }
4364 proc layoutrows {row endrow} {
4365     global rowidlist rowisopt rowfinal displayorder
4366     global uparrowlen downarrowlen maxwidth mingaplen
4367     global children parentlist
4368     global commitidx viewcomplete curview
4370     make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4371     set idlist {}
4372     if {$row > 0} {
4373         set rm1 [expr {$row - 1}]
4374         foreach id [lindex $rowidlist $rm1] {
4375             if {$id ne {}} {
4376                 lappend idlist $id
4377             }
4378         }
4379         set final [lindex $rowfinal $rm1]
4380     }
4381     for {} {$row < $endrow} {incr row} {
4382         set rm1 [expr {$row - 1}]
4383         if {$rm1 < 0 || $idlist eq {}} {
4384             set idlist [make_idlist $row]
4385             set final 1
4386         } else {
4387             set id [lindex $displayorder $rm1]
4388             set col [lsearch -exact $idlist $id]
4389             set idlist [lreplace $idlist $col $col]
4390             foreach p [lindex $parentlist $rm1] {
4391                 if {[lsearch -exact $idlist $p] < 0} {
4392                     set col [idcol $idlist $p $col]
4393                     set idlist [linsert $idlist $col $p]
4394                     # if not the first child, we have to insert a line going up
4395                     if {$id ne [lindex $children($curview,$p) 0]} {
4396                         makeupline $p $rm1 $row $col
4397                     }
4398                 }
4399             }
4400             set id [lindex $displayorder $row]
4401             if {$row > $downarrowlen} {
4402                 set termrow [expr {$row - $downarrowlen - 1}]
4403                 foreach p [lindex $parentlist $termrow] {
4404                     set i [lsearch -exact $idlist $p]
4405                     if {$i < 0} continue
4406                     set nr [nextuse $p $termrow]
4407                     if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4408                         set idlist [lreplace $idlist $i $i]
4409                     }
4410                 }
4411             }
4412             set col [lsearch -exact $idlist $id]
4413             if {$col < 0} {
4414                 set col [idcol $idlist $id]
4415                 set idlist [linsert $idlist $col $id]
4416                 if {$children($curview,$id) ne {}} {
4417                     makeupline $id $rm1 $row $col
4418                 }
4419             }
4420             set r [expr {$row + $uparrowlen - 1}]
4421             if {$r < $commitidx($curview)} {
4422                 set x $col
4423                 foreach p [lindex $parentlist $r] {
4424                     if {[lsearch -exact $idlist $p] >= 0} continue
4425                     set fk [lindex $children($curview,$p) 0]
4426                     if {[rowofcommit $fk] < $row} {
4427                         set x [idcol $idlist $p $x]
4428                         set idlist [linsert $idlist $x $p]
4429                     }
4430                 }
4431                 if {[incr r] < $commitidx($curview)} {
4432                     set p [lindex $displayorder $r]
4433                     if {[lsearch -exact $idlist $p] < 0} {
4434                         set fk [lindex $children($curview,$p) 0]
4435                         if {$fk ne {} && [rowofcommit $fk] < $row} {
4436                             set x [idcol $idlist $p $x]
4437                             set idlist [linsert $idlist $x $p]
4438                         }
4439                     }
4440                 }
4441             }
4442         }
4443         if {$final && !$viewcomplete($curview) &&
4444             $row + $uparrowlen + $mingaplen + $downarrowlen
4445                 >= $commitidx($curview)} {
4446             set final 0
4447         }
4448         set l [llength $rowidlist]
4449         if {$row == $l} {
4450             lappend rowidlist $idlist
4451             lappend rowisopt 0
4452             lappend rowfinal $final
4453         } elseif {$row < $l} {
4454             if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4455                 lset rowidlist $row $idlist
4456                 changedrow $row
4457             }
4458             lset rowfinal $row $final
4459         } else {
4460             set pad [ntimes [expr {$row - $l}] {}]
4461             set rowidlist [concat $rowidlist $pad]
4462             lappend rowidlist $idlist
4463             set rowfinal [concat $rowfinal $pad]
4464             lappend rowfinal $final
4465             set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4466         }
4467     }
4468     return $row
4471 proc changedrow {row} {
4472     global displayorder iddrawn rowisopt need_redisplay
4474     set l [llength $rowisopt]
4475     if {$row < $l} {
4476         lset rowisopt $row 0
4477         if {$row + 1 < $l} {
4478             lset rowisopt [expr {$row + 1}] 0
4479             if {$row + 2 < $l} {
4480                 lset rowisopt [expr {$row + 2}] 0
4481             }
4482         }
4483     }
4484     set id [lindex $displayorder $row]
4485     if {[info exists iddrawn($id)]} {
4486         set need_redisplay 1
4487     }
4490 proc insert_pad {row col npad} {
4491     global rowidlist
4493     set pad [ntimes $npad {}]
4494     set idlist [lindex $rowidlist $row]
4495     set bef [lrange $idlist 0 [expr {$col - 1}]]
4496     set aft [lrange $idlist $col end]
4497     set i [lsearch -exact $aft {}]
4498     if {$i > 0} {
4499         set aft [lreplace $aft $i $i]
4500     }
4501     lset rowidlist $row [concat $bef $pad $aft]
4502     changedrow $row
4505 proc optimize_rows {row col endrow} {
4506     global rowidlist rowisopt displayorder curview children
4508     if {$row < 1} {
4509         set row 1
4510     }
4511     for {} {$row < $endrow} {incr row; set col 0} {
4512         if {[lindex $rowisopt $row]} continue
4513         set haspad 0
4514         set y0 [expr {$row - 1}]
4515         set ym [expr {$row - 2}]
4516         set idlist [lindex $rowidlist $row]
4517         set previdlist [lindex $rowidlist $y0]
4518         if {$idlist eq {} || $previdlist eq {}} continue
4519         if {$ym >= 0} {
4520             set pprevidlist [lindex $rowidlist $ym]
4521             if {$pprevidlist eq {}} continue
4522         } else {
4523             set pprevidlist {}
4524         }
4525         set x0 -1
4526         set xm -1
4527         for {} {$col < [llength $idlist]} {incr col} {
4528             set id [lindex $idlist $col]
4529             if {[lindex $previdlist $col] eq $id} continue
4530             if {$id eq {}} {
4531                 set haspad 1
4532                 continue
4533             }
4534             set x0 [lsearch -exact $previdlist $id]
4535             if {$x0 < 0} continue
4536             set z [expr {$x0 - $col}]
4537             set isarrow 0
4538             set z0 {}
4539             if {$ym >= 0} {
4540                 set xm [lsearch -exact $pprevidlist $id]
4541                 if {$xm >= 0} {
4542                     set z0 [expr {$xm - $x0}]
4543                 }
4544             }
4545             if {$z0 eq {}} {
4546                 # if row y0 is the first child of $id then it's not an arrow
4547                 if {[lindex $children($curview,$id) 0] ne
4548                     [lindex $displayorder $y0]} {
4549                     set isarrow 1
4550                 }
4551             }
4552             if {!$isarrow && $id ne [lindex $displayorder $row] &&
4553                 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4554                 set isarrow 1
4555             }
4556             # Looking at lines from this row to the previous row,
4557             # make them go straight up if they end in an arrow on
4558             # the previous row; otherwise make them go straight up
4559             # or at 45 degrees.
4560             if {$z < -1 || ($z < 0 && $isarrow)} {
4561                 # Line currently goes left too much;
4562                 # insert pads in the previous row, then optimize it
4563                 set npad [expr {-1 - $z + $isarrow}]
4564                 insert_pad $y0 $x0 $npad
4565                 if {$y0 > 0} {
4566                     optimize_rows $y0 $x0 $row
4567                 }
4568                 set previdlist [lindex $rowidlist $y0]
4569                 set x0 [lsearch -exact $previdlist $id]
4570                 set z [expr {$x0 - $col}]
4571                 if {$z0 ne {}} {
4572                     set pprevidlist [lindex $rowidlist $ym]
4573                     set xm [lsearch -exact $pprevidlist $id]
4574                     set z0 [expr {$xm - $x0}]
4575                 }
4576             } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4577                 # Line currently goes right too much;
4578                 # insert pads in this line
4579                 set npad [expr {$z - 1 + $isarrow}]
4580                 insert_pad $row $col $npad
4581                 set idlist [lindex $rowidlist $row]
4582                 incr col $npad
4583                 set z [expr {$x0 - $col}]
4584                 set haspad 1
4585             }
4586             if {$z0 eq {} && !$isarrow && $ym >= 0} {
4587                 # this line links to its first child on row $row-2
4588                 set id [lindex $displayorder $ym]
4589                 set xc [lsearch -exact $pprevidlist $id]
4590                 if {$xc >= 0} {
4591                     set z0 [expr {$xc - $x0}]
4592                 }
4593             }
4594             # avoid lines jigging left then immediately right
4595             if {$z0 ne {} && $z < 0 && $z0 > 0} {
4596                 insert_pad $y0 $x0 1
4597                 incr x0
4598                 optimize_rows $y0 $x0 $row
4599                 set previdlist [lindex $rowidlist $y0]
4600             }
4601         }
4602         if {!$haspad} {
4603             # Find the first column that doesn't have a line going right
4604             for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4605                 set id [lindex $idlist $col]
4606                 if {$id eq {}} break
4607                 set x0 [lsearch -exact $previdlist $id]
4608                 if {$x0 < 0} {
4609                     # check if this is the link to the first child
4610                     set kid [lindex $displayorder $y0]
4611                     if {[lindex $children($curview,$id) 0] eq $kid} {
4612                         # it is, work out offset to child
4613                         set x0 [lsearch -exact $previdlist $kid]
4614                     }
4615                 }
4616                 if {$x0 <= $col} break
4617             }
4618             # Insert a pad at that column as long as it has a line and
4619             # isn't the last column
4620             if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4621                 set idlist [linsert $idlist $col {}]
4622                 lset rowidlist $row $idlist
4623                 changedrow $row
4624             }
4625         }
4626     }
4629 proc xc {row col} {
4630     global canvx0 linespc
4631     return [expr {$canvx0 + $col * $linespc}]
4634 proc yc {row} {
4635     global canvy0 linespc
4636     return [expr {$canvy0 + $row * $linespc}]
4639 proc linewidth {id} {
4640     global thickerline lthickness
4642     set wid $lthickness
4643     if {[info exists thickerline] && $id eq $thickerline} {
4644         set wid [expr {2 * $lthickness}]
4645     }
4646     return $wid
4649 proc rowranges {id} {
4650     global curview children uparrowlen downarrowlen
4651     global rowidlist
4653     set kids $children($curview,$id)
4654     if {$kids eq {}} {
4655         return {}
4656     }
4657     set ret {}
4658     lappend kids $id
4659     foreach child $kids {
4660         if {![commitinview $child $curview]} break
4661         set row [rowofcommit $child]
4662         if {![info exists prev]} {
4663             lappend ret [expr {$row + 1}]
4664         } else {
4665             if {$row <= $prevrow} {
4666                 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4667             }
4668             # see if the line extends the whole way from prevrow to row
4669             if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4670                 [lsearch -exact [lindex $rowidlist \
4671                             [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4672                 # it doesn't, see where it ends
4673                 set r [expr {$prevrow + $downarrowlen}]
4674                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4675                     while {[incr r -1] > $prevrow &&
4676                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4677                 } else {
4678                     while {[incr r] <= $row &&
4679                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4680                     incr r -1
4681                 }
4682                 lappend ret $r
4683                 # see where it starts up again
4684                 set r [expr {$row - $uparrowlen}]
4685                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4686                     while {[incr r] < $row &&
4687                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4688                 } else {
4689                     while {[incr r -1] >= $prevrow &&
4690                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4691                     incr r
4692                 }
4693                 lappend ret $r
4694             }
4695         }
4696         if {$child eq $id} {
4697             lappend ret $row
4698         }
4699         set prev $child
4700         set prevrow $row
4701     }
4702     return $ret
4705 proc drawlineseg {id row endrow arrowlow} {
4706     global rowidlist displayorder iddrawn linesegs
4707     global canv colormap linespc curview maxlinelen parentlist
4709     set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4710     set le [expr {$row + 1}]
4711     set arrowhigh 1
4712     while {1} {
4713         set c [lsearch -exact [lindex $rowidlist $le] $id]
4714         if {$c < 0} {
4715             incr le -1
4716             break
4717         }
4718         lappend cols $c
4719         set x [lindex $displayorder $le]
4720         if {$x eq $id} {
4721             set arrowhigh 0
4722             break
4723         }
4724         if {[info exists iddrawn($x)] || $le == $endrow} {
4725             set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4726             if {$c >= 0} {
4727                 lappend cols $c
4728                 set arrowhigh 0
4729             }
4730             break
4731         }
4732         incr le
4733     }
4734     if {$le <= $row} {
4735         return $row
4736     }
4738     set lines {}
4739     set i 0
4740     set joinhigh 0
4741     if {[info exists linesegs($id)]} {
4742         set lines $linesegs($id)
4743         foreach li $lines {
4744             set r0 [lindex $li 0]
4745             if {$r0 > $row} {
4746                 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4747                     set joinhigh 1
4748                 }
4749                 break
4750             }
4751             incr i
4752         }
4753     }
4754     set joinlow 0
4755     if {$i > 0} {
4756         set li [lindex $lines [expr {$i-1}]]
4757         set r1 [lindex $li 1]
4758         if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4759             set joinlow 1
4760         }
4761     }
4763     set x [lindex $cols [expr {$le - $row}]]
4764     set xp [lindex $cols [expr {$le - 1 - $row}]]
4765     set dir [expr {$xp - $x}]
4766     if {$joinhigh} {
4767         set ith [lindex $lines $i 2]
4768         set coords [$canv coords $ith]
4769         set ah [$canv itemcget $ith -arrow]
4770         set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4771         set x2 [lindex $cols [expr {$le + 1 - $row}]]
4772         if {$x2 ne {} && $x - $x2 == $dir} {
4773             set coords [lrange $coords 0 end-2]
4774         }
4775     } else {
4776         set coords [list [xc $le $x] [yc $le]]
4777     }
4778     if {$joinlow} {
4779         set itl [lindex $lines [expr {$i-1}] 2]
4780         set al [$canv itemcget $itl -arrow]
4781         set arrowlow [expr {$al eq "last" || $al eq "both"}]
4782     } elseif {$arrowlow} {
4783         if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4784             [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4785             set arrowlow 0
4786         }
4787     }
4788     set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4789     for {set y $le} {[incr y -1] > $row} {} {
4790         set x $xp
4791         set xp [lindex $cols [expr {$y - 1 - $row}]]
4792         set ndir [expr {$xp - $x}]
4793         if {$dir != $ndir || $xp < 0} {
4794             lappend coords [xc $y $x] [yc $y]
4795         }
4796         set dir $ndir
4797     }
4798     if {!$joinlow} {
4799         if {$xp < 0} {
4800             # join parent line to first child
4801             set ch [lindex $displayorder $row]
4802             set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4803             if {$xc < 0} {
4804                 puts "oops: drawlineseg: child $ch not on row $row"
4805             } elseif {$xc != $x} {
4806                 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4807                     set d [expr {int(0.5 * $linespc)}]
4808                     set x1 [xc $row $x]
4809                     if {$xc < $x} {
4810                         set x2 [expr {$x1 - $d}]
4811                     } else {
4812                         set x2 [expr {$x1 + $d}]
4813                     }
4814                     set y2 [yc $row]
4815                     set y1 [expr {$y2 + $d}]
4816                     lappend coords $x1 $y1 $x2 $y2
4817                 } elseif {$xc < $x - 1} {
4818                     lappend coords [xc $row [expr {$x-1}]] [yc $row]
4819                 } elseif {$xc > $x + 1} {
4820                     lappend coords [xc $row [expr {$x+1}]] [yc $row]
4821                 }
4822                 set x $xc
4823             }
4824             lappend coords [xc $row $x] [yc $row]
4825         } else {
4826             set xn [xc $row $xp]
4827             set yn [yc $row]
4828             lappend coords $xn $yn
4829         }
4830         if {!$joinhigh} {
4831             assigncolor $id
4832             set t [$canv create line $coords -width [linewidth $id] \
4833                        -fill $colormap($id) -tags lines.$id -arrow $arrow]
4834             $canv lower $t
4835             bindline $t $id
4836             set lines [linsert $lines $i [list $row $le $t]]
4837         } else {
4838             $canv coords $ith $coords
4839             if {$arrow ne $ah} {
4840                 $canv itemconf $ith -arrow $arrow
4841             }
4842             lset lines $i 0 $row
4843         }
4844     } else {
4845         set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4846         set ndir [expr {$xo - $xp}]
4847         set clow [$canv coords $itl]
4848         if {$dir == $ndir} {
4849             set clow [lrange $clow 2 end]
4850         }
4851         set coords [concat $coords $clow]
4852         if {!$joinhigh} {
4853             lset lines [expr {$i-1}] 1 $le
4854         } else {
4855             # coalesce two pieces
4856             $canv delete $ith
4857             set b [lindex $lines [expr {$i-1}] 0]
4858             set e [lindex $lines $i 1]
4859             set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4860         }
4861         $canv coords $itl $coords
4862         if {$arrow ne $al} {
4863             $canv itemconf $itl -arrow $arrow
4864         }
4865     }
4867     set linesegs($id) $lines
4868     return $le
4871 proc drawparentlinks {id row} {
4872     global rowidlist canv colormap curview parentlist
4873     global idpos linespc
4875     set rowids [lindex $rowidlist $row]
4876     set col [lsearch -exact $rowids $id]
4877     if {$col < 0} return
4878     set olds [lindex $parentlist $row]
4879     set row2 [expr {$row + 1}]
4880     set x [xc $row $col]
4881     set y [yc $row]
4882     set y2 [yc $row2]
4883     set d [expr {int(0.5 * $linespc)}]
4884     set ymid [expr {$y + $d}]
4885     set ids [lindex $rowidlist $row2]
4886     # rmx = right-most X coord used
4887     set rmx 0
4888     foreach p $olds {
4889         set i [lsearch -exact $ids $p]
4890         if {$i < 0} {
4891             puts "oops, parent $p of $id not in list"
4892             continue
4893         }
4894         set x2 [xc $row2 $i]
4895         if {$x2 > $rmx} {
4896             set rmx $x2
4897         }
4898         set j [lsearch -exact $rowids $p]
4899         if {$j < 0} {
4900             # drawlineseg will do this one for us
4901             continue
4902         }
4903         assigncolor $p
4904         # should handle duplicated parents here...
4905         set coords [list $x $y]
4906         if {$i != $col} {
4907             # if attaching to a vertical segment, draw a smaller
4908             # slant for visual distinctness
4909             if {$i == $j} {
4910                 if {$i < $col} {
4911                     lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4912                 } else {
4913                     lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4914                 }
4915             } elseif {$i < $col && $i < $j} {
4916                 # segment slants towards us already
4917                 lappend coords [xc $row $j] $y
4918             } else {
4919                 if {$i < $col - 1} {
4920                     lappend coords [expr {$x2 + $linespc}] $y
4921                 } elseif {$i > $col + 1} {
4922                     lappend coords [expr {$x2 - $linespc}] $y
4923                 }
4924                 lappend coords $x2 $y2
4925             }
4926         } else {
4927             lappend coords $x2 $y2
4928         }
4929         set t [$canv create line $coords -width [linewidth $p] \
4930                    -fill $colormap($p) -tags lines.$p]
4931         $canv lower $t
4932         bindline $t $p
4933     }
4934     if {$rmx > [lindex $idpos($id) 1]} {
4935         lset idpos($id) 1 $rmx
4936         redrawtags $id
4937     }
4940 proc drawlines {id} {
4941     global canv
4943     $canv itemconf lines.$id -width [linewidth $id]
4946 proc drawcmittext {id row col} {
4947     global linespc canv canv2 canv3 fgcolor curview
4948     global cmitlisted commitinfo rowidlist parentlist
4949     global rowtextx idpos idtags idheads idotherrefs
4950     global linehtag linentag linedtag selectedline
4951     global canvxmax boldrows boldnamerows fgcolor
4952     global mainheadid nullid nullid2 circleitem circlecolors ctxbut
4954     # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4955     set listed $cmitlisted($curview,$id)
4956     if {$id eq $nullid} {
4957         set ofill red
4958     } elseif {$id eq $nullid2} {
4959         set ofill green
4960     } elseif {$id eq $mainheadid} {
4961         set ofill yellow
4962     } else {
4963         set ofill [lindex $circlecolors $listed]
4964     }
4965     set x [xc $row $col]
4966     set y [yc $row]
4967     set orad [expr {$linespc / 3}]
4968     if {$listed <= 2} {
4969         set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4970                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4971                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
4972     } elseif {$listed == 3} {
4973         # triangle pointing left for left-side commits
4974         set t [$canv create polygon \
4975                    [expr {$x - $orad}] $y \
4976                    [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4977                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4978                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
4979     } else {
4980         # triangle pointing right for right-side commits
4981         set t [$canv create polygon \
4982                    [expr {$x + $orad - 1}] $y \
4983                    [expr {$x - $orad}] [expr {$y - $orad}] \
4984                    [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4985                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
4986     }
4987     set circleitem($row) $t
4988     $canv raise $t
4989     $canv bind $t <1> {selcanvline {} %x %y}
4990     set rmx [llength [lindex $rowidlist $row]]
4991     set olds [lindex $parentlist $row]
4992     if {$olds ne {}} {
4993         set nextids [lindex $rowidlist [expr {$row + 1}]]
4994         foreach p $olds {
4995             set i [lsearch -exact $nextids $p]
4996             if {$i > $rmx} {
4997                 set rmx $i
4998             }
4999         }
5000     }
5001     set xt [xc $row $rmx]
5002     set rowtextx($row) $xt
5003     set idpos($id) [list $x $xt $y]
5004     if {[info exists idtags($id)] || [info exists idheads($id)]
5005         || [info exists idotherrefs($id)]} {
5006         set xt [drawtags $id $x $xt $y]
5007     }
5008     set headline [lindex $commitinfo($id) 0]
5009     set name [lindex $commitinfo($id) 1]
5010     set date [lindex $commitinfo($id) 2]
5011     set date [formatdate $date]
5012     set font mainfont
5013     set nfont mainfont
5014     set isbold [ishighlighted $id]
5015     if {$isbold > 0} {
5016         lappend boldrows $row
5017         set font mainfontbold
5018         if {$isbold > 1} {
5019             lappend boldnamerows $row
5020             set nfont mainfontbold
5021         }
5022     }
5023     set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
5024                             -text $headline -font $font -tags text]
5025     $canv bind $linehtag($row) $ctxbut "rowmenu %X %Y $id"
5026     set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5027                             -text $name -font $nfont -tags text]
5028     set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5029                             -text $date -font mainfont -tags text]
5030     if {$selectedline == $row} {
5031         make_secsel $row
5032     }
5033     set xr [expr {$xt + [font measure $font $headline]}]
5034     if {$xr > $canvxmax} {
5035         set canvxmax $xr
5036         setcanvscroll
5037     }
5040 proc drawcmitrow {row} {
5041     global displayorder rowidlist nrows_drawn
5042     global iddrawn markingmatches
5043     global commitinfo numcommits
5044     global filehighlight fhighlights findpattern nhighlights
5045     global hlview vhighlights
5046     global highlight_related rhighlights
5048     if {$row >= $numcommits} return
5050     set id [lindex $displayorder $row]
5051     if {[info exists hlview] && ![info exists vhighlights($id)]} {
5052         askvhighlight $row $id
5053     }
5054     if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5055         askfilehighlight $row $id
5056     }
5057     if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5058         askfindhighlight $row $id
5059     }
5060     if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5061         askrelhighlight $row $id
5062     }
5063     if {![info exists iddrawn($id)]} {
5064         set col [lsearch -exact [lindex $rowidlist $row] $id]
5065         if {$col < 0} {
5066             puts "oops, row $row id $id not in list"
5067             return
5068         }
5069         if {![info exists commitinfo($id)]} {
5070             getcommit $id
5071         }
5072         assigncolor $id
5073         drawcmittext $id $row $col
5074         set iddrawn($id) 1
5075         incr nrows_drawn
5076     }
5077     if {$markingmatches} {
5078         markrowmatches $row $id
5079     }
5082 proc drawcommits {row {endrow {}}} {
5083     global numcommits iddrawn displayorder curview need_redisplay
5084     global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5086     if {$row < 0} {
5087         set row 0
5088     }
5089     if {$endrow eq {}} {
5090         set endrow $row
5091     }
5092     if {$endrow >= $numcommits} {
5093         set endrow [expr {$numcommits - 1}]
5094     }
5096     set rl1 [expr {$row - $downarrowlen - 3}]
5097     if {$rl1 < 0} {
5098         set rl1 0
5099     }
5100     set ro1 [expr {$row - 3}]
5101     if {$ro1 < 0} {
5102         set ro1 0
5103     }
5104     set r2 [expr {$endrow + $uparrowlen + 3}]
5105     if {$r2 > $numcommits} {
5106         set r2 $numcommits
5107     }
5108     for {set r $rl1} {$r < $r2} {incr r} {
5109         if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5110             if {$rl1 < $r} {
5111                 layoutrows $rl1 $r
5112             }
5113             set rl1 [expr {$r + 1}]
5114         }
5115     }
5116     if {$rl1 < $r} {
5117         layoutrows $rl1 $r
5118     }
5119     optimize_rows $ro1 0 $r2
5120     if {$need_redisplay || $nrows_drawn > 2000} {
5121         clear_display
5122         drawvisible
5123     }
5125     # make the lines join to already-drawn rows either side
5126     set r [expr {$row - 1}]
5127     if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5128         set r $row
5129     }
5130     set er [expr {$endrow + 1}]
5131     if {$er >= $numcommits ||
5132         ![info exists iddrawn([lindex $displayorder $er])]} {
5133         set er $endrow
5134     }
5135     for {} {$r <= $er} {incr r} {
5136         set id [lindex $displayorder $r]
5137         set wasdrawn [info exists iddrawn($id)]
5138         drawcmitrow $r
5139         if {$r == $er} break
5140         set nextid [lindex $displayorder [expr {$r + 1}]]
5141         if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5142         drawparentlinks $id $r
5144         set rowids [lindex $rowidlist $r]
5145         foreach lid $rowids {
5146             if {$lid eq {}} continue
5147             if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5148             if {$lid eq $id} {
5149                 # see if this is the first child of any of its parents
5150                 foreach p [lindex $parentlist $r] {
5151                     if {[lsearch -exact $rowids $p] < 0} {
5152                         # make this line extend up to the child
5153                         set lineend($p) [drawlineseg $p $r $er 0]
5154                     }
5155                 }
5156             } else {
5157                 set lineend($lid) [drawlineseg $lid $r $er 1]
5158             }
5159         }
5160     }
5163 proc undolayout {row} {
5164     global uparrowlen mingaplen downarrowlen
5165     global rowidlist rowisopt rowfinal need_redisplay
5167     set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5168     if {$r < 0} {
5169         set r 0
5170     }
5171     if {[llength $rowidlist] > $r} {
5172         incr r -1
5173         set rowidlist [lrange $rowidlist 0 $r]
5174         set rowfinal [lrange $rowfinal 0 $r]
5175         set rowisopt [lrange $rowisopt 0 $r]
5176         set need_redisplay 1
5177         run drawvisible
5178     }
5181 proc drawvisible {} {
5182     global canv linespc curview vrowmod selectedline targetrow targetid
5183     global need_redisplay cscroll numcommits
5185     set fs [$canv yview]
5186     set ymax [lindex [$canv cget -scrollregion] 3]
5187     if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5188     set f0 [lindex $fs 0]
5189     set f1 [lindex $fs 1]
5190     set y0 [expr {int($f0 * $ymax)}]
5191     set y1 [expr {int($f1 * $ymax)}]
5193     if {[info exists targetid]} {
5194         if {[commitinview $targetid $curview]} {
5195             set r [rowofcommit $targetid]
5196             if {$r != $targetrow} {
5197                 # Fix up the scrollregion and change the scrolling position
5198                 # now that our target row has moved.
5199                 set diff [expr {($r - $targetrow) * $linespc}]
5200                 set targetrow $r
5201                 setcanvscroll
5202                 set ymax [lindex [$canv cget -scrollregion] 3]
5203                 incr y0 $diff
5204                 incr y1 $diff
5205                 set f0 [expr {$y0 / $ymax}]
5206                 set f1 [expr {$y1 / $ymax}]
5207                 allcanvs yview moveto $f0
5208                 $cscroll set $f0 $f1
5209                 set need_redisplay 1
5210             }
5211         } else {
5212             unset targetid
5213         }
5214     }
5216     set row [expr {int(($y0 - 3) / $linespc) - 1}]
5217     set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5218     if {$endrow >= $vrowmod($curview)} {
5219         update_arcrows $curview
5220     }
5221     if {$selectedline ne {} &&
5222         $row <= $selectedline && $selectedline <= $endrow} {
5223         set targetrow $selectedline
5224     } elseif {[info exists targetid]} {
5225         set targetrow [expr {int(($row + $endrow) / 2)}]
5226     }
5227     if {[info exists targetrow]} {
5228         if {$targetrow >= $numcommits} {
5229             set targetrow [expr {$numcommits - 1}]
5230         }
5231         set targetid [commitonrow $targetrow]
5232     }
5233     drawcommits $row $endrow
5236 proc clear_display {} {
5237     global iddrawn linesegs need_redisplay nrows_drawn
5238     global vhighlights fhighlights nhighlights rhighlights
5239     global linehtag linentag linedtag boldrows boldnamerows
5241     allcanvs delete all
5242     catch {unset iddrawn}
5243     catch {unset linesegs}
5244     catch {unset linehtag}
5245     catch {unset linentag}
5246     catch {unset linedtag}
5247     set boldrows {}
5248     set boldnamerows {}
5249     catch {unset vhighlights}
5250     catch {unset fhighlights}
5251     catch {unset nhighlights}
5252     catch {unset rhighlights}
5253     set need_redisplay 0
5254     set nrows_drawn 0
5257 proc findcrossings {id} {
5258     global rowidlist parentlist numcommits displayorder
5260     set cross {}
5261     set ccross {}
5262     foreach {s e} [rowranges $id] {
5263         if {$e >= $numcommits} {
5264             set e [expr {$numcommits - 1}]
5265         }
5266         if {$e <= $s} continue
5267         for {set row $e} {[incr row -1] >= $s} {} {
5268             set x [lsearch -exact [lindex $rowidlist $row] $id]
5269             if {$x < 0} break
5270             set olds [lindex $parentlist $row]
5271             set kid [lindex $displayorder $row]
5272             set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5273             if {$kidx < 0} continue
5274             set nextrow [lindex $rowidlist [expr {$row + 1}]]
5275             foreach p $olds {
5276                 set px [lsearch -exact $nextrow $p]
5277                 if {$px < 0} continue
5278                 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5279                     if {[lsearch -exact $ccross $p] >= 0} continue
5280                     if {$x == $px + ($kidx < $px? -1: 1)} {
5281                         lappend ccross $p
5282                     } elseif {[lsearch -exact $cross $p] < 0} {
5283                         lappend cross $p
5284                     }
5285                 }
5286             }
5287         }
5288     }
5289     return [concat $ccross {{}} $cross]
5292 proc assigncolor {id} {
5293     global colormap colors nextcolor
5294     global parents children children curview
5296     if {[info exists colormap($id)]} return
5297     set ncolors [llength $colors]
5298     if {[info exists children($curview,$id)]} {
5299         set kids $children($curview,$id)
5300     } else {
5301         set kids {}
5302     }
5303     if {[llength $kids] == 1} {
5304         set child [lindex $kids 0]
5305         if {[info exists colormap($child)]
5306             && [llength $parents($curview,$child)] == 1} {
5307             set colormap($id) $colormap($child)
5308             return
5309         }
5310     }
5311     set badcolors {}
5312     set origbad {}
5313     foreach x [findcrossings $id] {
5314         if {$x eq {}} {
5315             # delimiter between corner crossings and other crossings
5316             if {[llength $badcolors] >= $ncolors - 1} break
5317             set origbad $badcolors
5318         }
5319         if {[info exists colormap($x)]
5320             && [lsearch -exact $badcolors $colormap($x)] < 0} {
5321             lappend badcolors $colormap($x)
5322         }
5323     }
5324     if {[llength $badcolors] >= $ncolors} {
5325         set badcolors $origbad
5326     }
5327     set origbad $badcolors
5328     if {[llength $badcolors] < $ncolors - 1} {
5329         foreach child $kids {
5330             if {[info exists colormap($child)]
5331                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5332                 lappend badcolors $colormap($child)
5333             }
5334             foreach p $parents($curview,$child) {
5335                 if {[info exists colormap($p)]
5336                     && [lsearch -exact $badcolors $colormap($p)] < 0} {
5337                     lappend badcolors $colormap($p)
5338                 }
5339             }
5340         }
5341         if {[llength $badcolors] >= $ncolors} {
5342             set badcolors $origbad
5343         }
5344     }
5345     for {set i 0} {$i <= $ncolors} {incr i} {
5346         set c [lindex $colors $nextcolor]
5347         if {[incr nextcolor] >= $ncolors} {
5348             set nextcolor 0
5349         }
5350         if {[lsearch -exact $badcolors $c]} break
5351     }
5352     set colormap($id) $c
5355 proc bindline {t id} {
5356     global canv
5358     $canv bind $t <Enter> "lineenter %x %y $id"
5359     $canv bind $t <Motion> "linemotion %x %y $id"
5360     $canv bind $t <Leave> "lineleave $id"
5361     $canv bind $t <Button-1> "lineclick %x %y $id 1"
5364 proc drawtags {id x xt y1} {
5365     global idtags idheads idotherrefs mainhead
5366     global linespc lthickness
5367     global canv rowtextx curview fgcolor bgcolor ctxbut
5369     set marks {}
5370     set ntags 0
5371     set nheads 0
5372     if {[info exists idtags($id)]} {
5373         set marks $idtags($id)
5374         set ntags [llength $marks]
5375     }
5376     if {[info exists idheads($id)]} {
5377         set marks [concat $marks $idheads($id)]
5378         set nheads [llength $idheads($id)]
5379     }
5380     if {[info exists idotherrefs($id)]} {
5381         set marks [concat $marks $idotherrefs($id)]
5382     }
5383     if {$marks eq {}} {
5384         return $xt
5385     }
5387     set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5388     set yt [expr {$y1 - 0.5 * $linespc}]
5389     set yb [expr {$yt + $linespc - 1}]
5390     set xvals {}
5391     set wvals {}
5392     set i -1
5393     foreach tag $marks {
5394         incr i
5395         if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5396             set wid [font measure mainfontbold $tag]
5397         } else {
5398             set wid [font measure mainfont $tag]
5399         }
5400         lappend xvals $xt
5401         lappend wvals $wid
5402         set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5403     }
5404     set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5405                -width $lthickness -fill black -tags tag.$id]
5406     $canv lower $t
5407     foreach tag $marks x $xvals wid $wvals {
5408         set xl [expr {$x + $delta}]
5409         set xr [expr {$x + $delta + $wid + $lthickness}]
5410         set font mainfont
5411         if {[incr ntags -1] >= 0} {
5412             # draw a tag
5413             set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5414                        $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5415                        -width 1 -outline black -fill yellow -tags tag.$id]
5416             $canv bind $t <1> [list showtag $tag 1]
5417             set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5418         } else {
5419             # draw a head or other ref
5420             if {[incr nheads -1] >= 0} {
5421                 set col green
5422                 if {$tag eq $mainhead} {
5423                     set font mainfontbold
5424                 }
5425             } else {
5426                 set col "#ddddff"
5427             }
5428             set xl [expr {$xl - $delta/2}]
5429             $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5430                 -width 1 -outline black -fill $col -tags tag.$id
5431             if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5432                 set rwid [font measure mainfont $remoteprefix]
5433                 set xi [expr {$x + 1}]
5434                 set yti [expr {$yt + 1}]
5435                 set xri [expr {$x + $rwid}]
5436                 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5437                         -width 0 -fill "#ffddaa" -tags tag.$id
5438             }
5439         }
5440         set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5441                    -font $font -tags [list tag.$id text]]
5442         if {$ntags >= 0} {
5443             $canv bind $t <1> [list showtag $tag 1]
5444         } elseif {$nheads >= 0} {
5445             $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
5446         }
5447     }
5448     return $xt
5451 proc xcoord {i level ln} {
5452     global canvx0 xspc1 xspc2
5454     set x [expr {$canvx0 + $i * $xspc1($ln)}]
5455     if {$i > 0 && $i == $level} {
5456         set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5457     } elseif {$i > $level} {
5458         set x [expr {$x + $xspc2 - $xspc1($ln)}]
5459     }
5460     return $x
5463 proc show_status {msg} {
5464     global canv fgcolor
5466     clear_display
5467     $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5468         -tags text -fill $fgcolor
5471 # Don't change the text pane cursor if it is currently the hand cursor,
5472 # showing that we are over a sha1 ID link.
5473 proc settextcursor {c} {
5474     global ctext curtextcursor
5476     if {[$ctext cget -cursor] == $curtextcursor} {
5477         $ctext config -cursor $c
5478     }
5479     set curtextcursor $c
5482 proc nowbusy {what {name {}}} {
5483     global isbusy busyname statusw
5485     if {[array names isbusy] eq {}} {
5486         . config -cursor watch
5487         settextcursor watch
5488     }
5489     set isbusy($what) 1
5490     set busyname($what) $name
5491     if {$name ne {}} {
5492         $statusw conf -text $name
5493     }
5496 proc notbusy {what} {
5497     global isbusy maincursor textcursor busyname statusw
5499     catch {
5500         unset isbusy($what)
5501         if {$busyname($what) ne {} &&
5502             [$statusw cget -text] eq $busyname($what)} {
5503             $statusw conf -text {}
5504         }
5505     }
5506     if {[array names isbusy] eq {}} {
5507         . config -cursor $maincursor
5508         settextcursor $textcursor
5509     }
5512 proc findmatches {f} {
5513     global findtype findstring
5514     if {$findtype == [mc "Regexp"]} {
5515         set matches [regexp -indices -all -inline $findstring $f]
5516     } else {
5517         set fs $findstring
5518         if {$findtype == [mc "IgnCase"]} {
5519             set f [string tolower $f]
5520             set fs [string tolower $fs]
5521         }
5522         set matches {}
5523         set i 0
5524         set l [string length $fs]
5525         while {[set j [string first $fs $f $i]] >= 0} {
5526             lappend matches [list $j [expr {$j+$l-1}]]
5527             set i [expr {$j + $l}]
5528         }
5529     }
5530     return $matches
5533 proc dofind {{dirn 1} {wrap 1}} {
5534     global findstring findstartline findcurline selectedline numcommits
5535     global gdttype filehighlight fh_serial find_dirn findallowwrap
5537     if {[info exists find_dirn]} {
5538         if {$find_dirn == $dirn} return
5539         stopfinding
5540     }
5541     focus .
5542     if {$findstring eq {} || $numcommits == 0} return
5543     if {$selectedline eq {}} {
5544         set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5545     } else {
5546         set findstartline $selectedline
5547     }
5548     set findcurline $findstartline
5549     nowbusy finding [mc "Searching"]
5550     if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5551         after cancel do_file_hl $fh_serial
5552         do_file_hl $fh_serial
5553     }
5554     set find_dirn $dirn
5555     set findallowwrap $wrap
5556     run findmore
5559 proc stopfinding {} {
5560     global find_dirn findcurline fprogcoord
5562     if {[info exists find_dirn]} {
5563         unset find_dirn
5564         unset findcurline
5565         notbusy finding
5566         set fprogcoord 0
5567         adjustprogress
5568     }
5571 proc findmore {} {
5572     global commitdata commitinfo numcommits findpattern findloc
5573     global findstartline findcurline findallowwrap
5574     global find_dirn gdttype fhighlights fprogcoord
5575     global curview varcorder vrownum varccommits vrowmod
5577     if {![info exists find_dirn]} {
5578         return 0
5579     }
5580     set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5581     set l $findcurline
5582     set moretodo 0
5583     if {$find_dirn > 0} {
5584         incr l
5585         if {$l >= $numcommits} {
5586             set l 0
5587         }
5588         if {$l <= $findstartline} {
5589             set lim [expr {$findstartline + 1}]
5590         } else {
5591             set lim $numcommits
5592             set moretodo $findallowwrap
5593         }
5594     } else {
5595         if {$l == 0} {
5596             set l $numcommits
5597         }
5598         incr l -1
5599         if {$l >= $findstartline} {
5600             set lim [expr {$findstartline - 1}]
5601         } else {
5602             set lim -1
5603             set moretodo $findallowwrap
5604         }
5605     }
5606     set n [expr {($lim - $l) * $find_dirn}]
5607     if {$n > 500} {
5608         set n 500
5609         set moretodo 1
5610     }
5611     if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5612         update_arcrows $curview
5613     }
5614     set found 0
5615     set domore 1
5616     set ai [bsearch $vrownum($curview) $l]
5617     set a [lindex $varcorder($curview) $ai]
5618     set arow [lindex $vrownum($curview) $ai]
5619     set ids [lindex $varccommits($curview,$a)]
5620     set arowend [expr {$arow + [llength $ids]}]
5621     if {$gdttype eq [mc "containing:"]} {
5622         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5623             if {$l < $arow || $l >= $arowend} {
5624                 incr ai $find_dirn
5625                 set a [lindex $varcorder($curview) $ai]
5626                 set arow [lindex $vrownum($curview) $ai]
5627                 set ids [lindex $varccommits($curview,$a)]
5628                 set arowend [expr {$arow + [llength $ids]}]
5629             }
5630             set id [lindex $ids [expr {$l - $arow}]]
5631             # shouldn't happen unless git log doesn't give all the commits...
5632             if {![info exists commitdata($id)] ||
5633                 ![doesmatch $commitdata($id)]} {
5634                 continue
5635             }
5636             if {![info exists commitinfo($id)]} {
5637                 getcommit $id
5638             }
5639             set info $commitinfo($id)
5640             foreach f $info ty $fldtypes {
5641                 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5642                     [doesmatch $f]} {
5643                     set found 1
5644                     break
5645                 }
5646             }
5647             if {$found} break
5648         }
5649     } else {
5650         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5651             if {$l < $arow || $l >= $arowend} {
5652                 incr ai $find_dirn
5653                 set a [lindex $varcorder($curview) $ai]
5654                 set arow [lindex $vrownum($curview) $ai]
5655                 set ids [lindex $varccommits($curview,$a)]
5656                 set arowend [expr {$arow + [llength $ids]}]
5657             }
5658             set id [lindex $ids [expr {$l - $arow}]]
5659             if {![info exists fhighlights($id)]} {
5660                 # this sets fhighlights($id) to -1
5661                 askfilehighlight $l $id
5662             }
5663             if {$fhighlights($id) > 0} {
5664                 set found $domore
5665                 break
5666             }
5667             if {$fhighlights($id) < 0} {
5668                 if {$domore} {
5669                     set domore 0
5670                     set findcurline [expr {$l - $find_dirn}]
5671                 }
5672             }
5673         }
5674     }
5675     if {$found || ($domore && !$moretodo)} {
5676         unset findcurline
5677         unset find_dirn
5678         notbusy finding
5679         set fprogcoord 0
5680         adjustprogress
5681         if {$found} {
5682             findselectline $l
5683         } else {
5684             bell
5685         }
5686         return 0
5687     }
5688     if {!$domore} {
5689         flushhighlights
5690     } else {
5691         set findcurline [expr {$l - $find_dirn}]
5692     }
5693     set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5694     if {$n < 0} {
5695         incr n $numcommits
5696     }
5697     set fprogcoord [expr {$n * 1.0 / $numcommits}]
5698     adjustprogress
5699     return $domore
5702 proc findselectline {l} {
5703     global findloc commentend ctext findcurline markingmatches gdttype
5705     set markingmatches 1
5706     set findcurline $l
5707     selectline $l 1
5708     if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5709         # highlight the matches in the comments
5710         set f [$ctext get 1.0 $commentend]
5711         set matches [findmatches $f]
5712         foreach match $matches {
5713             set start [lindex $match 0]
5714             set end [expr {[lindex $match 1] + 1}]
5715             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5716         }
5717     }
5718     drawvisible
5721 # mark the bits of a headline or author that match a find string
5722 proc markmatches {canv l str tag matches font row} {
5723     global selectedline
5725     set bbox [$canv bbox $tag]
5726     set x0 [lindex $bbox 0]
5727     set y0 [lindex $bbox 1]
5728     set y1 [lindex $bbox 3]
5729     foreach match $matches {
5730         set start [lindex $match 0]
5731         set end [lindex $match 1]
5732         if {$start > $end} continue
5733         set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5734         set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5735         set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5736                    [expr {$x0+$xlen+2}] $y1 \
5737                    -outline {} -tags [list match$l matches] -fill yellow]
5738         $canv lower $t
5739         if {$row == $selectedline} {
5740             $canv raise $t secsel
5741         }
5742     }
5745 proc unmarkmatches {} {
5746     global markingmatches
5748     allcanvs delete matches
5749     set markingmatches 0
5750     stopfinding
5753 proc selcanvline {w x y} {
5754     global canv canvy0 ctext linespc
5755     global rowtextx
5756     set ymax [lindex [$canv cget -scrollregion] 3]
5757     if {$ymax == {}} return
5758     set yfrac [lindex [$canv yview] 0]
5759     set y [expr {$y + $yfrac * $ymax}]
5760     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5761     if {$l < 0} {
5762         set l 0
5763     }
5764     if {$w eq $canv} {
5765         set xmax [lindex [$canv cget -scrollregion] 2]
5766         set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5767         if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5768     }
5769     unmarkmatches
5770     selectline $l 1
5773 proc commit_descriptor {p} {
5774     global commitinfo
5775     if {![info exists commitinfo($p)]} {
5776         getcommit $p
5777     }
5778     set l "..."
5779     if {[llength $commitinfo($p)] > 1} {
5780         set l [lindex $commitinfo($p) 0]
5781     }
5782     return "$p ($l)\n"
5785 # append some text to the ctext widget, and make any SHA1 ID
5786 # that we know about be a clickable link.
5787 proc appendwithlinks {text tags} {
5788     global ctext linknum curview pendinglinks
5790     set start [$ctext index "end - 1c"]
5791     $ctext insert end $text $tags
5792     set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5793     foreach l $links {
5794         set s [lindex $l 0]
5795         set e [lindex $l 1]
5796         set linkid [string range $text $s $e]
5797         incr e
5798         $ctext tag delete link$linknum
5799         $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5800         setlink $linkid link$linknum
5801         incr linknum
5802     }
5805 proc setlink {id lk} {
5806     global curview ctext pendinglinks commitinterest
5808     if {[commitinview $id $curview]} {
5809         $ctext tag conf $lk -foreground blue -underline 1
5810         $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5811         $ctext tag bind $lk <Enter> {linkcursor %W 1}
5812         $ctext tag bind $lk <Leave> {linkcursor %W -1}
5813     } else {
5814         lappend pendinglinks($id) $lk
5815         lappend commitinterest($id) {makelink %I}
5816     }
5819 proc makelink {id} {
5820     global pendinglinks
5822     if {![info exists pendinglinks($id)]} return
5823     foreach lk $pendinglinks($id) {
5824         setlink $id $lk
5825     }
5826     unset pendinglinks($id)
5829 proc linkcursor {w inc} {
5830     global linkentercount curtextcursor
5832     if {[incr linkentercount $inc] > 0} {
5833         $w configure -cursor hand2
5834     } else {
5835         $w configure -cursor $curtextcursor
5836         if {$linkentercount < 0} {
5837             set linkentercount 0
5838         }
5839     }
5842 proc viewnextline {dir} {
5843     global canv linespc
5845     $canv delete hover
5846     set ymax [lindex [$canv cget -scrollregion] 3]
5847     set wnow [$canv yview]
5848     set wtop [expr {[lindex $wnow 0] * $ymax}]
5849     set newtop [expr {$wtop + $dir * $linespc}]
5850     if {$newtop < 0} {
5851         set newtop 0
5852     } elseif {$newtop > $ymax} {
5853         set newtop $ymax
5854     }
5855     allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5858 # add a list of tag or branch names at position pos
5859 # returns the number of names inserted
5860 proc appendrefs {pos ids var} {
5861     global ctext linknum curview $var maxrefs
5863     if {[catch {$ctext index $pos}]} {
5864         return 0
5865     }
5866     $ctext conf -state normal
5867     $ctext delete $pos "$pos lineend"
5868     set tags {}
5869     foreach id $ids {
5870         foreach tag [set $var\($id\)] {
5871             lappend tags [list $tag $id]
5872         }
5873     }
5874     if {[llength $tags] > $maxrefs} {
5875         $ctext insert $pos "many ([llength $tags])"
5876     } else {
5877         set tags [lsort -index 0 -decreasing $tags]
5878         set sep {}
5879         foreach ti $tags {
5880             set id [lindex $ti 1]
5881             set lk link$linknum
5882             incr linknum
5883             $ctext tag delete $lk
5884             $ctext insert $pos $sep
5885             $ctext insert $pos [lindex $ti 0] $lk
5886             setlink $id $lk
5887             set sep ", "
5888         }
5889     }
5890     $ctext conf -state disabled
5891     return [llength $tags]
5894 # called when we have finished computing the nearby tags
5895 proc dispneartags {delay} {
5896     global selectedline currentid showneartags tagphase
5898     if {$selectedline eq {} || !$showneartags} return
5899     after cancel dispnexttag
5900     if {$delay} {
5901         after 200 dispnexttag
5902         set tagphase -1
5903     } else {
5904         after idle dispnexttag
5905         set tagphase 0
5906     }
5909 proc dispnexttag {} {
5910     global selectedline currentid showneartags tagphase ctext
5912     if {$selectedline eq {} || !$showneartags} return
5913     switch -- $tagphase {
5914         0 {
5915             set dtags [desctags $currentid]
5916             if {$dtags ne {}} {
5917                 appendrefs precedes $dtags idtags
5918             }
5919         }
5920         1 {
5921             set atags [anctags $currentid]
5922             if {$atags ne {}} {
5923                 appendrefs follows $atags idtags
5924             }
5925         }
5926         2 {
5927             set dheads [descheads $currentid]
5928             if {$dheads ne {}} {
5929                 if {[appendrefs branch $dheads idheads] > 1
5930                     && [$ctext get "branch -3c"] eq "h"} {
5931                     # turn "Branch" into "Branches"
5932                     $ctext conf -state normal
5933                     $ctext insert "branch -2c" "es"
5934                     $ctext conf -state disabled
5935                 }
5936             }
5937         }
5938     }
5939     if {[incr tagphase] <= 2} {
5940         after idle dispnexttag
5941     }
5944 proc make_secsel {l} {
5945     global linehtag linentag linedtag canv canv2 canv3
5947     if {![info exists linehtag($l)]} return
5948     $canv delete secsel
5949     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5950                -tags secsel -fill [$canv cget -selectbackground]]
5951     $canv lower $t
5952     $canv2 delete secsel
5953     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5954                -tags secsel -fill [$canv2 cget -selectbackground]]
5955     $canv2 lower $t
5956     $canv3 delete secsel
5957     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5958                -tags secsel -fill [$canv3 cget -selectbackground]]
5959     $canv3 lower $t
5962 proc selectline {l isnew} {
5963     global canv ctext commitinfo selectedline
5964     global canvy0 linespc parents children curview
5965     global currentid sha1entry
5966     global commentend idtags linknum
5967     global mergemax numcommits pending_select
5968     global cmitmode showneartags allcommits
5969     global targetrow targetid lastscrollrows
5970     global autoselect
5972     catch {unset pending_select}
5973     $canv delete hover
5974     normalline
5975     unsel_reflist
5976     stopfinding
5977     if {$l < 0 || $l >= $numcommits} return
5978     set id [commitonrow $l]
5979     set targetid $id
5980     set targetrow $l
5981     set selectedline $l
5982     set currentid $id
5983     if {$lastscrollrows < $numcommits} {
5984         setcanvscroll
5985     }
5987     set y [expr {$canvy0 + $l * $linespc}]
5988     set ymax [lindex [$canv cget -scrollregion] 3]
5989     set ytop [expr {$y - $linespc - 1}]
5990     set ybot [expr {$y + $linespc + 1}]
5991     set wnow [$canv yview]
5992     set wtop [expr {[lindex $wnow 0] * $ymax}]
5993     set wbot [expr {[lindex $wnow 1] * $ymax}]
5994     set wh [expr {$wbot - $wtop}]
5995     set newtop $wtop
5996     if {$ytop < $wtop} {
5997         if {$ybot < $wtop} {
5998             set newtop [expr {$y - $wh / 2.0}]
5999         } else {
6000             set newtop $ytop
6001             if {$newtop > $wtop - $linespc} {
6002                 set newtop [expr {$wtop - $linespc}]
6003             }
6004         }
6005     } elseif {$ybot > $wbot} {
6006         if {$ytop > $wbot} {
6007             set newtop [expr {$y - $wh / 2.0}]
6008         } else {
6009             set newtop [expr {$ybot - $wh}]
6010             if {$newtop < $wtop + $linespc} {
6011                 set newtop [expr {$wtop + $linespc}]
6012             }
6013         }
6014     }
6015     if {$newtop != $wtop} {
6016         if {$newtop < 0} {
6017             set newtop 0
6018         }
6019         allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6020         drawvisible
6021     }
6023     make_secsel $l
6025     if {$isnew} {
6026         addtohistory [list selbyid $id]
6027     }
6029     $sha1entry delete 0 end
6030     $sha1entry insert 0 $id
6031     if {$autoselect} {
6032         $sha1entry selection from 0
6033         $sha1entry selection to end
6034     }
6035     rhighlight_sel $id
6037     $ctext conf -state normal
6038     clear_ctext
6039     set linknum 0
6040     if {![info exists commitinfo($id)]} {
6041         getcommit $id
6042     }
6043     set info $commitinfo($id)
6044     set date [formatdate [lindex $info 2]]
6045     $ctext insert end "[mc "Author"]: [lindex $info 1]  $date\n"
6046     set date [formatdate [lindex $info 4]]
6047     $ctext insert end "[mc "Committer"]: [lindex $info 3]  $date\n"
6048     if {[info exists idtags($id)]} {
6049         $ctext insert end [mc "Tags:"]
6050         foreach tag $idtags($id) {
6051             $ctext insert end " $tag"
6052         }
6053         $ctext insert end "\n"
6054     }
6056     set headers {}
6057     set olds $parents($curview,$id)
6058     if {[llength $olds] > 1} {
6059         set np 0
6060         foreach p $olds {
6061             if {$np >= $mergemax} {
6062                 set tag mmax
6063             } else {
6064                 set tag m$np
6065             }
6066             $ctext insert end "[mc "Parent"]: " $tag
6067             appendwithlinks [commit_descriptor $p] {}
6068             incr np
6069         }
6070     } else {
6071         foreach p $olds {
6072             append headers "[mc "Parent"]: [commit_descriptor $p]"
6073         }
6074     }
6076     foreach c $children($curview,$id) {
6077         append headers "[mc "Child"]:  [commit_descriptor $c]"
6078     }
6080     # make anything that looks like a SHA1 ID be a clickable link
6081     appendwithlinks $headers {}
6082     if {$showneartags} {
6083         if {![info exists allcommits]} {
6084             getallcommits
6085         }
6086         $ctext insert end "[mc "Branch"]: "
6087         $ctext mark set branch "end -1c"
6088         $ctext mark gravity branch left
6089         $ctext insert end "\n[mc "Follows"]: "
6090         $ctext mark set follows "end -1c"
6091         $ctext mark gravity follows left
6092         $ctext insert end "\n[mc "Precedes"]: "
6093         $ctext mark set precedes "end -1c"
6094         $ctext mark gravity precedes left
6095         $ctext insert end "\n"
6096         dispneartags 1
6097     }
6098     $ctext insert end "\n"
6099     set comment [lindex $info 5]
6100     if {[string first "\r" $comment] >= 0} {
6101         set comment [string map {"\r" "\n    "} $comment]
6102     }
6103     appendwithlinks $comment {comment}
6105     $ctext tag remove found 1.0 end
6106     $ctext conf -state disabled
6107     set commentend [$ctext index "end - 1c"]
6109     init_flist [mc "Comments"]
6110     if {$cmitmode eq "tree"} {
6111         gettree $id
6112     } elseif {[llength $olds] <= 1} {
6113         startdiff $id
6114     } else {
6115         mergediff $id
6116     }
6119 proc selfirstline {} {
6120     unmarkmatches
6121     selectline 0 1
6124 proc sellastline {} {
6125     global numcommits
6126     unmarkmatches
6127     set l [expr {$numcommits - 1}]
6128     selectline $l 1
6131 proc selnextline {dir} {
6132     global selectedline
6133     focus .
6134     if {$selectedline eq {}} return
6135     set l [expr {$selectedline + $dir}]
6136     unmarkmatches
6137     selectline $l 1
6140 proc selnextpage {dir} {
6141     global canv linespc selectedline numcommits
6143     set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6144     if {$lpp < 1} {
6145         set lpp 1
6146     }
6147     allcanvs yview scroll [expr {$dir * $lpp}] units
6148     drawvisible
6149     if {$selectedline eq {}} return
6150     set l [expr {$selectedline + $dir * $lpp}]
6151     if {$l < 0} {
6152         set l 0
6153     } elseif {$l >= $numcommits} {
6154         set l [expr $numcommits - 1]
6155     }
6156     unmarkmatches
6157     selectline $l 1
6160 proc unselectline {} {
6161     global selectedline currentid
6163     set selectedline {}
6164     catch {unset currentid}
6165     allcanvs delete secsel
6166     rhighlight_none
6169 proc reselectline {} {
6170     global selectedline
6172     if {$selectedline ne {}} {
6173         selectline $selectedline 0
6174     }
6177 proc addtohistory {cmd} {
6178     global history historyindex curview
6180     set elt [list $curview $cmd]
6181     if {$historyindex > 0
6182         && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6183         return
6184     }
6186     if {$historyindex < [llength $history]} {
6187         set history [lreplace $history $historyindex end $elt]
6188     } else {
6189         lappend history $elt
6190     }
6191     incr historyindex
6192     if {$historyindex > 1} {
6193         .tf.bar.leftbut conf -state normal
6194     } else {
6195         .tf.bar.leftbut conf -state disabled
6196     }
6197     .tf.bar.rightbut conf -state disabled
6200 proc godo {elt} {
6201     global curview
6203     set view [lindex $elt 0]
6204     set cmd [lindex $elt 1]
6205     if {$curview != $view} {
6206         showview $view
6207     }
6208     eval $cmd
6211 proc goback {} {
6212     global history historyindex
6213     focus .
6215     if {$historyindex > 1} {
6216         incr historyindex -1
6217         godo [lindex $history [expr {$historyindex - 1}]]
6218         .tf.bar.rightbut conf -state normal
6219     }
6220     if {$historyindex <= 1} {
6221         .tf.bar.leftbut conf -state disabled
6222     }
6225 proc goforw {} {
6226     global history historyindex
6227     focus .
6229     if {$historyindex < [llength $history]} {
6230         set cmd [lindex $history $historyindex]
6231         incr historyindex
6232         godo $cmd
6233         .tf.bar.leftbut conf -state normal
6234     }
6235     if {$historyindex >= [llength $history]} {
6236         .tf.bar.rightbut conf -state disabled
6237     }
6240 proc gettree {id} {
6241     global treefilelist treeidlist diffids diffmergeid treepending
6242     global nullid nullid2
6244     set diffids $id
6245     catch {unset diffmergeid}
6246     if {![info exists treefilelist($id)]} {
6247         if {![info exists treepending]} {
6248             if {$id eq $nullid} {
6249                 set cmd [list | git ls-files]
6250             } elseif {$id eq $nullid2} {
6251                 set cmd [list | git ls-files --stage -t]
6252             } else {
6253                 set cmd [list | git ls-tree -r $id]
6254             }
6255             if {[catch {set gtf [open $cmd r]}]} {
6256                 return
6257             }
6258             set treepending $id
6259             set treefilelist($id) {}
6260             set treeidlist($id) {}
6261             fconfigure $gtf -blocking 0 -encoding binary
6262             filerun $gtf [list gettreeline $gtf $id]
6263         }
6264     } else {
6265         setfilelist $id
6266     }
6269 proc gettreeline {gtf id} {
6270     global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6272     set nl 0
6273     while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6274         if {$diffids eq $nullid} {
6275             set fname $line
6276         } else {
6277             set i [string first "\t" $line]
6278             if {$i < 0} continue
6279             set fname [string range $line [expr {$i+1}] end]
6280             set line [string range $line 0 [expr {$i-1}]]
6281             if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6282             set sha1 [lindex $line 2]
6283             lappend treeidlist($id) $sha1
6284         }
6285         if {[string index $fname 0] eq "\""} {
6286             set fname [lindex $fname 0]
6287         }
6288         set fname [encoding convertfrom $fname]
6289         lappend treefilelist($id) $fname
6290     }
6291     if {![eof $gtf]} {
6292         return [expr {$nl >= 1000? 2: 1}]
6293     }
6294     close $gtf
6295     unset treepending
6296     if {$cmitmode ne "tree"} {
6297         if {![info exists diffmergeid]} {
6298             gettreediffs $diffids
6299         }
6300     } elseif {$id ne $diffids} {
6301         gettree $diffids
6302     } else {
6303         setfilelist $id
6304     }
6305     return 0
6308 proc showfile {f} {
6309     global treefilelist treeidlist diffids nullid nullid2
6310     global ctext commentend
6312     set i [lsearch -exact $treefilelist($diffids) $f]
6313     if {$i < 0} {
6314         puts "oops, $f not in list for id $diffids"
6315         return
6316     }
6317     if {$diffids eq $nullid} {
6318         if {[catch {set bf [open $f r]} err]} {
6319             puts "oops, can't read $f: $err"
6320             return
6321         }
6322     } else {
6323         set blob [lindex $treeidlist($diffids) $i]
6324         if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6325             puts "oops, error reading blob $blob: $err"
6326             return
6327         }
6328     }
6329     fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6330     filerun $bf [list getblobline $bf $diffids]
6331     $ctext config -state normal
6332     clear_ctext $commentend
6333     $ctext insert end "\n"
6334     $ctext insert end "$f\n" filesep
6335     $ctext config -state disabled
6336     $ctext yview $commentend
6337     settabs 0
6340 proc getblobline {bf id} {
6341     global diffids cmitmode ctext
6343     if {$id ne $diffids || $cmitmode ne "tree"} {
6344         catch {close $bf}
6345         return 0
6346     }
6347     $ctext config -state normal
6348     set nl 0
6349     while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6350         $ctext insert end "$line\n"
6351     }
6352     if {[eof $bf]} {
6353         # delete last newline
6354         $ctext delete "end - 2c" "end - 1c"
6355         close $bf
6356         return 0
6357     }
6358     $ctext config -state disabled
6359     return [expr {$nl >= 1000? 2: 1}]
6362 proc mergediff {id} {
6363     global diffmergeid mdifffd
6364     global diffids
6365     global parents
6366     global diffcontext
6367     global diffencoding
6368     global limitdiffs vfilelimit curview
6370     set diffmergeid $id
6371     set diffids $id
6372     # this doesn't seem to actually affect anything...
6373     set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6374     if {$limitdiffs && $vfilelimit($curview) ne {}} {
6375         set cmd [concat $cmd -- $vfilelimit($curview)]
6376     }
6377     if {[catch {set mdf [open $cmd r]} err]} {
6378         error_popup "[mc "Error getting merge diffs:"] $err"
6379         return
6380     }
6381     fconfigure $mdf -blocking 0 -encoding binary
6382     set mdifffd($id) $mdf
6383     set np [llength $parents($curview,$id)]
6384     set diffencoding [get_path_encoding {}]
6385     settabs $np
6386     filerun $mdf [list getmergediffline $mdf $id $np]
6389 proc getmergediffline {mdf id np} {
6390     global diffmergeid ctext cflist mergemax
6391     global difffilestart mdifffd
6392     global diffencoding
6394     $ctext conf -state normal
6395     set nr 0
6396     while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6397         if {![info exists diffmergeid] || $id != $diffmergeid
6398             || $mdf != $mdifffd($id)} {
6399             close $mdf
6400             return 0
6401         }
6402         if {[regexp {^diff --cc (.*)} $line match fname]} {
6403             # start of a new file
6404             set fname [encoding convertfrom $fname]
6405             $ctext insert end "\n"
6406             set here [$ctext index "end - 1c"]
6407             lappend difffilestart $here
6408             add_flist [list $fname]
6409             set diffencoding [get_path_encoding $fname]
6410             set l [expr {(78 - [string length $fname]) / 2}]
6411             set pad [string range "----------------------------------------" 1 $l]
6412             $ctext insert end "$pad $fname $pad\n" filesep
6413         } elseif {[regexp {^@@} $line]} {
6414             set line [encoding convertfrom $diffencoding $line]
6415             $ctext insert end "$line\n" hunksep
6416         } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6417             # do nothing
6418         } else {
6419             set line [encoding convertfrom $diffencoding $line]
6420             # parse the prefix - one ' ', '-' or '+' for each parent
6421             set spaces {}
6422             set minuses {}
6423             set pluses {}
6424             set isbad 0
6425             for {set j 0} {$j < $np} {incr j} {
6426                 set c [string range $line $j $j]
6427                 if {$c == " "} {
6428                     lappend spaces $j
6429                 } elseif {$c == "-"} {
6430                     lappend minuses $j
6431                 } elseif {$c == "+"} {
6432                     lappend pluses $j
6433                 } else {
6434                     set isbad 1
6435                     break
6436                 }
6437             }
6438             set tags {}
6439             set num {}
6440             if {!$isbad && $minuses ne {} && $pluses eq {}} {
6441                 # line doesn't appear in result, parents in $minuses have the line
6442                 set num [lindex $minuses 0]
6443             } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6444                 # line appears in result, parents in $pluses don't have the line
6445                 lappend tags mresult
6446                 set num [lindex $spaces 0]
6447             }
6448             if {$num ne {}} {
6449                 if {$num >= $mergemax} {
6450                     set num "max"
6451                 }
6452                 lappend tags m$num
6453             }
6454             $ctext insert end "$line\n" $tags
6455         }
6456     }
6457     $ctext conf -state disabled
6458     if {[eof $mdf]} {
6459         close $mdf
6460         return 0
6461     }
6462     return [expr {$nr >= 1000? 2: 1}]
6465 proc startdiff {ids} {
6466     global treediffs diffids treepending diffmergeid nullid nullid2
6468     settabs 1
6469     set diffids $ids
6470     catch {unset diffmergeid}
6471     if {![info exists treediffs($ids)] ||
6472         [lsearch -exact $ids $nullid] >= 0 ||
6473         [lsearch -exact $ids $nullid2] >= 0} {
6474         if {![info exists treepending]} {
6475             gettreediffs $ids
6476         }
6477     } else {
6478         addtocflist $ids
6479     }
6482 proc path_filter {filter name} {
6483     foreach p $filter {
6484         set l [string length $p]
6485         if {[string index $p end] eq "/"} {
6486             if {[string compare -length $l $p $name] == 0} {
6487                 return 1
6488             }
6489         } else {
6490             if {[string compare -length $l $p $name] == 0 &&
6491                 ([string length $name] == $l ||
6492                  [string index $name $l] eq "/")} {
6493                 return 1
6494             }
6495         }
6496     }
6497     return 0
6500 proc addtocflist {ids} {
6501     global treediffs
6503     add_flist $treediffs($ids)
6504     getblobdiffs $ids
6507 proc diffcmd {ids flags} {
6508     global nullid nullid2
6510     set i [lsearch -exact $ids $nullid]
6511     set j [lsearch -exact $ids $nullid2]
6512     if {$i >= 0} {
6513         if {[llength $ids] > 1 && $j < 0} {
6514             # comparing working directory with some specific revision
6515             set cmd [concat | git diff-index $flags]
6516             if {$i == 0} {
6517                 lappend cmd -R [lindex $ids 1]
6518             } else {
6519                 lappend cmd [lindex $ids 0]
6520             }
6521         } else {
6522             # comparing working directory with index
6523             set cmd [concat | git diff-files $flags]
6524             if {$j == 1} {
6525                 lappend cmd -R
6526             }
6527         }
6528     } elseif {$j >= 0} {
6529         set cmd [concat | git diff-index --cached $flags]
6530         if {[llength $ids] > 1} {
6531             # comparing index with specific revision
6532             if {$i == 0} {
6533                 lappend cmd -R [lindex $ids 1]
6534             } else {
6535                 lappend cmd [lindex $ids 0]
6536             }
6537         } else {
6538             # comparing index with HEAD
6539             lappend cmd HEAD
6540         }
6541     } else {
6542         set cmd [concat | git diff-tree -r $flags $ids]
6543     }
6544     return $cmd
6547 proc gettreediffs {ids} {
6548     global treediff treepending
6550     if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6552     set treepending $ids
6553     set treediff {}
6554     fconfigure $gdtf -blocking 0 -encoding binary
6555     filerun $gdtf [list gettreediffline $gdtf $ids]
6558 proc gettreediffline {gdtf ids} {
6559     global treediff treediffs treepending diffids diffmergeid
6560     global cmitmode vfilelimit curview limitdiffs perfile_attrs
6562     set nr 0
6563     set sublist {}
6564     set max 1000
6565     if {$perfile_attrs} {
6566         # cache_gitattr is slow, and even slower on win32 where we
6567         # have to invoke it for only about 30 paths at a time
6568         set max 500
6569         if {[tk windowingsystem] == "win32"} {
6570             set max 120
6571         }
6572     }
6573     while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
6574         set i [string first "\t" $line]
6575         if {$i >= 0} {
6576             set file [string range $line [expr {$i+1}] end]
6577             if {[string index $file 0] eq "\""} {
6578                 set file [lindex $file 0]
6579             }
6580             set file [encoding convertfrom $file]
6581             lappend treediff $file
6582             lappend sublist $file
6583         }
6584     }
6585     if {$perfile_attrs} {
6586         cache_gitattr encoding $sublist
6587     }
6588     if {![eof $gdtf]} {
6589         return [expr {$nr >= $max? 2: 1}]
6590     }
6591     close $gdtf
6592     if {$limitdiffs && $vfilelimit($curview) ne {}} {
6593         set flist {}
6594         foreach f $treediff {
6595             if {[path_filter $vfilelimit($curview) $f]} {
6596                 lappend flist $f
6597             }
6598         }
6599         set treediffs($ids) $flist
6600     } else {
6601         set treediffs($ids) $treediff
6602     }
6603     unset treepending
6604     if {$cmitmode eq "tree"} {
6605         gettree $diffids
6606     } elseif {$ids != $diffids} {
6607         if {![info exists diffmergeid]} {
6608             gettreediffs $diffids
6609         }
6610     } else {
6611         addtocflist $ids
6612     }
6613     return 0
6616 # empty string or positive integer
6617 proc diffcontextvalidate {v} {
6618     return [regexp {^(|[1-9][0-9]*)$} $v]
6621 proc diffcontextchange {n1 n2 op} {
6622     global diffcontextstring diffcontext
6624     if {[string is integer -strict $diffcontextstring]} {
6625         if {$diffcontextstring > 0} {
6626             set diffcontext $diffcontextstring
6627             reselectline
6628         }
6629     }
6632 proc changeignorespace {} {
6633     reselectline
6636 proc getblobdiffs {ids} {
6637     global blobdifffd diffids env
6638     global diffinhdr treediffs
6639     global diffcontext
6640     global ignorespace
6641     global limitdiffs vfilelimit curview
6642     global diffencoding
6644     set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6645     if {$ignorespace} {
6646         append cmd " -w"
6647     }
6648     if {$limitdiffs && $vfilelimit($curview) ne {}} {
6649         set cmd [concat $cmd -- $vfilelimit($curview)]
6650     }
6651     if {[catch {set bdf [open $cmd r]} err]} {
6652         puts "error getting diffs: $err"
6653         return
6654     }
6655     set diffinhdr 0
6656     set diffencoding [get_path_encoding {}]
6657     fconfigure $bdf -blocking 0 -encoding binary
6658     set blobdifffd($ids) $bdf
6659     filerun $bdf [list getblobdiffline $bdf $diffids]
6662 proc setinlist {var i val} {
6663     global $var
6665     while {[llength [set $var]] < $i} {
6666         lappend $var {}
6667     }
6668     if {[llength [set $var]] == $i} {
6669         lappend $var $val
6670     } else {
6671         lset $var $i $val
6672     }
6675 proc makediffhdr {fname ids} {
6676     global ctext curdiffstart treediffs
6678     set i [lsearch -exact $treediffs($ids) $fname]
6679     if {$i >= 0} {
6680         setinlist difffilestart $i $curdiffstart
6681     }
6682     set l [expr {(78 - [string length $fname]) / 2}]
6683     set pad [string range "----------------------------------------" 1 $l]
6684     $ctext insert $curdiffstart "$pad $fname $pad" filesep
6687 proc getblobdiffline {bdf ids} {
6688     global diffids blobdifffd ctext curdiffstart
6689     global diffnexthead diffnextnote difffilestart
6690     global diffinhdr treediffs
6691     global diffencoding
6693     set nr 0
6694     $ctext conf -state normal
6695     while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6696         if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6697             close $bdf
6698             return 0
6699         }
6700         if {![string compare -length 11 "diff --git " $line]} {
6701             # trim off "diff --git "
6702             set line [string range $line 11 end]
6703             set diffinhdr 1
6704             # start of a new file
6705             $ctext insert end "\n"
6706             set curdiffstart [$ctext index "end - 1c"]
6707             $ctext insert end "\n" filesep
6708             # If the name hasn't changed the length will be odd,
6709             # the middle char will be a space, and the two bits either
6710             # side will be a/name and b/name, or "a/name" and "b/name".
6711             # If the name has changed we'll get "rename from" and
6712             # "rename to" or "copy from" and "copy to" lines following this,
6713             # and we'll use them to get the filenames.
6714             # This complexity is necessary because spaces in the filename(s)
6715             # don't get escaped.
6716             set l [string length $line]
6717             set i [expr {$l / 2}]
6718             if {!(($l & 1) && [string index $line $i] eq " " &&
6719                   [string range $line 2 [expr {$i - 1}]] eq \
6720                       [string range $line [expr {$i + 3}] end])} {
6721                 continue
6722             }
6723             # unescape if quoted and chop off the a/ from the front
6724             if {[string index $line 0] eq "\""} {
6725                 set fname [string range [lindex $line 0] 2 end]
6726             } else {
6727                 set fname [string range $line 2 [expr {$i - 1}]]
6728             }
6729             set fname [encoding convertfrom $fname]
6730             set diffencoding [get_path_encoding $fname]
6731             makediffhdr $fname $ids
6733         } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6734                        $line match f1l f1c f2l f2c rest]} {
6735             set line [encoding convertfrom $diffencoding $line]
6736             $ctext insert end "$line\n" hunksep
6737             set diffinhdr 0
6739         } elseif {$diffinhdr} {
6740             if {![string compare -length 12 "rename from " $line]} {
6741                 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6742                 if {[string index $fname 0] eq "\""} {
6743                     set fname [lindex $fname 0]
6744                 }
6745                 set fname [encoding convertfrom $fname]
6746                 set i [lsearch -exact $treediffs($ids) $fname]
6747                 if {$i >= 0} {
6748                     setinlist difffilestart $i $curdiffstart
6749                 }
6750             } elseif {![string compare -length 10 $line "rename to "] ||
6751                       ![string compare -length 8 $line "copy to "]} {
6752                 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6753                 if {[string index $fname 0] eq "\""} {
6754                     set fname [lindex $fname 0]
6755                 }
6756                 set fname [encoding convertfrom $fname]
6757                 set diffencoding [get_path_encoding $fname]
6758                 makediffhdr $fname $ids
6759             } elseif {[string compare -length 3 $line "---"] == 0} {
6760                 # do nothing
6761                 continue
6762             } elseif {[string compare -length 3 $line "+++"] == 0} {
6763                 set diffinhdr 0
6764                 continue
6765             }
6766             $ctext insert end "$line\n" filesep
6768         } else {
6769             set line [encoding convertfrom $diffencoding $line]
6770             set x [string range $line 0 0]
6771             if {$x == "-" || $x == "+"} {
6772                 set tag [expr {$x == "+"}]
6773                 $ctext insert end "$line\n" d$tag
6774             } elseif {$x == " "} {
6775                 $ctext insert end "$line\n"
6776             } else {
6777                 # "\ No newline at end of file",
6778                 # or something else we don't recognize
6779                 $ctext insert end "$line\n" hunksep
6780             }
6781         }
6782     }
6783     $ctext conf -state disabled
6784     if {[eof $bdf]} {
6785         close $bdf
6786         return 0
6787     }
6788     return [expr {$nr >= 1000? 2: 1}]
6791 proc changediffdisp {} {
6792     global ctext diffelide
6794     $ctext tag conf d0 -elide [lindex $diffelide 0]
6795     $ctext tag conf d1 -elide [lindex $diffelide 1]
6798 proc highlightfile {loc cline} {
6799     global ctext cflist cflist_top
6801     $ctext yview $loc
6802     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6803     $cflist tag add highlight $cline.0 "$cline.0 lineend"
6804     $cflist see $cline.0
6805     set cflist_top $cline
6808 proc prevfile {} {
6809     global difffilestart ctext cmitmode
6811     if {$cmitmode eq "tree"} return
6812     set prev 0.0
6813     set prevline 1
6814     set here [$ctext index @0,0]
6815     foreach loc $difffilestart {
6816         if {[$ctext compare $loc >= $here]} {
6817             highlightfile $prev $prevline
6818             return
6819         }
6820         set prev $loc
6821         incr prevline
6822     }
6823     highlightfile $prev $prevline
6826 proc nextfile {} {
6827     global difffilestart ctext cmitmode
6829     if {$cmitmode eq "tree"} return
6830     set here [$ctext index @0,0]
6831     set line 1
6832     foreach loc $difffilestart {
6833         incr line
6834         if {[$ctext compare $loc > $here]} {
6835             highlightfile $loc $line
6836             return
6837         }
6838     }
6841 proc clear_ctext {{first 1.0}} {
6842     global ctext smarktop smarkbot
6843     global pendinglinks
6845     set l [lindex [split $first .] 0]
6846     if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6847         set smarktop $l
6848     }
6849     if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6850         set smarkbot $l
6851     }
6852     $ctext delete $first end
6853     if {$first eq "1.0"} {
6854         catch {unset pendinglinks}
6855     }
6858 proc settabs {{firstab {}}} {
6859     global firsttabstop tabstop ctext have_tk85
6861     if {$firstab ne {} && $have_tk85} {
6862         set firsttabstop $firstab
6863     }
6864     set w [font measure textfont "0"]
6865     if {$firsttabstop != 0} {
6866         $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6867                                [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6868     } elseif {$have_tk85 || $tabstop != 8} {
6869         $ctext conf -tabs [expr {$tabstop * $w}]
6870     } else {
6871         $ctext conf -tabs {}
6872     }
6875 proc incrsearch {name ix op} {
6876     global ctext searchstring searchdirn
6878     $ctext tag remove found 1.0 end
6879     if {[catch {$ctext index anchor}]} {
6880         # no anchor set, use start of selection, or of visible area
6881         set sel [$ctext tag ranges sel]
6882         if {$sel ne {}} {
6883             $ctext mark set anchor [lindex $sel 0]
6884         } elseif {$searchdirn eq "-forwards"} {
6885             $ctext mark set anchor @0,0
6886         } else {
6887             $ctext mark set anchor @0,[winfo height $ctext]
6888         }
6889     }
6890     if {$searchstring ne {}} {
6891         set here [$ctext search $searchdirn -- $searchstring anchor]
6892         if {$here ne {}} {
6893             $ctext see $here
6894         }
6895         searchmarkvisible 1
6896     }
6899 proc dosearch {} {
6900     global sstring ctext searchstring searchdirn
6902     focus $sstring
6903     $sstring icursor end
6904     set searchdirn -forwards
6905     if {$searchstring ne {}} {
6906         set sel [$ctext tag ranges sel]
6907         if {$sel ne {}} {
6908             set start "[lindex $sel 0] + 1c"
6909         } elseif {[catch {set start [$ctext index anchor]}]} {
6910             set start "@0,0"
6911         }
6912         set match [$ctext search -count mlen -- $searchstring $start]
6913         $ctext tag remove sel 1.0 end
6914         if {$match eq {}} {
6915             bell
6916             return
6917         }
6918         $ctext see $match
6919         set mend "$match + $mlen c"
6920         $ctext tag add sel $match $mend
6921         $ctext mark unset anchor
6922     }
6925 proc dosearchback {} {
6926     global sstring ctext searchstring searchdirn
6928     focus $sstring
6929     $sstring icursor end
6930     set searchdirn -backwards
6931     if {$searchstring ne {}} {
6932         set sel [$ctext tag ranges sel]
6933         if {$sel ne {}} {
6934             set start [lindex $sel 0]
6935         } elseif {[catch {set start [$ctext index anchor]}]} {
6936             set start @0,[winfo height $ctext]
6937         }
6938         set match [$ctext search -backwards -count ml -- $searchstring $start]
6939         $ctext tag remove sel 1.0 end
6940         if {$match eq {}} {
6941             bell
6942             return
6943         }
6944         $ctext see $match
6945         set mend "$match + $ml c"
6946         $ctext tag add sel $match $mend
6947         $ctext mark unset anchor
6948     }
6951 proc searchmark {first last} {
6952     global ctext searchstring
6954     set mend $first.0
6955     while {1} {
6956         set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6957         if {$match eq {}} break
6958         set mend "$match + $mlen c"
6959         $ctext tag add found $match $mend
6960     }
6963 proc searchmarkvisible {doall} {
6964     global ctext smarktop smarkbot
6966     set topline [lindex [split [$ctext index @0,0] .] 0]
6967     set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6968     if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6969         # no overlap with previous
6970         searchmark $topline $botline
6971         set smarktop $topline
6972         set smarkbot $botline
6973     } else {
6974         if {$topline < $smarktop} {
6975             searchmark $topline [expr {$smarktop-1}]
6976             set smarktop $topline
6977         }
6978         if {$botline > $smarkbot} {
6979             searchmark [expr {$smarkbot+1}] $botline
6980             set smarkbot $botline
6981         }
6982     }
6985 proc scrolltext {f0 f1} {
6986     global searchstring
6988     .bleft.bottom.sb set $f0 $f1
6989     if {$searchstring ne {}} {
6990         searchmarkvisible 0
6991     }
6994 proc setcoords {} {
6995     global linespc charspc canvx0 canvy0
6996     global xspc1 xspc2 lthickness
6998     set linespc [font metrics mainfont -linespace]
6999     set charspc [font measure mainfont "m"]
7000     set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7001     set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7002     set lthickness [expr {int($linespc / 9) + 1}]
7003     set xspc1(0) $linespc
7004     set xspc2 $linespc
7007 proc redisplay {} {
7008     global canv
7009     global selectedline
7011     set ymax [lindex [$canv cget -scrollregion] 3]
7012     if {$ymax eq {} || $ymax == 0} return
7013     set span [$canv yview]
7014     clear_display
7015     setcanvscroll
7016     allcanvs yview moveto [lindex $span 0]
7017     drawvisible
7018     if {$selectedline ne {}} {
7019         selectline $selectedline 0
7020         allcanvs yview moveto [lindex $span 0]
7021     }
7024 proc parsefont {f n} {
7025     global fontattr
7027     set fontattr($f,family) [lindex $n 0]
7028     set s [lindex $n 1]
7029     if {$s eq {} || $s == 0} {
7030         set s 10
7031     } elseif {$s < 0} {
7032         set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7033     }
7034     set fontattr($f,size) $s
7035     set fontattr($f,weight) normal
7036     set fontattr($f,slant) roman
7037     foreach style [lrange $n 2 end] {
7038         switch -- $style {
7039             "normal" -
7040             "bold"   {set fontattr($f,weight) $style}
7041             "roman" -
7042             "italic" {set fontattr($f,slant) $style}
7043         }
7044     }
7047 proc fontflags {f {isbold 0}} {
7048     global fontattr
7050     return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7051                 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7052                 -slant $fontattr($f,slant)]
7055 proc fontname {f} {
7056     global fontattr
7058     set n [list $fontattr($f,family) $fontattr($f,size)]
7059     if {$fontattr($f,weight) eq "bold"} {
7060         lappend n "bold"
7061     }
7062     if {$fontattr($f,slant) eq "italic"} {
7063         lappend n "italic"
7064     }
7065     return $n
7068 proc incrfont {inc} {
7069     global mainfont textfont ctext canv cflist showrefstop
7070     global stopped entries fontattr
7072     unmarkmatches
7073     set s $fontattr(mainfont,size)
7074     incr s $inc
7075     if {$s < 1} {
7076         set s 1
7077     }
7078     set fontattr(mainfont,size) $s
7079     font config mainfont -size $s
7080     font config mainfontbold -size $s
7081     set mainfont [fontname mainfont]
7082     set s $fontattr(textfont,size)
7083     incr s $inc
7084     if {$s < 1} {
7085         set s 1
7086     }
7087     set fontattr(textfont,size) $s
7088     font config textfont -size $s
7089     font config textfontbold -size $s
7090     set textfont [fontname textfont]
7091     setcoords
7092     settabs
7093     redisplay
7096 proc clearsha1 {} {
7097     global sha1entry sha1string
7098     if {[string length $sha1string] == 40} {
7099         $sha1entry delete 0 end
7100     }
7103 proc sha1change {n1 n2 op} {
7104     global sha1string currentid sha1but
7105     if {$sha1string == {}
7106         || ([info exists currentid] && $sha1string == $currentid)} {
7107         set state disabled
7108     } else {
7109         set state normal
7110     }
7111     if {[$sha1but cget -state] == $state} return
7112     if {$state == "normal"} {
7113         $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7114     } else {
7115         $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7116     }
7119 proc gotocommit {} {
7120     global sha1string tagids headids curview varcid
7122     if {$sha1string == {}
7123         || ([info exists currentid] && $sha1string == $currentid)} return
7124     if {[info exists tagids($sha1string)]} {
7125         set id $tagids($sha1string)
7126     } elseif {[info exists headids($sha1string)]} {
7127         set id $headids($sha1string)
7128     } else {
7129         set id [string tolower $sha1string]
7130         if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7131             set matches [array names varcid "$curview,$id*"]
7132             if {$matches ne {}} {
7133                 if {[llength $matches] > 1} {
7134                     error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7135                     return
7136                 }
7137                 set id [lindex [split [lindex $matches 0] ","] 1]
7138             }
7139         }
7140     }
7141     if {[commitinview $id $curview]} {
7142         selectline [rowofcommit $id] 1
7143         return
7144     }
7145     if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7146         set msg [mc "SHA1 id %s is not known" $sha1string]
7147     } else {
7148         set msg [mc "Tag/Head %s is not known" $sha1string]
7149     }
7150     error_popup $msg
7153 proc lineenter {x y id} {
7154     global hoverx hovery hoverid hovertimer
7155     global commitinfo canv
7157     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7158     set hoverx $x
7159     set hovery $y
7160     set hoverid $id
7161     if {[info exists hovertimer]} {
7162         after cancel $hovertimer
7163     }
7164     set hovertimer [after 500 linehover]
7165     $canv delete hover
7168 proc linemotion {x y id} {
7169     global hoverx hovery hoverid hovertimer
7171     if {[info exists hoverid] && $id == $hoverid} {
7172         set hoverx $x
7173         set hovery $y
7174         if {[info exists hovertimer]} {
7175             after cancel $hovertimer
7176         }
7177         set hovertimer [after 500 linehover]
7178     }
7181 proc lineleave {id} {
7182     global hoverid hovertimer canv
7184     if {[info exists hoverid] && $id == $hoverid} {
7185         $canv delete hover
7186         if {[info exists hovertimer]} {
7187             after cancel $hovertimer
7188             unset hovertimer
7189         }
7190         unset hoverid
7191     }
7194 proc linehover {} {
7195     global hoverx hovery hoverid hovertimer
7196     global canv linespc lthickness
7197     global commitinfo
7199     set text [lindex $commitinfo($hoverid) 0]
7200     set ymax [lindex [$canv cget -scrollregion] 3]
7201     if {$ymax == {}} return
7202     set yfrac [lindex [$canv yview] 0]
7203     set x [expr {$hoverx + 2 * $linespc}]
7204     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7205     set x0 [expr {$x - 2 * $lthickness}]
7206     set y0 [expr {$y - 2 * $lthickness}]
7207     set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7208     set y1 [expr {$y + $linespc + 2 * $lthickness}]
7209     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7210                -fill \#ffff80 -outline black -width 1 -tags hover]
7211     $canv raise $t
7212     set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7213                -font mainfont]
7214     $canv raise $t
7217 proc clickisonarrow {id y} {
7218     global lthickness
7220     set ranges [rowranges $id]
7221     set thresh [expr {2 * $lthickness + 6}]
7222     set n [expr {[llength $ranges] - 1}]
7223     for {set i 1} {$i < $n} {incr i} {
7224         set row [lindex $ranges $i]
7225         if {abs([yc $row] - $y) < $thresh} {
7226             return $i
7227         }
7228     }
7229     return {}
7232 proc arrowjump {id n y} {
7233     global canv
7235     # 1 <-> 2, 3 <-> 4, etc...
7236     set n [expr {(($n - 1) ^ 1) + 1}]
7237     set row [lindex [rowranges $id] $n]
7238     set yt [yc $row]
7239     set ymax [lindex [$canv cget -scrollregion] 3]
7240     if {$ymax eq {} || $ymax <= 0} return
7241     set view [$canv yview]
7242     set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7243     set yfrac [expr {$yt / $ymax - $yspan / 2}]
7244     if {$yfrac < 0} {
7245         set yfrac 0
7246     }
7247     allcanvs yview moveto $yfrac
7250 proc lineclick {x y id isnew} {
7251     global ctext commitinfo children canv thickerline curview
7253     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7254     unmarkmatches
7255     unselectline
7256     normalline
7257     $canv delete hover
7258     # draw this line thicker than normal
7259     set thickerline $id
7260     drawlines $id
7261     if {$isnew} {
7262         set ymax [lindex [$canv cget -scrollregion] 3]
7263         if {$ymax eq {}} return
7264         set yfrac [lindex [$canv yview] 0]
7265         set y [expr {$y + $yfrac * $ymax}]
7266     }
7267     set dirn [clickisonarrow $id $y]
7268     if {$dirn ne {}} {
7269         arrowjump $id $dirn $y
7270         return
7271     }
7273     if {$isnew} {
7274         addtohistory [list lineclick $x $y $id 0]
7275     }
7276     # fill the details pane with info about this line
7277     $ctext conf -state normal
7278     clear_ctext
7279     settabs 0
7280     $ctext insert end "[mc "Parent"]:\t"
7281     $ctext insert end $id link0
7282     setlink $id link0
7283     set info $commitinfo($id)
7284     $ctext insert end "\n\t[lindex $info 0]\n"
7285     $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7286     set date [formatdate [lindex $info 2]]
7287     $ctext insert end "\t[mc "Date"]:\t$date\n"
7288     set kids $children($curview,$id)
7289     if {$kids ne {}} {
7290         $ctext insert end "\n[mc "Children"]:"
7291         set i 0
7292         foreach child $kids {
7293             incr i
7294             if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7295             set info $commitinfo($child)
7296             $ctext insert end "\n\t"
7297             $ctext insert end $child link$i
7298             setlink $child link$i
7299             $ctext insert end "\n\t[lindex $info 0]"
7300             $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7301             set date [formatdate [lindex $info 2]]
7302             $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7303         }
7304     }
7305     $ctext conf -state disabled
7306     init_flist {}
7309 proc normalline {} {
7310     global thickerline
7311     if {[info exists thickerline]} {
7312         set id $thickerline
7313         unset thickerline
7314         drawlines $id
7315     }
7318 proc selbyid {id} {
7319     global curview
7320     if {[commitinview $id $curview]} {
7321         selectline [rowofcommit $id] 1
7322     }
7325 proc mstime {} {
7326     global startmstime
7327     if {![info exists startmstime]} {
7328         set startmstime [clock clicks -milliseconds]
7329     }
7330     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7333 proc rowmenu {x y id} {
7334     global rowctxmenu selectedline rowmenuid curview
7335     global nullid nullid2 fakerowmenu mainhead
7337     stopfinding
7338     set rowmenuid $id
7339     if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7340         set state disabled
7341     } else {
7342         set state normal
7343     }
7344     if {$id ne $nullid && $id ne $nullid2} {
7345         set menu $rowctxmenu
7346         if {$mainhead ne {}} {
7347             $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7348         } else {
7349             $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7350         }
7351     } else {
7352         set menu $fakerowmenu
7353     }
7354     $menu entryconfigure [mca "Diff this -> selected"] -state $state
7355     $menu entryconfigure [mca "Diff selected -> this"] -state $state
7356     $menu entryconfigure [mca "Make patch"] -state $state
7357     tk_popup $menu $x $y
7360 proc diffvssel {dirn} {
7361     global rowmenuid selectedline
7363     if {$selectedline eq {}} return
7364     if {$dirn} {
7365         set oldid [commitonrow $selectedline]
7366         set newid $rowmenuid
7367     } else {
7368         set oldid $rowmenuid
7369         set newid [commitonrow $selectedline]
7370     }
7371     addtohistory [list doseldiff $oldid $newid]
7372     doseldiff $oldid $newid
7375 proc doseldiff {oldid newid} {
7376     global ctext
7377     global commitinfo
7379     $ctext conf -state normal
7380     clear_ctext
7381     init_flist [mc "Top"]
7382     $ctext insert end "[mc "From"] "
7383     $ctext insert end $oldid link0
7384     setlink $oldid link0
7385     $ctext insert end "\n     "
7386     $ctext insert end [lindex $commitinfo($oldid) 0]
7387     $ctext insert end "\n\n[mc "To"]   "
7388     $ctext insert end $newid link1
7389     setlink $newid link1
7390     $ctext insert end "\n     "
7391     $ctext insert end [lindex $commitinfo($newid) 0]
7392     $ctext insert end "\n"
7393     $ctext conf -state disabled
7394     $ctext tag remove found 1.0 end
7395     startdiff [list $oldid $newid]
7398 proc mkpatch {} {
7399     global rowmenuid currentid commitinfo patchtop patchnum
7401     if {![info exists currentid]} return
7402     set oldid $currentid
7403     set oldhead [lindex $commitinfo($oldid) 0]
7404     set newid $rowmenuid
7405     set newhead [lindex $commitinfo($newid) 0]
7406     set top .patch
7407     set patchtop $top
7408     catch {destroy $top}
7409     toplevel $top
7410     label $top.title -text [mc "Generate patch"]
7411     grid $top.title - -pady 10
7412     label $top.from -text [mc "From:"]
7413     entry $top.fromsha1 -width 40 -relief flat
7414     $top.fromsha1 insert 0 $oldid
7415     $top.fromsha1 conf -state readonly
7416     grid $top.from $top.fromsha1 -sticky w
7417     entry $top.fromhead -width 60 -relief flat
7418     $top.fromhead insert 0 $oldhead
7419     $top.fromhead conf -state readonly
7420     grid x $top.fromhead -sticky w
7421     label $top.to -text [mc "To:"]
7422     entry $top.tosha1 -width 40 -relief flat
7423     $top.tosha1 insert 0 $newid
7424     $top.tosha1 conf -state readonly
7425     grid $top.to $top.tosha1 -sticky w
7426     entry $top.tohead -width 60 -relief flat
7427     $top.tohead insert 0 $newhead
7428     $top.tohead conf -state readonly
7429     grid x $top.tohead -sticky w
7430     button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7431     grid $top.rev x -pady 10
7432     label $top.flab -text [mc "Output file:"]
7433     entry $top.fname -width 60
7434     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7435     incr patchnum
7436     grid $top.flab $top.fname -sticky w
7437     frame $top.buts
7438     button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7439     button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7440     grid $top.buts.gen $top.buts.can
7441     grid columnconfigure $top.buts 0 -weight 1 -uniform a
7442     grid columnconfigure $top.buts 1 -weight 1 -uniform a
7443     grid $top.buts - -pady 10 -sticky ew
7444     focus $top.fname
7447 proc mkpatchrev {} {
7448     global patchtop
7450     set oldid [$patchtop.fromsha1 get]
7451     set oldhead [$patchtop.fromhead get]
7452     set newid [$patchtop.tosha1 get]
7453     set newhead [$patchtop.tohead get]
7454     foreach e [list fromsha1 fromhead tosha1 tohead] \
7455             v [list $newid $newhead $oldid $oldhead] {
7456         $patchtop.$e conf -state normal
7457         $patchtop.$e delete 0 end
7458         $patchtop.$e insert 0 $v
7459         $patchtop.$e conf -state readonly
7460     }
7463 proc mkpatchgo {} {
7464     global patchtop nullid nullid2
7466     set oldid [$patchtop.fromsha1 get]
7467     set newid [$patchtop.tosha1 get]
7468     set fname [$patchtop.fname get]
7469     set cmd [diffcmd [list $oldid $newid] -p]
7470     # trim off the initial "|"
7471     set cmd [lrange $cmd 1 end]
7472     lappend cmd >$fname &
7473     if {[catch {eval exec $cmd} err]} {
7474         error_popup "[mc "Error creating patch:"] $err"
7475     }
7476     catch {destroy $patchtop}
7477     unset patchtop
7480 proc mkpatchcan {} {
7481     global patchtop
7483     catch {destroy $patchtop}
7484     unset patchtop
7487 proc mktag {} {
7488     global rowmenuid mktagtop commitinfo
7490     set top .maketag
7491     set mktagtop $top
7492     catch {destroy $top}
7493     toplevel $top
7494     label $top.title -text [mc "Create tag"]
7495     grid $top.title - -pady 10
7496     label $top.id -text [mc "ID:"]
7497     entry $top.sha1 -width 40 -relief flat
7498     $top.sha1 insert 0 $rowmenuid
7499     $top.sha1 conf -state readonly
7500     grid $top.id $top.sha1 -sticky w
7501     entry $top.head -width 60 -relief flat
7502     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7503     $top.head conf -state readonly
7504     grid x $top.head -sticky w
7505     label $top.tlab -text [mc "Tag name:"]
7506     entry $top.tag -width 60
7507     grid $top.tlab $top.tag -sticky w
7508     frame $top.buts
7509     button $top.buts.gen -text [mc "Create"] -command mktaggo
7510     button $top.buts.can -text [mc "Cancel"] -command mktagcan
7511     grid $top.buts.gen $top.buts.can
7512     grid columnconfigure $top.buts 0 -weight 1 -uniform a
7513     grid columnconfigure $top.buts 1 -weight 1 -uniform a
7514     grid $top.buts - -pady 10 -sticky ew
7515     focus $top.tag
7518 proc domktag {} {
7519     global mktagtop env tagids idtags
7521     set id [$mktagtop.sha1 get]
7522     set tag [$mktagtop.tag get]
7523     if {$tag == {}} {
7524         error_popup [mc "No tag name specified"]
7525         return
7526     }
7527     if {[info exists tagids($tag)]} {
7528         error_popup [mc "Tag \"%s\" already exists" $tag]
7529         return
7530     }
7531     if {[catch {
7532         exec git tag $tag $id
7533     } err]} {
7534         error_popup "[mc "Error creating tag:"] $err"
7535         return
7536     }
7538     set tagids($tag) $id
7539     lappend idtags($id) $tag
7540     redrawtags $id
7541     addedtag $id
7542     dispneartags 0
7543     run refill_reflist
7546 proc redrawtags {id} {
7547     global canv linehtag idpos currentid curview cmitlisted
7548     global canvxmax iddrawn circleitem mainheadid circlecolors
7550     if {![commitinview $id $curview]} return
7551     if {![info exists iddrawn($id)]} return
7552     set row [rowofcommit $id]
7553     if {$id eq $mainheadid} {
7554         set ofill yellow
7555     } else {
7556         set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7557     }
7558     $canv itemconf $circleitem($row) -fill $ofill
7559     $canv delete tag.$id
7560     set xt [eval drawtags $id $idpos($id)]
7561     $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7562     set text [$canv itemcget $linehtag($row) -text]
7563     set font [$canv itemcget $linehtag($row) -font]
7564     set xr [expr {$xt + [font measure $font $text]}]
7565     if {$xr > $canvxmax} {
7566         set canvxmax $xr
7567         setcanvscroll
7568     }
7569     if {[info exists currentid] && $currentid == $id} {
7570         make_secsel $row
7571     }
7574 proc mktagcan {} {
7575     global mktagtop
7577     catch {destroy $mktagtop}
7578     unset mktagtop
7581 proc mktaggo {} {
7582     domktag
7583     mktagcan
7586 proc writecommit {} {
7587     global rowmenuid wrcomtop commitinfo wrcomcmd
7589     set top .writecommit
7590     set wrcomtop $top
7591     catch {destroy $top}
7592     toplevel $top
7593     label $top.title -text [mc "Write commit to file"]
7594     grid $top.title - -pady 10
7595     label $top.id -text [mc "ID:"]
7596     entry $top.sha1 -width 40 -relief flat
7597     $top.sha1 insert 0 $rowmenuid
7598     $top.sha1 conf -state readonly
7599     grid $top.id $top.sha1 -sticky w
7600     entry $top.head -width 60 -relief flat
7601     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7602     $top.head conf -state readonly
7603     grid x $top.head -sticky w
7604     label $top.clab -text [mc "Command:"]
7605     entry $top.cmd -width 60 -textvariable wrcomcmd
7606     grid $top.clab $top.cmd -sticky w -pady 10
7607     label $top.flab -text [mc "Output file:"]
7608     entry $top.fname -width 60
7609     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7610     grid $top.flab $top.fname -sticky w
7611     frame $top.buts
7612     button $top.buts.gen -text [mc "Write"] -command wrcomgo
7613     button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7614     grid $top.buts.gen $top.buts.can
7615     grid columnconfigure $top.buts 0 -weight 1 -uniform a
7616     grid columnconfigure $top.buts 1 -weight 1 -uniform a
7617     grid $top.buts - -pady 10 -sticky ew
7618     focus $top.fname
7621 proc wrcomgo {} {
7622     global wrcomtop
7624     set id [$wrcomtop.sha1 get]
7625     set cmd "echo $id | [$wrcomtop.cmd get]"
7626     set fname [$wrcomtop.fname get]
7627     if {[catch {exec sh -c $cmd >$fname &} err]} {
7628         error_popup "[mc "Error writing commit:"] $err"
7629     }
7630     catch {destroy $wrcomtop}
7631     unset wrcomtop
7634 proc wrcomcan {} {
7635     global wrcomtop
7637     catch {destroy $wrcomtop}
7638     unset wrcomtop
7641 proc mkbranch {} {
7642     global rowmenuid mkbrtop
7644     set top .makebranch
7645     catch {destroy $top}
7646     toplevel $top
7647     label $top.title -text [mc "Create new branch"]
7648     grid $top.title - -pady 10
7649     label $top.id -text [mc "ID:"]
7650     entry $top.sha1 -width 40 -relief flat
7651     $top.sha1 insert 0 $rowmenuid
7652     $top.sha1 conf -state readonly
7653     grid $top.id $top.sha1 -sticky w
7654     label $top.nlab -text [mc "Name:"]
7655     entry $top.name -width 40
7656     bind $top.name <Key-Return> "[list mkbrgo $top]"
7657     grid $top.nlab $top.name -sticky w
7658     frame $top.buts
7659     button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7660     button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7661     grid $top.buts.go $top.buts.can
7662     grid columnconfigure $top.buts 0 -weight 1 -uniform a
7663     grid columnconfigure $top.buts 1 -weight 1 -uniform a
7664     grid $top.buts - -pady 10 -sticky ew
7665     focus $top.name
7668 proc mkbrgo {top} {
7669     global headids idheads
7671     set name [$top.name get]
7672     set id [$top.sha1 get]
7673     if {$name eq {}} {
7674         error_popup [mc "Please specify a name for the new branch"]
7675         return
7676     }
7677     catch {destroy $top}
7678     nowbusy newbranch
7679     update
7680     if {[catch {
7681         exec git branch $name $id
7682     } err]} {
7683         notbusy newbranch
7684         error_popup $err
7685     } else {
7686         set headids($name) $id
7687         lappend idheads($id) $name
7688         addedhead $id $name
7689         notbusy newbranch
7690         redrawtags $id
7691         dispneartags 0
7692         run refill_reflist
7693     }
7696 proc cherrypick {} {
7697     global rowmenuid curview
7698     global mainhead mainheadid
7700     set oldhead [exec git rev-parse HEAD]
7701     set dheads [descheads $rowmenuid]
7702     if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7703         set ok [confirm_popup [mc "Commit %s is already\
7704                 included in branch %s -- really re-apply it?" \
7705                                    [string range $rowmenuid 0 7] $mainhead]]
7706         if {!$ok} return
7707     }
7708     nowbusy cherrypick [mc "Cherry-picking"]
7709     update
7710     # Unfortunately git-cherry-pick writes stuff to stderr even when
7711     # no error occurs, and exec takes that as an indication of error...
7712     if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7713         notbusy cherrypick
7714         error_popup $err
7715         return
7716     }
7717     set newhead [exec git rev-parse HEAD]
7718     if {$newhead eq $oldhead} {
7719         notbusy cherrypick
7720         error_popup [mc "No changes committed"]
7721         return
7722     }
7723     addnewchild $newhead $oldhead
7724     if {[commitinview $oldhead $curview]} {
7725         insertrow $newhead $oldhead $curview
7726         if {$mainhead ne {}} {
7727             movehead $newhead $mainhead
7728             movedhead $newhead $mainhead
7729         }
7730         set mainheadid $newhead
7731         redrawtags $oldhead
7732         redrawtags $newhead
7733         selbyid $newhead
7734     }
7735     notbusy cherrypick
7738 proc resethead {} {
7739     global mainhead rowmenuid confirm_ok resettype
7741     set confirm_ok 0
7742     set w ".confirmreset"
7743     toplevel $w
7744     wm transient $w .
7745     wm title $w [mc "Confirm reset"]
7746     message $w.m -text \
7747         [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7748         -justify center -aspect 1000
7749     pack $w.m -side top -fill x -padx 20 -pady 20
7750     frame $w.f -relief sunken -border 2
7751     message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7752     grid $w.f.rt -sticky w
7753     set resettype mixed
7754     radiobutton $w.f.soft -value soft -variable resettype -justify left \
7755         -text [mc "Soft: Leave working tree and index untouched"]
7756     grid $w.f.soft -sticky w
7757     radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7758         -text [mc "Mixed: Leave working tree untouched, reset index"]
7759     grid $w.f.mixed -sticky w
7760     radiobutton $w.f.hard -value hard -variable resettype -justify left \
7761         -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7762     grid $w.f.hard -sticky w
7763     pack $w.f -side top -fill x
7764     button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7765     pack $w.ok -side left -fill x -padx 20 -pady 20
7766     button $w.cancel -text [mc Cancel] -command "destroy $w"
7767     pack $w.cancel -side right -fill x -padx 20 -pady 20
7768     bind $w <Visibility> "grab $w; focus $w"
7769     tkwait window $w
7770     if {!$confirm_ok} return
7771     if {[catch {set fd [open \
7772             [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7773         error_popup $err
7774     } else {
7775         dohidelocalchanges
7776         filerun $fd [list readresetstat $fd]
7777         nowbusy reset [mc "Resetting"]
7778         selbyid $rowmenuid
7779     }
7782 proc readresetstat {fd} {
7783     global mainhead mainheadid showlocalchanges rprogcoord
7785     if {[gets $fd line] >= 0} {
7786         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7787             set rprogcoord [expr {1.0 * $m / $n}]
7788             adjustprogress
7789         }
7790         return 1
7791     }
7792     set rprogcoord 0
7793     adjustprogress
7794     notbusy reset
7795     if {[catch {close $fd} err]} {
7796         error_popup $err
7797     }
7798     set oldhead $mainheadid
7799     set newhead [exec git rev-parse HEAD]
7800     if {$newhead ne $oldhead} {
7801         movehead $newhead $mainhead
7802         movedhead $newhead $mainhead
7803         set mainheadid $newhead
7804         redrawtags $oldhead
7805         redrawtags $newhead
7806     }
7807     if {$showlocalchanges} {
7808         doshowlocalchanges
7809     }
7810     return 0
7813 # context menu for a head
7814 proc headmenu {x y id head} {
7815     global headmenuid headmenuhead headctxmenu mainhead
7817     stopfinding
7818     set headmenuid $id
7819     set headmenuhead $head
7820     set state normal
7821     if {$head eq $mainhead} {
7822         set state disabled
7823     }
7824     $headctxmenu entryconfigure 0 -state $state
7825     $headctxmenu entryconfigure 1 -state $state
7826     tk_popup $headctxmenu $x $y
7829 proc cobranch {} {
7830     global headmenuid headmenuhead headids
7831     global showlocalchanges mainheadid
7833     # check the tree is clean first??
7834     nowbusy checkout [mc "Checking out"]
7835     update
7836     dohidelocalchanges
7837     if {[catch {
7838         set fd [open [list | git checkout $headmenuhead 2>@1] r]
7839     } err]} {
7840         notbusy checkout
7841         error_popup $err
7842         if {$showlocalchanges} {
7843             dodiffindex
7844         }
7845     } else {
7846         filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7847     }
7850 proc readcheckoutstat {fd newhead newheadid} {
7851     global mainhead mainheadid headids showlocalchanges progresscoords
7853     if {[gets $fd line] >= 0} {
7854         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7855             set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7856             adjustprogress
7857         }
7858         return 1
7859     }
7860     set progresscoords {0 0}
7861     adjustprogress
7862     notbusy checkout
7863     if {[catch {close $fd} err]} {
7864         error_popup $err
7865     }
7866     set oldmainid $mainheadid
7867     set mainhead $newhead
7868     set mainheadid $newheadid
7869     redrawtags $oldmainid
7870     redrawtags $newheadid
7871     selbyid $newheadid
7872     if {$showlocalchanges} {
7873         dodiffindex
7874     }
7877 proc rmbranch {} {
7878     global headmenuid headmenuhead mainhead
7879     global idheads
7881     set head $headmenuhead
7882     set id $headmenuid
7883     # this check shouldn't be needed any more...
7884     if {$head eq $mainhead} {
7885         error_popup [mc "Cannot delete the currently checked-out branch"]
7886         return
7887     }
7888     set dheads [descheads $id]
7889     if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7890         # the stuff on this branch isn't on any other branch
7891         if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7892                         branch.\nReally delete branch %s?" $head $head]]} return
7893     }
7894     nowbusy rmbranch
7895     update
7896     if {[catch {exec git branch -D $head} err]} {
7897         notbusy rmbranch
7898         error_popup $err
7899         return
7900     }
7901     removehead $id $head
7902     removedhead $id $head
7903     redrawtags $id
7904     notbusy rmbranch
7905     dispneartags 0
7906     run refill_reflist
7909 # Display a list of tags and heads
7910 proc showrefs {} {
7911     global showrefstop bgcolor fgcolor selectbgcolor
7912     global bglist fglist reflistfilter reflist maincursor
7914     set top .showrefs
7915     set showrefstop $top
7916     if {[winfo exists $top]} {
7917         raise $top
7918         refill_reflist
7919         return
7920     }
7921     toplevel $top
7922     wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7923     text $top.list -background $bgcolor -foreground $fgcolor \
7924         -selectbackground $selectbgcolor -font mainfont \
7925         -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7926         -width 30 -height 20 -cursor $maincursor \
7927         -spacing1 1 -spacing3 1 -state disabled
7928     $top.list tag configure highlight -background $selectbgcolor
7929     lappend bglist $top.list
7930     lappend fglist $top.list
7931     scrollbar $top.ysb -command "$top.list yview" -orient vertical
7932     scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7933     grid $top.list $top.ysb -sticky nsew
7934     grid $top.xsb x -sticky ew
7935     frame $top.f
7936     label $top.f.l -text "[mc "Filter"]: "
7937     entry $top.f.e -width 20 -textvariable reflistfilter
7938     set reflistfilter "*"
7939     trace add variable reflistfilter write reflistfilter_change
7940     pack $top.f.e -side right -fill x -expand 1
7941     pack $top.f.l -side left
7942     grid $top.f - -sticky ew -pady 2
7943     button $top.close -command [list destroy $top] -text [mc "Close"]
7944     grid $top.close -
7945     grid columnconfigure $top 0 -weight 1
7946     grid rowconfigure $top 0 -weight 1
7947     bind $top.list <1> {break}
7948     bind $top.list <B1-Motion> {break}
7949     bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7950     set reflist {}
7951     refill_reflist
7954 proc sel_reflist {w x y} {
7955     global showrefstop reflist headids tagids otherrefids
7957     if {![winfo exists $showrefstop]} return
7958     set l [lindex [split [$w index "@$x,$y"] "."] 0]
7959     set ref [lindex $reflist [expr {$l-1}]]
7960     set n [lindex $ref 0]
7961     switch -- [lindex $ref 1] {
7962         "H" {selbyid $headids($n)}
7963         "T" {selbyid $tagids($n)}
7964         "o" {selbyid $otherrefids($n)}
7965     }
7966     $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7969 proc unsel_reflist {} {
7970     global showrefstop
7972     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7973     $showrefstop.list tag remove highlight 0.0 end
7976 proc reflistfilter_change {n1 n2 op} {
7977     global reflistfilter
7979     after cancel refill_reflist
7980     after 200 refill_reflist
7983 proc refill_reflist {} {
7984     global reflist reflistfilter showrefstop headids tagids otherrefids
7985     global curview commitinterest
7987     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7988     set refs {}
7989     foreach n [array names headids] {
7990         if {[string match $reflistfilter $n]} {
7991             if {[commitinview $headids($n) $curview]} {
7992                 lappend refs [list $n H]
7993             } else {
7994                 set commitinterest($headids($n)) {run refill_reflist}
7995             }
7996         }
7997     }
7998     foreach n [array names tagids] {
7999         if {[string match $reflistfilter $n]} {
8000             if {[commitinview $tagids($n) $curview]} {
8001                 lappend refs [list $n T]
8002             } else {
8003                 set commitinterest($tagids($n)) {run refill_reflist}
8004             }
8005         }
8006     }
8007     foreach n [array names otherrefids] {
8008         if {[string match $reflistfilter $n]} {
8009             if {[commitinview $otherrefids($n) $curview]} {
8010                 lappend refs [list $n o]
8011             } else {
8012                 set commitinterest($otherrefids($n)) {run refill_reflist}
8013             }
8014         }
8015     }
8016     set refs [lsort -index 0 $refs]
8017     if {$refs eq $reflist} return
8019     # Update the contents of $showrefstop.list according to the
8020     # differences between $reflist (old) and $refs (new)
8021     $showrefstop.list conf -state normal
8022     $showrefstop.list insert end "\n"
8023     set i 0
8024     set j 0
8025     while {$i < [llength $reflist] || $j < [llength $refs]} {
8026         if {$i < [llength $reflist]} {
8027             if {$j < [llength $refs]} {
8028                 set cmp [string compare [lindex $reflist $i 0] \
8029                              [lindex $refs $j 0]]
8030                 if {$cmp == 0} {
8031                     set cmp [string compare [lindex $reflist $i 1] \
8032                                  [lindex $refs $j 1]]
8033                 }
8034             } else {
8035                 set cmp -1
8036             }
8037         } else {
8038             set cmp 1
8039         }
8040         switch -- $cmp {
8041             -1 {
8042                 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8043                 incr i
8044             }
8045             0 {
8046                 incr i
8047                 incr j
8048             }
8049             1 {
8050                 set l [expr {$j + 1}]
8051                 $showrefstop.list image create $l.0 -align baseline \
8052                     -image reficon-[lindex $refs $j 1] -padx 2
8053                 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8054                 incr j
8055             }
8056         }
8057     }
8058     set reflist $refs
8059     # delete last newline
8060     $showrefstop.list delete end-2c end-1c
8061     $showrefstop.list conf -state disabled
8064 # Stuff for finding nearby tags
8065 proc getallcommits {} {
8066     global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8067     global idheads idtags idotherrefs allparents tagobjid
8069     if {![info exists allcommits]} {
8070         set nextarc 0
8071         set allcommits 0
8072         set seeds {}
8073         set allcwait 0
8074         set cachedarcs 0
8075         set allccache [file join [gitdir] "gitk.cache"]
8076         if {![catch {
8077             set f [open $allccache r]
8078             set allcwait 1
8079             getcache $f
8080         }]} return
8081     }
8083     if {$allcwait} {
8084         return
8085     }
8086     set cmd [list | git rev-list --parents]
8087     set allcupdate [expr {$seeds ne {}}]
8088     if {!$allcupdate} {
8089         set ids "--all"
8090     } else {
8091         set refs [concat [array names idheads] [array names idtags] \
8092                       [array names idotherrefs]]
8093         set ids {}
8094         set tagobjs {}
8095         foreach name [array names tagobjid] {
8096             lappend tagobjs $tagobjid($name)
8097         }
8098         foreach id [lsort -unique $refs] {
8099             if {![info exists allparents($id)] &&
8100                 [lsearch -exact $tagobjs $id] < 0} {
8101                 lappend ids $id
8102             }
8103         }
8104         if {$ids ne {}} {
8105             foreach id $seeds {
8106                 lappend ids "^$id"
8107             }
8108         }
8109     }
8110     if {$ids ne {}} {
8111         set fd [open [concat $cmd $ids] r]
8112         fconfigure $fd -blocking 0
8113         incr allcommits
8114         nowbusy allcommits
8115         filerun $fd [list getallclines $fd]
8116     } else {
8117         dispneartags 0
8118     }
8121 # Since most commits have 1 parent and 1 child, we group strings of
8122 # such commits into "arcs" joining branch/merge points (BMPs), which
8123 # are commits that either don't have 1 parent or don't have 1 child.
8125 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8126 # arcout(id) - outgoing arcs for BMP
8127 # arcids(a) - list of IDs on arc including end but not start
8128 # arcstart(a) - BMP ID at start of arc
8129 # arcend(a) - BMP ID at end of arc
8130 # growing(a) - arc a is still growing
8131 # arctags(a) - IDs out of arcids (excluding end) that have tags
8132 # archeads(a) - IDs out of arcids (excluding end) that have heads
8133 # The start of an arc is at the descendent end, so "incoming" means
8134 # coming from descendents, and "outgoing" means going towards ancestors.
8136 proc getallclines {fd} {
8137     global allparents allchildren idtags idheads nextarc
8138     global arcnos arcids arctags arcout arcend arcstart archeads growing
8139     global seeds allcommits cachedarcs allcupdate
8140     
8141     set nid 0
8142     while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8143         set id [lindex $line 0]
8144         if {[info exists allparents($id)]} {
8145             # seen it already
8146             continue
8147         }
8148         set cachedarcs 0
8149         set olds [lrange $line 1 end]
8150         set allparents($id) $olds
8151         if {![info exists allchildren($id)]} {
8152             set allchildren($id) {}
8153             set arcnos($id) {}
8154             lappend seeds $id
8155         } else {
8156             set a $arcnos($id)
8157             if {[llength $olds] == 1 && [llength $a] == 1} {
8158                 lappend arcids($a) $id
8159                 if {[info exists idtags($id)]} {
8160                     lappend arctags($a) $id
8161                 }
8162                 if {[info exists idheads($id)]} {
8163                     lappend archeads($a) $id
8164                 }
8165                 if {[info exists allparents($olds)]} {
8166                     # seen parent already
8167                     if {![info exists arcout($olds)]} {
8168                         splitarc $olds
8169                     }
8170                     lappend arcids($a) $olds
8171                     set arcend($a) $olds
8172                     unset growing($a)
8173                 }
8174                 lappend allchildren($olds) $id
8175                 lappend arcnos($olds) $a
8176                 continue
8177             }
8178         }
8179         foreach a $arcnos($id) {
8180             lappend arcids($a) $id
8181             set arcend($a) $id
8182             unset growing($a)
8183         }
8185         set ao {}
8186         foreach p $olds {
8187             lappend allchildren($p) $id
8188             set a [incr nextarc]
8189             set arcstart($a) $id
8190             set archeads($a) {}
8191             set arctags($a) {}
8192             set archeads($a) {}
8193             set arcids($a) {}
8194             lappend ao $a
8195             set growing($a) 1
8196             if {[info exists allparents($p)]} {
8197                 # seen it already, may need to make a new branch
8198                 if {![info exists arcout($p)]} {
8199                     splitarc $p
8200                 }
8201                 lappend arcids($a) $p
8202                 set arcend($a) $p
8203                 unset growing($a)
8204             }
8205             lappend arcnos($p) $a
8206         }
8207         set arcout($id) $ao
8208     }
8209     if {$nid > 0} {
8210         global cached_dheads cached_dtags cached_atags
8211         catch {unset cached_dheads}
8212         catch {unset cached_dtags}
8213         catch {unset cached_atags}
8214     }
8215     if {![eof $fd]} {
8216         return [expr {$nid >= 1000? 2: 1}]
8217     }
8218     set cacheok 1
8219     if {[catch {
8220         fconfigure $fd -blocking 1
8221         close $fd
8222     } err]} {
8223         # got an error reading the list of commits
8224         # if we were updating, try rereading the whole thing again
8225         if {$allcupdate} {
8226             incr allcommits -1
8227             dropcache $err
8228             return
8229         }
8230         error_popup "[mc "Error reading commit topology information;\
8231                 branch and preceding/following tag information\
8232                 will be incomplete."]\n($err)"
8233         set cacheok 0
8234     }
8235     if {[incr allcommits -1] == 0} {
8236         notbusy allcommits
8237         if {$cacheok} {
8238             run savecache
8239         }
8240     }
8241     dispneartags 0
8242     return 0
8245 proc recalcarc {a} {
8246     global arctags archeads arcids idtags idheads
8248     set at {}
8249     set ah {}
8250     foreach id [lrange $arcids($a) 0 end-1] {
8251         if {[info exists idtags($id)]} {
8252             lappend at $id
8253         }
8254         if {[info exists idheads($id)]} {
8255             lappend ah $id
8256         }
8257     }
8258     set arctags($a) $at
8259     set archeads($a) $ah
8262 proc splitarc {p} {
8263     global arcnos arcids nextarc arctags archeads idtags idheads
8264     global arcstart arcend arcout allparents growing
8266     set a $arcnos($p)
8267     if {[llength $a] != 1} {
8268         puts "oops splitarc called but [llength $a] arcs already"
8269         return
8270     }
8271     set a [lindex $a 0]
8272     set i [lsearch -exact $arcids($a) $p]
8273     if {$i < 0} {
8274         puts "oops splitarc $p not in arc $a"
8275         return
8276     }
8277     set na [incr nextarc]
8278     if {[info exists arcend($a)]} {
8279         set arcend($na) $arcend($a)
8280     } else {
8281         set l [lindex $allparents([lindex $arcids($a) end]) 0]
8282         set j [lsearch -exact $arcnos($l) $a]
8283         set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8284     }
8285     set tail [lrange $arcids($a) [expr {$i+1}] end]
8286     set arcids($a) [lrange $arcids($a) 0 $i]
8287     set arcend($a) $p
8288     set arcstart($na) $p
8289     set arcout($p) $na
8290     set arcids($na) $tail
8291     if {[info exists growing($a)]} {
8292         set growing($na) 1
8293         unset growing($a)
8294     }
8296     foreach id $tail {
8297         if {[llength $arcnos($id)] == 1} {
8298             set arcnos($id) $na
8299         } else {
8300             set j [lsearch -exact $arcnos($id) $a]
8301             set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8302         }
8303     }
8305     # reconstruct tags and heads lists
8306     if {$arctags($a) ne {} || $archeads($a) ne {}} {
8307         recalcarc $a
8308         recalcarc $na
8309     } else {
8310         set arctags($na) {}
8311         set archeads($na) {}
8312     }
8315 # Update things for a new commit added that is a child of one
8316 # existing commit.  Used when cherry-picking.
8317 proc addnewchild {id p} {
8318     global allparents allchildren idtags nextarc
8319     global arcnos arcids arctags arcout arcend arcstart archeads growing
8320     global seeds allcommits
8322     if {![info exists allcommits] || ![info exists arcnos($p)]} return
8323     set allparents($id) [list $p]
8324     set allchildren($id) {}
8325     set arcnos($id) {}
8326     lappend seeds $id
8327     lappend allchildren($p) $id
8328     set a [incr nextarc]
8329     set arcstart($a) $id
8330     set archeads($a) {}
8331     set arctags($a) {}
8332     set arcids($a) [list $p]
8333     set arcend($a) $p
8334     if {![info exists arcout($p)]} {
8335         splitarc $p
8336     }
8337     lappend arcnos($p) $a
8338     set arcout($id) [list $a]
8341 # This implements a cache for the topology information.
8342 # The cache saves, for each arc, the start and end of the arc,
8343 # the ids on the arc, and the outgoing arcs from the end.
8344 proc readcache {f} {
8345     global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8346     global idtags idheads allparents cachedarcs possible_seeds seeds growing
8347     global allcwait
8349     set a $nextarc
8350     set lim $cachedarcs
8351     if {$lim - $a > 500} {
8352         set lim [expr {$a + 500}]
8353     }
8354     if {[catch {
8355         if {$a == $lim} {
8356             # finish reading the cache and setting up arctags, etc.
8357             set line [gets $f]
8358             if {$line ne "1"} {error "bad final version"}
8359             close $f
8360             foreach id [array names idtags] {
8361                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8362                     [llength $allparents($id)] == 1} {
8363                     set a [lindex $arcnos($id) 0]
8364                     if {$arctags($a) eq {}} {
8365                         recalcarc $a
8366                     }
8367                 }
8368             }
8369             foreach id [array names idheads] {
8370                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8371                     [llength $allparents($id)] == 1} {
8372                     set a [lindex $arcnos($id) 0]
8373                     if {$archeads($a) eq {}} {
8374                         recalcarc $a
8375                     }
8376                 }
8377             }
8378             foreach id [lsort -unique $possible_seeds] {
8379                 if {$arcnos($id) eq {}} {
8380                     lappend seeds $id
8381                 }
8382             }
8383             set allcwait 0
8384         } else {
8385             while {[incr a] <= $lim} {
8386                 set line [gets $f]
8387                 if {[llength $line] != 3} {error "bad line"}
8388                 set s [lindex $line 0]
8389                 set arcstart($a) $s
8390                 lappend arcout($s) $a
8391                 if {![info exists arcnos($s)]} {
8392                     lappend possible_seeds $s
8393                     set arcnos($s) {}
8394                 }
8395                 set e [lindex $line 1]
8396                 if {$e eq {}} {
8397                     set growing($a) 1
8398                 } else {
8399                     set arcend($a) $e
8400                     if {![info exists arcout($e)]} {
8401                         set arcout($e) {}
8402                     }
8403                 }
8404                 set arcids($a) [lindex $line 2]
8405                 foreach id $arcids($a) {
8406                     lappend allparents($s) $id
8407                     set s $id
8408                     lappend arcnos($id) $a
8409                 }
8410                 if {![info exists allparents($s)]} {
8411                     set allparents($s) {}
8412                 }
8413                 set arctags($a) {}
8414                 set archeads($a) {}
8415             }
8416             set nextarc [expr {$a - 1}]
8417         }
8418     } err]} {
8419         dropcache $err
8420         return 0
8421     }
8422     if {!$allcwait} {
8423         getallcommits
8424     }
8425     return $allcwait
8428 proc getcache {f} {
8429     global nextarc cachedarcs possible_seeds
8431     if {[catch {
8432         set line [gets $f]
8433         if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8434         # make sure it's an integer
8435         set cachedarcs [expr {int([lindex $line 1])}]
8436         if {$cachedarcs < 0} {error "bad number of arcs"}
8437         set nextarc 0
8438         set possible_seeds {}
8439         run readcache $f
8440     } err]} {
8441         dropcache $err
8442     }
8443     return 0
8446 proc dropcache {err} {
8447     global allcwait nextarc cachedarcs seeds
8449     #puts "dropping cache ($err)"
8450     foreach v {arcnos arcout arcids arcstart arcend growing \
8451                    arctags archeads allparents allchildren} {
8452         global $v
8453         catch {unset $v}
8454     }
8455     set allcwait 0
8456     set nextarc 0
8457     set cachedarcs 0
8458     set seeds {}
8459     getallcommits
8462 proc writecache {f} {
8463     global cachearc cachedarcs allccache
8464     global arcstart arcend arcnos arcids arcout
8466     set a $cachearc
8467     set lim $cachedarcs
8468     if {$lim - $a > 1000} {
8469         set lim [expr {$a + 1000}]
8470     }
8471     if {[catch {
8472         while {[incr a] <= $lim} {
8473             if {[info exists arcend($a)]} {
8474                 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8475             } else {
8476                 puts $f [list $arcstart($a) {} $arcids($a)]
8477             }
8478         }
8479     } err]} {
8480         catch {close $f}
8481         catch {file delete $allccache}
8482         #puts "writing cache failed ($err)"
8483         return 0
8484     }
8485     set cachearc [expr {$a - 1}]
8486     if {$a > $cachedarcs} {
8487         puts $f "1"
8488         close $f
8489         return 0
8490     }
8491     return 1
8494 proc savecache {} {
8495     global nextarc cachedarcs cachearc allccache
8497     if {$nextarc == $cachedarcs} return
8498     set cachearc 0
8499     set cachedarcs $nextarc
8500     catch {
8501         set f [open $allccache w]
8502         puts $f [list 1 $cachedarcs]
8503         run writecache $f
8504     }
8507 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8508 # or 0 if neither is true.
8509 proc anc_or_desc {a b} {
8510     global arcout arcstart arcend arcnos cached_isanc
8512     if {$arcnos($a) eq $arcnos($b)} {
8513         # Both are on the same arc(s); either both are the same BMP,
8514         # or if one is not a BMP, the other is also not a BMP or is
8515         # the BMP at end of the arc (and it only has 1 incoming arc).
8516         # Or both can be BMPs with no incoming arcs.
8517         if {$a eq $b || $arcnos($a) eq {}} {
8518             return 0
8519         }
8520         # assert {[llength $arcnos($a)] == 1}
8521         set arc [lindex $arcnos($a) 0]
8522         set i [lsearch -exact $arcids($arc) $a]
8523         set j [lsearch -exact $arcids($arc) $b]
8524         if {$i < 0 || $i > $j} {
8525             return 1
8526         } else {
8527             return -1
8528         }
8529     }
8531     if {![info exists arcout($a)]} {
8532         set arc [lindex $arcnos($a) 0]
8533         if {[info exists arcend($arc)]} {
8534             set aend $arcend($arc)
8535         } else {
8536             set aend {}
8537         }
8538         set a $arcstart($arc)
8539     } else {
8540         set aend $a
8541     }
8542     if {![info exists arcout($b)]} {
8543         set arc [lindex $arcnos($b) 0]
8544         if {[info exists arcend($arc)]} {
8545             set bend $arcend($arc)
8546         } else {
8547             set bend {}
8548         }
8549         set b $arcstart($arc)
8550     } else {
8551         set bend $b
8552     }
8553     if {$a eq $bend} {
8554         return 1
8555     }
8556     if {$b eq $aend} {
8557         return -1
8558     }
8559     if {[info exists cached_isanc($a,$bend)]} {
8560         if {$cached_isanc($a,$bend)} {
8561             return 1
8562         }
8563     }
8564     if {[info exists cached_isanc($b,$aend)]} {
8565         if {$cached_isanc($b,$aend)} {
8566             return -1
8567         }
8568         if {[info exists cached_isanc($a,$bend)]} {
8569             return 0
8570         }
8571     }
8573     set todo [list $a $b]
8574     set anc($a) a
8575     set anc($b) b
8576     for {set i 0} {$i < [llength $todo]} {incr i} {
8577         set x [lindex $todo $i]
8578         if {$anc($x) eq {}} {
8579             continue
8580         }
8581         foreach arc $arcnos($x) {
8582             set xd $arcstart($arc)
8583             if {$xd eq $bend} {
8584                 set cached_isanc($a,$bend) 1
8585                 set cached_isanc($b,$aend) 0
8586                 return 1
8587             } elseif {$xd eq $aend} {
8588                 set cached_isanc($b,$aend) 1
8589                 set cached_isanc($a,$bend) 0
8590                 return -1
8591             }
8592             if {![info exists anc($xd)]} {
8593                 set anc($xd) $anc($x)
8594                 lappend todo $xd
8595             } elseif {$anc($xd) ne $anc($x)} {
8596                 set anc($xd) {}
8597             }
8598         }
8599     }
8600     set cached_isanc($a,$bend) 0
8601     set cached_isanc($b,$aend) 0
8602     return 0
8605 # This identifies whether $desc has an ancestor that is
8606 # a growing tip of the graph and which is not an ancestor of $anc
8607 # and returns 0 if so and 1 if not.
8608 # If we subsequently discover a tag on such a growing tip, and that
8609 # turns out to be a descendent of $anc (which it could, since we
8610 # don't necessarily see children before parents), then $desc
8611 # isn't a good choice to display as a descendent tag of
8612 # $anc (since it is the descendent of another tag which is
8613 # a descendent of $anc).  Similarly, $anc isn't a good choice to
8614 # display as a ancestor tag of $desc.
8616 proc is_certain {desc anc} {
8617     global arcnos arcout arcstart arcend growing problems
8619     set certain {}
8620     if {[llength $arcnos($anc)] == 1} {
8621         # tags on the same arc are certain
8622         if {$arcnos($desc) eq $arcnos($anc)} {
8623             return 1
8624         }
8625         if {![info exists arcout($anc)]} {
8626             # if $anc is partway along an arc, use the start of the arc instead
8627             set a [lindex $arcnos($anc) 0]
8628             set anc $arcstart($a)
8629         }
8630     }
8631     if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8632         set x $desc
8633     } else {
8634         set a [lindex $arcnos($desc) 0]
8635         set x $arcend($a)
8636     }
8637     if {$x == $anc} {
8638         return 1
8639     }
8640     set anclist [list $x]
8641     set dl($x) 1
8642     set nnh 1
8643     set ngrowanc 0
8644     for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8645         set x [lindex $anclist $i]
8646         if {$dl($x)} {
8647             incr nnh -1
8648         }
8649         set done($x) 1
8650         foreach a $arcout($x) {
8651             if {[info exists growing($a)]} {
8652                 if {![info exists growanc($x)] && $dl($x)} {
8653                     set growanc($x) 1
8654                     incr ngrowanc
8655                 }
8656             } else {
8657                 set y $arcend($a)
8658                 if {[info exists dl($y)]} {
8659                     if {$dl($y)} {
8660                         if {!$dl($x)} {
8661                             set dl($y) 0
8662                             if {![info exists done($y)]} {
8663                                 incr nnh -1
8664                             }
8665                             if {[info exists growanc($x)]} {
8666                                 incr ngrowanc -1
8667                             }
8668                             set xl [list $y]
8669                             for {set k 0} {$k < [llength $xl]} {incr k} {
8670                                 set z [lindex $xl $k]
8671                                 foreach c $arcout($z) {
8672                                     if {[info exists arcend($c)]} {
8673                                         set v $arcend($c)
8674                                         if {[info exists dl($v)] && $dl($v)} {
8675                                             set dl($v) 0
8676                                             if {![info exists done($v)]} {
8677                                                 incr nnh -1
8678                                             }
8679                                             if {[info exists growanc($v)]} {
8680                                                 incr ngrowanc -1
8681                                             }
8682                                             lappend xl $v
8683                                         }
8684                                     }
8685                                 }
8686                             }
8687                         }
8688                     }
8689                 } elseif {$y eq $anc || !$dl($x)} {
8690                     set dl($y) 0
8691                     lappend anclist $y
8692                 } else {
8693                     set dl($y) 1
8694                     lappend anclist $y
8695                     incr nnh
8696                 }
8697             }
8698         }
8699     }
8700     foreach x [array names growanc] {
8701         if {$dl($x)} {
8702             return 0
8703         }
8704         return 0
8705     }
8706     return 1
8709 proc validate_arctags {a} {
8710     global arctags idtags
8712     set i -1
8713     set na $arctags($a)
8714     foreach id $arctags($a) {
8715         incr i
8716         if {![info exists idtags($id)]} {
8717             set na [lreplace $na $i $i]
8718             incr i -1
8719         }
8720     }
8721     set arctags($a) $na
8724 proc validate_archeads {a} {
8725     global archeads idheads
8727     set i -1
8728     set na $archeads($a)
8729     foreach id $archeads($a) {
8730         incr i
8731         if {![info exists idheads($id)]} {
8732             set na [lreplace $na $i $i]
8733             incr i -1
8734         }
8735     }
8736     set archeads($a) $na
8739 # Return the list of IDs that have tags that are descendents of id,
8740 # ignoring IDs that are descendents of IDs already reported.
8741 proc desctags {id} {
8742     global arcnos arcstart arcids arctags idtags allparents
8743     global growing cached_dtags
8745     if {![info exists allparents($id)]} {
8746         return {}
8747     }
8748     set t1 [clock clicks -milliseconds]
8749     set argid $id
8750     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8751         # part-way along an arc; check that arc first
8752         set a [lindex $arcnos($id) 0]
8753         if {$arctags($a) ne {}} {
8754             validate_arctags $a
8755             set i [lsearch -exact $arcids($a) $id]
8756             set tid {}
8757             foreach t $arctags($a) {
8758                 set j [lsearch -exact $arcids($a) $t]
8759                 if {$j >= $i} break
8760                 set tid $t
8761             }
8762             if {$tid ne {}} {
8763                 return $tid
8764             }
8765         }
8766         set id $arcstart($a)
8767         if {[info exists idtags($id)]} {
8768             return $id
8769         }
8770     }
8771     if {[info exists cached_dtags($id)]} {
8772         return $cached_dtags($id)
8773     }
8775     set origid $id
8776     set todo [list $id]
8777     set queued($id) 1
8778     set nc 1
8779     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8780         set id [lindex $todo $i]
8781         set done($id) 1
8782         set ta [info exists hastaggedancestor($id)]
8783         if {!$ta} {
8784             incr nc -1
8785         }
8786         # ignore tags on starting node
8787         if {!$ta && $i > 0} {
8788             if {[info exists idtags($id)]} {
8789                 set tagloc($id) $id
8790                 set ta 1
8791             } elseif {[info exists cached_dtags($id)]} {
8792                 set tagloc($id) $cached_dtags($id)
8793                 set ta 1
8794             }
8795         }
8796         foreach a $arcnos($id) {
8797             set d $arcstart($a)
8798             if {!$ta && $arctags($a) ne {}} {
8799                 validate_arctags $a
8800                 if {$arctags($a) ne {}} {
8801                     lappend tagloc($id) [lindex $arctags($a) end]
8802                 }
8803             }
8804             if {$ta || $arctags($a) ne {}} {
8805                 set tomark [list $d]
8806                 for {set j 0} {$j < [llength $tomark]} {incr j} {
8807                     set dd [lindex $tomark $j]
8808                     if {![info exists hastaggedancestor($dd)]} {
8809                         if {[info exists done($dd)]} {
8810                             foreach b $arcnos($dd) {
8811                                 lappend tomark $arcstart($b)
8812                             }
8813                             if {[info exists tagloc($dd)]} {
8814                                 unset tagloc($dd)
8815                             }
8816                         } elseif {[info exists queued($dd)]} {
8817                             incr nc -1
8818                         }
8819                         set hastaggedancestor($dd) 1
8820                     }
8821                 }
8822             }
8823             if {![info exists queued($d)]} {
8824                 lappend todo $d
8825                 set queued($d) 1
8826                 if {![info exists hastaggedancestor($d)]} {
8827                     incr nc
8828                 }
8829             }
8830         }
8831     }
8832     set tags {}
8833     foreach id [array names tagloc] {
8834         if {![info exists hastaggedancestor($id)]} {
8835             foreach t $tagloc($id) {
8836                 if {[lsearch -exact $tags $t] < 0} {
8837                     lappend tags $t
8838                 }
8839             }
8840         }
8841     }
8842     set t2 [clock clicks -milliseconds]
8843     set loopix $i
8845     # remove tags that are descendents of other tags
8846     for {set i 0} {$i < [llength $tags]} {incr i} {
8847         set a [lindex $tags $i]
8848         for {set j 0} {$j < $i} {incr j} {
8849             set b [lindex $tags $j]
8850             set r [anc_or_desc $a $b]
8851             if {$r == 1} {
8852                 set tags [lreplace $tags $j $j]
8853                 incr j -1
8854                 incr i -1
8855             } elseif {$r == -1} {
8856                 set tags [lreplace $tags $i $i]
8857                 incr i -1
8858                 break
8859             }
8860         }
8861     }
8863     if {[array names growing] ne {}} {
8864         # graph isn't finished, need to check if any tag could get
8865         # eclipsed by another tag coming later.  Simply ignore any
8866         # tags that could later get eclipsed.
8867         set ctags {}
8868         foreach t $tags {
8869             if {[is_certain $t $origid]} {
8870                 lappend ctags $t
8871             }
8872         }
8873         if {$tags eq $ctags} {
8874             set cached_dtags($origid) $tags
8875         } else {
8876             set tags $ctags
8877         }
8878     } else {
8879         set cached_dtags($origid) $tags
8880     }
8881     set t3 [clock clicks -milliseconds]
8882     if {0 && $t3 - $t1 >= 100} {
8883         puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8884             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8885     }
8886     return $tags
8889 proc anctags {id} {
8890     global arcnos arcids arcout arcend arctags idtags allparents
8891     global growing cached_atags
8893     if {![info exists allparents($id)]} {
8894         return {}
8895     }
8896     set t1 [clock clicks -milliseconds]
8897     set argid $id
8898     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8899         # part-way along an arc; check that arc first
8900         set a [lindex $arcnos($id) 0]
8901         if {$arctags($a) ne {}} {
8902             validate_arctags $a
8903             set i [lsearch -exact $arcids($a) $id]
8904             foreach t $arctags($a) {
8905                 set j [lsearch -exact $arcids($a) $t]
8906                 if {$j > $i} {
8907                     return $t
8908                 }
8909             }
8910         }
8911         if {![info exists arcend($a)]} {
8912             return {}
8913         }
8914         set id $arcend($a)
8915         if {[info exists idtags($id)]} {
8916             return $id
8917         }
8918     }
8919     if {[info exists cached_atags($id)]} {
8920         return $cached_atags($id)
8921     }
8923     set origid $id
8924     set todo [list $id]
8925     set queued($id) 1
8926     set taglist {}
8927     set nc 1
8928     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8929         set id [lindex $todo $i]
8930         set done($id) 1
8931         set td [info exists hastaggeddescendent($id)]
8932         if {!$td} {
8933             incr nc -1
8934         }
8935         # ignore tags on starting node
8936         if {!$td && $i > 0} {
8937             if {[info exists idtags($id)]} {
8938                 set tagloc($id) $id
8939                 set td 1
8940             } elseif {[info exists cached_atags($id)]} {
8941                 set tagloc($id) $cached_atags($id)
8942                 set td 1
8943             }
8944         }
8945         foreach a $arcout($id) {
8946             if {!$td && $arctags($a) ne {}} {
8947                 validate_arctags $a
8948                 if {$arctags($a) ne {}} {
8949                     lappend tagloc($id) [lindex $arctags($a) 0]
8950                 }
8951             }
8952             if {![info exists arcend($a)]} continue
8953             set d $arcend($a)
8954             if {$td || $arctags($a) ne {}} {
8955                 set tomark [list $d]
8956                 for {set j 0} {$j < [llength $tomark]} {incr j} {
8957                     set dd [lindex $tomark $j]
8958                     if {![info exists hastaggeddescendent($dd)]} {
8959                         if {[info exists done($dd)]} {
8960                             foreach b $arcout($dd) {
8961                                 if {[info exists arcend($b)]} {
8962                                     lappend tomark $arcend($b)
8963                                 }
8964                             }
8965                             if {[info exists tagloc($dd)]} {
8966                                 unset tagloc($dd)
8967                             }
8968                         } elseif {[info exists queued($dd)]} {
8969                             incr nc -1
8970                         }
8971                         set hastaggeddescendent($dd) 1
8972                     }
8973                 }
8974             }
8975             if {![info exists queued($d)]} {
8976                 lappend todo $d
8977                 set queued($d) 1
8978                 if {![info exists hastaggeddescendent($d)]} {
8979                     incr nc
8980                 }
8981             }
8982         }
8983     }
8984     set t2 [clock clicks -milliseconds]
8985     set loopix $i
8986     set tags {}
8987     foreach id [array names tagloc] {
8988         if {![info exists hastaggeddescendent($id)]} {
8989             foreach t $tagloc($id) {
8990                 if {[lsearch -exact $tags $t] < 0} {
8991                     lappend tags $t
8992                 }
8993             }
8994         }
8995     }
8997     # remove tags that are ancestors of other tags
8998     for {set i 0} {$i < [llength $tags]} {incr i} {
8999         set a [lindex $tags $i]
9000         for {set j 0} {$j < $i} {incr j} {
9001             set b [lindex $tags $j]
9002             set r [anc_or_desc $a $b]
9003             if {$r == -1} {
9004                 set tags [lreplace $tags $j $j]
9005                 incr j -1
9006                 incr i -1
9007             } elseif {$r == 1} {
9008                 set tags [lreplace $tags $i $i]
9009                 incr i -1
9010                 break
9011             }
9012         }
9013     }
9015     if {[array names growing] ne {}} {
9016         # graph isn't finished, need to check if any tag could get
9017         # eclipsed by another tag coming later.  Simply ignore any
9018         # tags that could later get eclipsed.
9019         set ctags {}
9020         foreach t $tags {
9021             if {[is_certain $origid $t]} {
9022                 lappend ctags $t
9023             }
9024         }
9025         if {$tags eq $ctags} {
9026             set cached_atags($origid) $tags
9027         } else {
9028             set tags $ctags
9029         }
9030     } else {
9031         set cached_atags($origid) $tags
9032     }
9033     set t3 [clock clicks -milliseconds]
9034     if {0 && $t3 - $t1 >= 100} {
9035         puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9036             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9037     }
9038     return $tags
9041 # Return the list of IDs that have heads that are descendents of id,
9042 # including id itself if it has a head.
9043 proc descheads {id} {
9044     global arcnos arcstart arcids archeads idheads cached_dheads
9045     global allparents
9047     if {![info exists allparents($id)]} {
9048         return {}
9049     }
9050     set aret {}
9051     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9052         # part-way along an arc; check it first
9053         set a [lindex $arcnos($id) 0]
9054         if {$archeads($a) ne {}} {
9055             validate_archeads $a
9056             set i [lsearch -exact $arcids($a) $id]
9057             foreach t $archeads($a) {
9058                 set j [lsearch -exact $arcids($a) $t]
9059                 if {$j > $i} break
9060                 lappend aret $t
9061             }
9062         }
9063         set id $arcstart($a)
9064     }
9065     set origid $id
9066     set todo [list $id]
9067     set seen($id) 1
9068     set ret {}
9069     for {set i 0} {$i < [llength $todo]} {incr i} {
9070         set id [lindex $todo $i]
9071         if {[info exists cached_dheads($id)]} {
9072             set ret [concat $ret $cached_dheads($id)]
9073         } else {
9074             if {[info exists idheads($id)]} {
9075                 lappend ret $id
9076             }
9077             foreach a $arcnos($id) {
9078                 if {$archeads($a) ne {}} {
9079                     validate_archeads $a
9080                     if {$archeads($a) ne {}} {
9081                         set ret [concat $ret $archeads($a)]
9082                     }
9083                 }
9084                 set d $arcstart($a)
9085                 if {![info exists seen($d)]} {
9086                     lappend todo $d
9087                     set seen($d) 1
9088                 }
9089             }
9090         }
9091     }
9092     set ret [lsort -unique $ret]
9093     set cached_dheads($origid) $ret
9094     return [concat $ret $aret]
9097 proc addedtag {id} {
9098     global arcnos arcout cached_dtags cached_atags
9100     if {![info exists arcnos($id)]} return
9101     if {![info exists arcout($id)]} {
9102         recalcarc [lindex $arcnos($id) 0]
9103     }
9104     catch {unset cached_dtags}
9105     catch {unset cached_atags}
9108 proc addedhead {hid head} {
9109     global arcnos arcout cached_dheads
9111     if {![info exists arcnos($hid)]} return
9112     if {![info exists arcout($hid)]} {
9113         recalcarc [lindex $arcnos($hid) 0]
9114     }
9115     catch {unset cached_dheads}
9118 proc removedhead {hid head} {
9119     global cached_dheads
9121     catch {unset cached_dheads}
9124 proc movedhead {hid head} {
9125     global arcnos arcout cached_dheads
9127     if {![info exists arcnos($hid)]} return
9128     if {![info exists arcout($hid)]} {
9129         recalcarc [lindex $arcnos($hid) 0]
9130     }
9131     catch {unset cached_dheads}
9134 proc changedrefs {} {
9135     global cached_dheads cached_dtags cached_atags
9136     global arctags archeads arcnos arcout idheads idtags
9138     foreach id [concat [array names idheads] [array names idtags]] {
9139         if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9140             set a [lindex $arcnos($id) 0]
9141             if {![info exists donearc($a)]} {
9142                 recalcarc $a
9143                 set donearc($a) 1
9144             }
9145         }
9146     }
9147     catch {unset cached_dtags}
9148     catch {unset cached_atags}
9149     catch {unset cached_dheads}
9152 proc rereadrefs {} {
9153     global idtags idheads idotherrefs mainheadid
9155     set refids [concat [array names idtags] \
9156                     [array names idheads] [array names idotherrefs]]
9157     foreach id $refids {
9158         if {![info exists ref($id)]} {
9159             set ref($id) [listrefs $id]
9160         }
9161     }
9162     set oldmainhead $mainheadid
9163     readrefs
9164     changedrefs
9165     set refids [lsort -unique [concat $refids [array names idtags] \
9166                         [array names idheads] [array names idotherrefs]]]
9167     foreach id $refids {
9168         set v [listrefs $id]
9169         if {![info exists ref($id)] || $ref($id) != $v} {
9170             redrawtags $id
9171         }
9172     }
9173     if {$oldmainhead ne $mainheadid} {
9174         redrawtags $oldmainhead
9175         redrawtags $mainheadid
9176     }
9177     run refill_reflist
9180 proc listrefs {id} {
9181     global idtags idheads idotherrefs
9183     set x {}
9184     if {[info exists idtags($id)]} {
9185         set x $idtags($id)
9186     }
9187     set y {}
9188     if {[info exists idheads($id)]} {
9189         set y $idheads($id)
9190     }
9191     set z {}
9192     if {[info exists idotherrefs($id)]} {
9193         set z $idotherrefs($id)
9194     }
9195     return [list $x $y $z]
9198 proc showtag {tag isnew} {
9199     global ctext tagcontents tagids linknum tagobjid
9201     if {$isnew} {
9202         addtohistory [list showtag $tag 0]
9203     }
9204     $ctext conf -state normal
9205     clear_ctext
9206     settabs 0
9207     set linknum 0
9208     if {![info exists tagcontents($tag)]} {
9209         catch {
9210             set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9211         }
9212     }
9213     if {[info exists tagcontents($tag)]} {
9214         set text $tagcontents($tag)
9215     } else {
9216         set text "[mc "Tag"]: $tag\n[mc "Id"]:  $tagids($tag)"
9217     }
9218     appendwithlinks $text {}
9219     $ctext conf -state disabled
9220     init_flist {}
9223 proc doquit {} {
9224     global stopped
9225     global gitktmpdir
9227     set stopped 100
9228     savestuff .
9229     destroy .
9231     if {[info exists gitktmpdir]} {
9232         catch {file delete -force $gitktmpdir}
9233     }
9236 proc mkfontdisp {font top which} {
9237     global fontattr fontpref $font
9239     set fontpref($font) [set $font]
9240     button $top.${font}but -text $which -font optionfont \
9241         -command [list choosefont $font $which]
9242     label $top.$font -relief flat -font $font \
9243         -text $fontattr($font,family) -justify left
9244     grid x $top.${font}but $top.$font -sticky w
9247 proc choosefont {font which} {
9248     global fontparam fontlist fonttop fontattr
9250     set fontparam(which) $which
9251     set fontparam(font) $font
9252     set fontparam(family) [font actual $font -family]
9253     set fontparam(size) $fontattr($font,size)
9254     set fontparam(weight) $fontattr($font,weight)
9255     set fontparam(slant) $fontattr($font,slant)
9256     set top .gitkfont
9257     set fonttop $top
9258     if {![winfo exists $top]} {
9259         font create sample
9260         eval font config sample [font actual $font]
9261         toplevel $top
9262         wm title $top [mc "Gitk font chooser"]
9263         label $top.l -textvariable fontparam(which)
9264         pack $top.l -side top
9265         set fontlist [lsort [font families]]
9266         frame $top.f
9267         listbox $top.f.fam -listvariable fontlist \
9268             -yscrollcommand [list $top.f.sb set]
9269         bind $top.f.fam <<ListboxSelect>> selfontfam
9270         scrollbar $top.f.sb -command [list $top.f.fam yview]
9271         pack $top.f.sb -side right -fill y
9272         pack $top.f.fam -side left -fill both -expand 1
9273         pack $top.f -side top -fill both -expand 1
9274         frame $top.g
9275         spinbox $top.g.size -from 4 -to 40 -width 4 \
9276             -textvariable fontparam(size) \
9277             -validatecommand {string is integer -strict %s}
9278         checkbutton $top.g.bold -padx 5 \
9279             -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9280             -variable fontparam(weight) -onvalue bold -offvalue normal
9281         checkbutton $top.g.ital -padx 5 \
9282             -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0  \
9283             -variable fontparam(slant) -onvalue italic -offvalue roman
9284         pack $top.g.size $top.g.bold $top.g.ital -side left
9285         pack $top.g -side top
9286         canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9287             -background white
9288         $top.c create text 100 25 -anchor center -text $which -font sample \
9289             -fill black -tags text
9290         bind $top.c <Configure> [list centertext $top.c]
9291         pack $top.c -side top -fill x
9292         frame $top.buts
9293         button $top.buts.ok -text [mc "OK"] -command fontok -default active
9294         button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9295         grid $top.buts.ok $top.buts.can
9296         grid columnconfigure $top.buts 0 -weight 1 -uniform a
9297         grid columnconfigure $top.buts 1 -weight 1 -uniform a
9298         pack $top.buts -side bottom -fill x
9299         trace add variable fontparam write chg_fontparam
9300     } else {
9301         raise $top
9302         $top.c itemconf text -text $which
9303     }
9304     set i [lsearch -exact $fontlist $fontparam(family)]
9305     if {$i >= 0} {
9306         $top.f.fam selection set $i
9307         $top.f.fam see $i
9308     }
9311 proc centertext {w} {
9312     $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9315 proc fontok {} {
9316     global fontparam fontpref prefstop
9318     set f $fontparam(font)
9319     set fontpref($f) [list $fontparam(family) $fontparam(size)]
9320     if {$fontparam(weight) eq "bold"} {
9321         lappend fontpref($f) "bold"
9322     }
9323     if {$fontparam(slant) eq "italic"} {
9324         lappend fontpref($f) "italic"
9325     }
9326     set w $prefstop.$f
9327     $w conf -text $fontparam(family) -font $fontpref($f)
9328         
9329     fontcan
9332 proc fontcan {} {
9333     global fonttop fontparam
9335     if {[info exists fonttop]} {
9336         catch {destroy $fonttop}
9337         catch {font delete sample}
9338         unset fonttop
9339         unset fontparam
9340     }
9343 proc selfontfam {} {
9344     global fonttop fontparam
9346     set i [$fonttop.f.fam curselection]
9347     if {$i ne {}} {
9348         set fontparam(family) [$fonttop.f.fam get $i]
9349     }
9352 proc chg_fontparam {v sub op} {
9353     global fontparam
9355     font config sample -$sub $fontparam($sub)
9358 proc doprefs {} {
9359     global maxwidth maxgraphpct
9360     global oldprefs prefstop showneartags showlocalchanges
9361     global bgcolor fgcolor ctext diffcolors selectbgcolor
9362     global tabstop limitdiffs autoselect extdifftool perfile_attrs
9364     set top .gitkprefs
9365     set prefstop $top
9366     if {[winfo exists $top]} {
9367         raise $top
9368         return
9369     }
9370     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9371                    limitdiffs tabstop perfile_attrs} {
9372         set oldprefs($v) [set $v]
9373     }
9374     toplevel $top
9375     wm title $top [mc "Gitk preferences"]
9376     label $top.ldisp -text [mc "Commit list display options"]
9377     grid $top.ldisp - -sticky w -pady 10
9378     label $top.spacer -text " "
9379     label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9380         -font optionfont
9381     spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9382     grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9383     label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9384         -font optionfont
9385     spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9386     grid x $top.maxpctl $top.maxpct -sticky w
9387     frame $top.showlocal
9388     label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9389     checkbutton $top.showlocal.b -variable showlocalchanges
9390     pack $top.showlocal.b $top.showlocal.l -side left
9391     grid x $top.showlocal -sticky w
9392     frame $top.autoselect
9393     label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9394     checkbutton $top.autoselect.b -variable autoselect
9395     pack $top.autoselect.b $top.autoselect.l -side left
9396     grid x $top.autoselect -sticky w
9398     label $top.ddisp -text [mc "Diff display options"]
9399     grid $top.ddisp - -sticky w -pady 10
9400     label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9401     spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9402     grid x $top.tabstopl $top.tabstop -sticky w
9403     frame $top.ntag
9404     label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9405     checkbutton $top.ntag.b -variable showneartags
9406     pack $top.ntag.b $top.ntag.l -side left
9407     grid x $top.ntag -sticky w
9408     frame $top.ldiff
9409     label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9410     checkbutton $top.ldiff.b -variable limitdiffs
9411     pack $top.ldiff.b $top.ldiff.l -side left
9412     grid x $top.ldiff -sticky w
9413     frame $top.lattr
9414     label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
9415     checkbutton $top.lattr.b -variable perfile_attrs
9416     pack $top.lattr.b $top.lattr.l -side left
9417     grid x $top.lattr -sticky w
9419     entry $top.extdifft -textvariable extdifftool
9420     frame $top.extdifff
9421     label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9422         -padx 10
9423     button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9424         -command choose_extdiff
9425     pack $top.extdifff.l $top.extdifff.b -side left
9426     grid x $top.extdifff $top.extdifft -sticky w
9428     label $top.cdisp -text [mc "Colors: press to choose"]
9429     grid $top.cdisp - -sticky w -pady 10
9430     label $top.bg -padx 40 -relief sunk -background $bgcolor
9431     button $top.bgbut -text [mc "Background"] -font optionfont \
9432         -command [list choosecolor bgcolor {} $top.bg background setbg]
9433     grid x $top.bgbut $top.bg -sticky w
9434     label $top.fg -padx 40 -relief sunk -background $fgcolor
9435     button $top.fgbut -text [mc "Foreground"] -font optionfont \
9436         -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9437     grid x $top.fgbut $top.fg -sticky w
9438     label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9439     button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9440         -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9441                       [list $ctext tag conf d0 -foreground]]
9442     grid x $top.diffoldbut $top.diffold -sticky w
9443     label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9444     button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9445         -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9446                       [list $ctext tag conf d1 -foreground]]
9447     grid x $top.diffnewbut $top.diffnew -sticky w
9448     label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9449     button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9450         -command [list choosecolor diffcolors 2 $top.hunksep \
9451                       "diff hunk header" \
9452                       [list $ctext tag conf hunksep -foreground]]
9453     grid x $top.hunksepbut $top.hunksep -sticky w
9454     label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9455     button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9456         -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9457     grid x $top.selbgbut $top.selbgsep -sticky w
9459     label $top.cfont -text [mc "Fonts: press to choose"]
9460     grid $top.cfont - -sticky w -pady 10
9461     mkfontdisp mainfont $top [mc "Main font"]
9462     mkfontdisp textfont $top [mc "Diff display font"]
9463     mkfontdisp uifont $top [mc "User interface font"]
9465     frame $top.buts
9466     button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9467     button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9468     grid $top.buts.ok $top.buts.can
9469     grid columnconfigure $top.buts 0 -weight 1 -uniform a
9470     grid columnconfigure $top.buts 1 -weight 1 -uniform a
9471     grid $top.buts - - -pady 10 -sticky ew
9472     bind $top <Visibility> "focus $top.buts.ok"
9475 proc choose_extdiff {} {
9476     global extdifftool
9478     set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9479     if {$prog ne {}} {
9480         set extdifftool $prog
9481     }
9484 proc choosecolor {v vi w x cmd} {
9485     global $v
9487     set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9488                -title [mc "Gitk: choose color for %s" $x]]
9489     if {$c eq {}} return
9490     $w conf -background $c
9491     lset $v $vi $c
9492     eval $cmd $c
9495 proc setselbg {c} {
9496     global bglist cflist
9497     foreach w $bglist {
9498         $w configure -selectbackground $c
9499     }
9500     $cflist tag configure highlight \
9501         -background [$cflist cget -selectbackground]
9502     allcanvs itemconf secsel -fill $c
9505 proc setbg {c} {
9506     global bglist
9508     foreach w $bglist {
9509         $w conf -background $c
9510     }
9513 proc setfg {c} {
9514     global fglist canv
9516     foreach w $fglist {
9517         $w conf -foreground $c
9518     }
9519     allcanvs itemconf text -fill $c
9520     $canv itemconf circle -outline $c
9523 proc prefscan {} {
9524     global oldprefs prefstop
9526     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9527                    limitdiffs tabstop perfile_attrs} {
9528         global $v
9529         set $v $oldprefs($v)
9530     }
9531     catch {destroy $prefstop}
9532     unset prefstop
9533     fontcan
9536 proc prefsok {} {
9537     global maxwidth maxgraphpct
9538     global oldprefs prefstop showneartags showlocalchanges
9539     global fontpref mainfont textfont uifont
9540     global limitdiffs treediffs perfile_attrs
9542     catch {destroy $prefstop}
9543     unset prefstop
9544     fontcan
9545     set fontchanged 0
9546     if {$mainfont ne $fontpref(mainfont)} {
9547         set mainfont $fontpref(mainfont)
9548         parsefont mainfont $mainfont
9549         eval font configure mainfont [fontflags mainfont]
9550         eval font configure mainfontbold [fontflags mainfont 1]
9551         setcoords
9552         set fontchanged 1
9553     }
9554     if {$textfont ne $fontpref(textfont)} {
9555         set textfont $fontpref(textfont)
9556         parsefont textfont $textfont
9557         eval font configure textfont [fontflags textfont]
9558         eval font configure textfontbold [fontflags textfont 1]
9559     }
9560     if {$uifont ne $fontpref(uifont)} {
9561         set uifont $fontpref(uifont)
9562         parsefont uifont $uifont
9563         eval font configure uifont [fontflags uifont]
9564     }
9565     settabs
9566     if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9567         if {$showlocalchanges} {
9568             doshowlocalchanges
9569         } else {
9570             dohidelocalchanges
9571         }
9572     }
9573     if {$limitdiffs != $oldprefs(limitdiffs) ||
9574         ($perfile_attrs && !$oldprefs(perfile_attrs))} {
9575         # treediffs elements are limited by path;
9576         # won't have encodings cached if perfile_attrs was just turned on
9577         catch {unset treediffs}
9578     }
9579     if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9580         || $maxgraphpct != $oldprefs(maxgraphpct)} {
9581         redisplay
9582     } elseif {$showneartags != $oldprefs(showneartags) ||
9583           $limitdiffs != $oldprefs(limitdiffs)} {
9584         reselectline
9585     }
9588 proc formatdate {d} {
9589     global datetimeformat
9590     if {$d ne {}} {
9591         set d [clock format $d -format $datetimeformat]
9592     }
9593     return $d
9596 # This list of encoding names and aliases is distilled from
9597 # http://www.iana.org/assignments/character-sets.
9598 # Not all of them are supported by Tcl.
9599 set encoding_aliases {
9600     { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9601       ISO646-US US-ASCII us IBM367 cp367 csASCII }
9602     { ISO-10646-UTF-1 csISO10646UTF1 }
9603     { ISO_646.basic:1983 ref csISO646basic1983 }
9604     { INVARIANT csINVARIANT }
9605     { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9606     { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9607     { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9608     { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9609     { NATS-DANO iso-ir-9-1 csNATSDANO }
9610     { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9611     { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9612     { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9613     { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9614     { ISO-2022-KR csISO2022KR }
9615     { EUC-KR csEUCKR }
9616     { ISO-2022-JP csISO2022JP }
9617     { ISO-2022-JP-2 csISO2022JP2 }
9618     { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9619       csISO13JISC6220jp }
9620     { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9621     { IT iso-ir-15 ISO646-IT csISO15Italian }
9622     { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9623     { ES iso-ir-17 ISO646-ES csISO17Spanish }
9624     { greek7-old iso-ir-18 csISO18Greek7Old }
9625     { latin-greek iso-ir-19 csISO19LatinGreek }
9626     { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9627     { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9628     { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9629     { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9630     { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9631     { BS_viewdata iso-ir-47 csISO47BSViewdata }
9632     { INIS iso-ir-49 csISO49INIS }
9633     { INIS-8 iso-ir-50 csISO50INIS8 }
9634     { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9635     { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9636     { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9637     { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9638     { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9639     { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9640       csISO60Norwegian1 }
9641     { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9642     { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9643     { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9644     { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9645     { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9646     { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9647     { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9648     { greek7 iso-ir-88 csISO88Greek7 }
9649     { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9650     { iso-ir-90 csISO90 }
9651     { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9652     { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9653       csISO92JISC62991984b }
9654     { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9655     { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9656     { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9657       csISO95JIS62291984handadd }
9658     { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9659     { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9660     { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9661     { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9662       CP819 csISOLatin1 }
9663     { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9664     { T.61-7bit iso-ir-102 csISO102T617bit }
9665     { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9666     { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9667     { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9668     { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9669     { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9670     { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9671     { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9672     { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9673       arabic csISOLatinArabic }
9674     { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9675     { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9676     { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9677       greek greek8 csISOLatinGreek }
9678     { T.101-G2 iso-ir-128 csISO128T101G2 }
9679     { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9680       csISOLatinHebrew }
9681     { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9682     { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9683     { CSN_369103 iso-ir-139 csISO139CSN369103 }
9684     { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9685     { ISO_6937-2-add iso-ir-142 csISOTextComm }
9686     { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9687     { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9688       csISOLatinCyrillic }
9689     { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9690     { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9691     { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9692     { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9693     { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9694     { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9695     { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9696     { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9697     { ISO_10367-box iso-ir-155 csISO10367Box }
9698     { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9699     { latin-lap lap iso-ir-158 csISO158Lap }
9700     { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9701     { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9702     { us-dk csUSDK }
9703     { dk-us csDKUS }
9704     { JIS_X0201 X0201 csHalfWidthKatakana }
9705     { KSC5636 ISO646-KR csKSC5636 }
9706     { ISO-10646-UCS-2 csUnicode }
9707     { ISO-10646-UCS-4 csUCS4 }
9708     { DEC-MCS dec csDECMCS }
9709     { hp-roman8 roman8 r8 csHPRoman8 }
9710     { macintosh mac csMacintosh }
9711     { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9712       csIBM037 }
9713     { IBM038 EBCDIC-INT cp038 csIBM038 }
9714     { IBM273 CP273 csIBM273 }
9715     { IBM274 EBCDIC-BE CP274 csIBM274 }
9716     { IBM275 EBCDIC-BR cp275 csIBM275 }
9717     { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9718     { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9719     { IBM280 CP280 ebcdic-cp-it csIBM280 }
9720     { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9721     { IBM284 CP284 ebcdic-cp-es csIBM284 }
9722     { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9723     { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9724     { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9725     { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9726     { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9727     { IBM424 cp424 ebcdic-cp-he csIBM424 }
9728     { IBM437 cp437 437 csPC8CodePage437 }
9729     { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9730     { IBM775 cp775 csPC775Baltic }
9731     { IBM850 cp850 850 csPC850Multilingual }
9732     { IBM851 cp851 851 csIBM851 }
9733     { IBM852 cp852 852 csPCp852 }
9734     { IBM855 cp855 855 csIBM855 }
9735     { IBM857 cp857 857 csIBM857 }
9736     { IBM860 cp860 860 csIBM860 }
9737     { IBM861 cp861 861 cp-is csIBM861 }
9738     { IBM862 cp862 862 csPC862LatinHebrew }
9739     { IBM863 cp863 863 csIBM863 }
9740     { IBM864 cp864 csIBM864 }
9741     { IBM865 cp865 865 csIBM865 }
9742     { IBM866 cp866 866 csIBM866 }
9743     { IBM868 CP868 cp-ar csIBM868 }
9744     { IBM869 cp869 869 cp-gr csIBM869 }
9745     { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9746     { IBM871 CP871 ebcdic-cp-is csIBM871 }
9747     { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9748     { IBM891 cp891 csIBM891 }
9749     { IBM903 cp903 csIBM903 }
9750     { IBM904 cp904 904 csIBBM904 }
9751     { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9752     { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9753     { IBM1026 CP1026 csIBM1026 }
9754     { EBCDIC-AT-DE csIBMEBCDICATDE }
9755     { EBCDIC-AT-DE-A csEBCDICATDEA }
9756     { EBCDIC-CA-FR csEBCDICCAFR }
9757     { EBCDIC-DK-NO csEBCDICDKNO }
9758     { EBCDIC-DK-NO-A csEBCDICDKNOA }
9759     { EBCDIC-FI-SE csEBCDICFISE }
9760     { EBCDIC-FI-SE-A csEBCDICFISEA }
9761     { EBCDIC-FR csEBCDICFR }
9762     { EBCDIC-IT csEBCDICIT }
9763     { EBCDIC-PT csEBCDICPT }
9764     { EBCDIC-ES csEBCDICES }
9765     { EBCDIC-ES-A csEBCDICESA }
9766     { EBCDIC-ES-S csEBCDICESS }
9767     { EBCDIC-UK csEBCDICUK }
9768     { EBCDIC-US csEBCDICUS }
9769     { UNKNOWN-8BIT csUnknown8BiT }
9770     { MNEMONIC csMnemonic }
9771     { MNEM csMnem }
9772     { VISCII csVISCII }
9773     { VIQR csVIQR }
9774     { KOI8-R csKOI8R }
9775     { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9776     { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9777     { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9778     { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9779     { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9780     { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9781     { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9782     { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9783     { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9784     { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9785     { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9786     { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9787     { IBM1047 IBM-1047 }
9788     { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9789     { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9790     { UNICODE-1-1 csUnicode11 }
9791     { CESU-8 csCESU-8 }
9792     { BOCU-1 csBOCU-1 }
9793     { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9794     { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9795       l8 }
9796     { ISO-8859-15 ISO_8859-15 Latin-9 }
9797     { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9798     { GBK CP936 MS936 windows-936 }
9799     { JIS_Encoding csJISEncoding }
9800     { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
9801     { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9802       EUC-JP }
9803     { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9804     { ISO-10646-UCS-Basic csUnicodeASCII }
9805     { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9806     { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9807     { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9808     { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9809     { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9810     { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9811     { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9812     { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9813     { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9814     { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9815     { Adobe-Standard-Encoding csAdobeStandardEncoding }
9816     { Ventura-US csVenturaUS }
9817     { Ventura-International csVenturaInternational }
9818     { PC8-Danish-Norwegian csPC8DanishNorwegian }
9819     { PC8-Turkish csPC8Turkish }
9820     { IBM-Symbols csIBMSymbols }
9821     { IBM-Thai csIBMThai }
9822     { HP-Legal csHPLegal }
9823     { HP-Pi-font csHPPiFont }
9824     { HP-Math8 csHPMath8 }
9825     { Adobe-Symbol-Encoding csHPPSMath }
9826     { HP-DeskTop csHPDesktop }
9827     { Ventura-Math csVenturaMath }
9828     { Microsoft-Publishing csMicrosoftPublishing }
9829     { Windows-31J csWindows31J }
9830     { GB2312 csGB2312 }
9831     { Big5 csBig5 }
9834 proc tcl_encoding {enc} {
9835     global encoding_aliases tcl_encoding_cache
9836     if {[info exists tcl_encoding_cache($enc)]} {
9837         return $tcl_encoding_cache($enc)
9838     }
9839     set names [encoding names]
9840     set lcnames [string tolower $names]
9841     set enc [string tolower $enc]
9842     set i [lsearch -exact $lcnames $enc]
9843     if {$i < 0} {
9844         # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9845         if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
9846             set i [lsearch -exact $lcnames $encx]
9847         }
9848     }
9849     if {$i < 0} {
9850         foreach l $encoding_aliases {
9851             set ll [string tolower $l]
9852             if {[lsearch -exact $ll $enc] < 0} continue
9853             # look through the aliases for one that tcl knows about
9854             foreach e $ll {
9855                 set i [lsearch -exact $lcnames $e]
9856                 if {$i < 0} {
9857                     if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
9858                         set i [lsearch -exact $lcnames $ex]
9859                     }
9860                 }
9861                 if {$i >= 0} break
9862             }
9863             break
9864         }
9865     }
9866     set tclenc {}
9867     if {$i >= 0} {
9868         set tclenc [lindex $names $i]
9869     }
9870     set tcl_encoding_cache($enc) $tclenc
9871     return $tclenc
9874 proc gitattr {path attr default} {
9875     global path_attr_cache
9876     if {[info exists path_attr_cache($attr,$path)]} {
9877         set r $path_attr_cache($attr,$path)
9878     } else {
9879         set r "unspecified"
9880         if {![catch {set line [exec git check-attr $attr -- $path]}]} {
9881             regexp "(.*): encoding: (.*)" $line m f r
9882         }
9883         set path_attr_cache($attr,$path) $r
9884     }
9885     if {$r eq "unspecified"} {
9886         return $default
9887     }
9888     return $r
9891 proc cache_gitattr {attr pathlist} {
9892     global path_attr_cache
9893     set newlist {}
9894     foreach path $pathlist {
9895         if {![info exists path_attr_cache($attr,$path)]} {
9896             lappend newlist $path
9897         }
9898     }
9899     set lim 1000
9900     if {[tk windowingsystem] == "win32"} {
9901         # windows has a 32k limit on the arguments to a command...
9902         set lim 30
9903     }
9904     while {$newlist ne {}} {
9905         set head [lrange $newlist 0 [expr {$lim - 1}]]
9906         set newlist [lrange $newlist $lim end]
9907         if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
9908             foreach row [split $rlist "\n"] {
9909                 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
9910                     if {[string index $path 0] eq "\""} {
9911                         set path [encoding convertfrom [lindex $path 0]]
9912                     }
9913                     set path_attr_cache($attr,$path) $value
9914                 }
9915             }
9916         }
9917     }
9920 proc get_path_encoding {path} {
9921     global gui_encoding perfile_attrs
9922     set tcl_enc $gui_encoding
9923     if {$path ne {} && $perfile_attrs} {
9924         set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
9925         if {$enc2 ne {}} {
9926             set tcl_enc $enc2
9927         }
9928     }
9929     return $tcl_enc
9932 # First check that Tcl/Tk is recent enough
9933 if {[catch {package require Tk 8.4} err]} {
9934     show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9935                      Gitk requires at least Tcl/Tk 8.4."]
9936     exit 1
9939 # defaults...
9940 set wrcomcmd "git diff-tree --stdin -p --pretty"
9942 set gitencoding {}
9943 catch {
9944     set gitencoding [exec git config --get i18n.commitencoding]
9946 if {$gitencoding == ""} {
9947     set gitencoding "utf-8"
9949 set tclencoding [tcl_encoding $gitencoding]
9950 if {$tclencoding == {}} {
9951     puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9954 set gui_encoding [encoding system]
9955 catch {
9956     set enc [exec git config --get gui.encoding]
9957     if {$enc ne {}} {
9958         set tclenc [tcl_encoding $enc]
9959         if {$tclenc ne {}} {
9960             set gui_encoding $tclenc
9961         } else {
9962             puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
9963         }
9964     }
9967 set mainfont {Helvetica 9}
9968 set textfont {Courier 9}
9969 set uifont {Helvetica 9 bold}
9970 set tabstop 8
9971 set findmergefiles 0
9972 set maxgraphpct 50
9973 set maxwidth 16
9974 set revlistorder 0
9975 set fastdate 0
9976 set uparrowlen 5
9977 set downarrowlen 5
9978 set mingaplen 100
9979 set cmitmode "patch"
9980 set wrapcomment "none"
9981 set showneartags 1
9982 set maxrefs 20
9983 set maxlinelen 200
9984 set showlocalchanges 1
9985 set limitdiffs 1
9986 set datetimeformat "%Y-%m-%d %H:%M:%S"
9987 set autoselect 1
9988 set perfile_attrs 0
9990 set extdifftool "meld"
9992 set colors {green red blue magenta darkgrey brown orange}
9993 set bgcolor white
9994 set fgcolor black
9995 set diffcolors {red "#00a000" blue}
9996 set diffcontext 3
9997 set ignorespace 0
9998 set selectbgcolor gray85
10000 set circlecolors {white blue gray blue blue}
10002 # button for popping up context menus
10003 if {[tk windowingsystem] eq "aqua"} {
10004     set ctxbut <Button-2>
10005 } else {
10006     set ctxbut <Button-3>
10009 ## For msgcat loading, first locate the installation location.
10010 if { [info exists ::env(GITK_MSGSDIR)] } {
10011     ## Msgsdir was manually set in the environment.
10012     set gitk_msgsdir $::env(GITK_MSGSDIR)
10013 } else {
10014     ## Let's guess the prefix from argv0.
10015     set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10016     set gitk_libdir [file join $gitk_prefix share gitk lib]
10017     set gitk_msgsdir [file join $gitk_libdir msgs]
10018     unset gitk_prefix
10021 ## Internationalization (i18n) through msgcat and gettext. See
10022 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10023 package require msgcat
10024 namespace import ::msgcat::mc
10025 ## And eventually load the actual message catalog
10026 ::msgcat::mcload $gitk_msgsdir
10028 catch {source ~/.gitk}
10030 font create optionfont -family sans-serif -size -12
10032 parsefont mainfont $mainfont
10033 eval font create mainfont [fontflags mainfont]
10034 eval font create mainfontbold [fontflags mainfont 1]
10036 parsefont textfont $textfont
10037 eval font create textfont [fontflags textfont]
10038 eval font create textfontbold [fontflags textfont 1]
10040 parsefont uifont $uifont
10041 eval font create uifont [fontflags uifont]
10043 setoptions
10045 # check that we can find a .git directory somewhere...
10046 if {[catch {set gitdir [gitdir]}]} {
10047     show_error {} . [mc "Cannot find a git repository here."]
10048     exit 1
10050 if {![file isdirectory $gitdir]} {
10051     show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10052     exit 1
10055 set selecthead {}
10056 set selectheadid {}
10058 set revtreeargs {}
10059 set cmdline_files {}
10060 set i 0
10061 set revtreeargscmd {}
10062 foreach arg $argv {
10063     switch -glob -- $arg {
10064         "" { }
10065         "--" {
10066             set cmdline_files [lrange $argv [expr {$i + 1}] end]
10067             break
10068         }
10069         "--select-commit=*" {
10070             set selecthead [string range $arg 16 end]
10071         }
10072         "--argscmd=*" {
10073             set revtreeargscmd [string range $arg 10 end]
10074         }
10075         default {
10076             lappend revtreeargs $arg
10077         }
10078     }
10079     incr i
10082 if {$selecthead eq "HEAD"} {
10083     set selecthead {}
10086 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10087     # no -- on command line, but some arguments (other than --argscmd)
10088     if {[catch {
10089         set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10090         set cmdline_files [split $f "\n"]
10091         set n [llength $cmdline_files]
10092         set revtreeargs [lrange $revtreeargs 0 end-$n]
10093         # Unfortunately git rev-parse doesn't produce an error when
10094         # something is both a revision and a filename.  To be consistent
10095         # with git log and git rev-list, check revtreeargs for filenames.
10096         foreach arg $revtreeargs {
10097             if {[file exists $arg]} {
10098                 show_error {} . [mc "Ambiguous argument '%s': both revision\
10099                                  and filename" $arg]
10100                 exit 1
10101             }
10102         }
10103     } err]} {
10104         # unfortunately we get both stdout and stderr in $err,
10105         # so look for "fatal:".
10106         set i [string first "fatal:" $err]
10107         if {$i > 0} {
10108             set err [string range $err [expr {$i + 6}] end]
10109         }
10110         show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10111         exit 1
10112     }
10115 set nullid "0000000000000000000000000000000000000000"
10116 set nullid2 "0000000000000000000000000000000000000001"
10117 set nullfile "/dev/null"
10119 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10121 set runq {}
10122 set history {}
10123 set historyindex 0
10124 set fh_serial 0
10125 set nhl_names {}
10126 set highlight_paths {}
10127 set findpattern {}
10128 set searchdirn -forwards
10129 set boldrows {}
10130 set boldnamerows {}
10131 set diffelide {0 0}
10132 set markingmatches 0
10133 set linkentercount 0
10134 set need_redisplay 0
10135 set nrows_drawn 0
10136 set firsttabstop 0
10138 set nextviewnum 1
10139 set curview 0
10140 set selectedview 0
10141 set selectedhlview [mc "None"]
10142 set highlight_related [mc "None"]
10143 set highlight_files {}
10144 set viewfiles(0) {}
10145 set viewperm(0) 0
10146 set viewargs(0) {}
10147 set viewargscmd(0) {}
10149 set selectedline {}
10150 set numcommits 0
10151 set loginstance 0
10152 set cmdlineok 0
10153 set stopped 0
10154 set stuffsaved 0
10155 set patchnum 0
10156 set lserial 0
10157 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10158 setcoords
10159 makewindow
10160 # wait for the window to become visible
10161 tkwait visibility .
10162 wm title . "[file tail $argv0]: [file tail [pwd]]"
10163 readrefs
10165 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10166     # create a view for the files/dirs specified on the command line
10167     set curview 1
10168     set selectedview 1
10169     set nextviewnum 2
10170     set viewname(1) [mc "Command line"]
10171     set viewfiles(1) $cmdline_files
10172     set viewargs(1) $revtreeargs
10173     set viewargscmd(1) $revtreeargscmd
10174     set viewperm(1) 0
10175     set vdatemode(1) 0
10176     addviewmenu 1
10177     .bar.view entryconf [mca "Edit view..."] -state normal
10178     .bar.view entryconf [mca "Delete view"] -state normal
10181 if {[info exists permviews]} {
10182     foreach v $permviews {
10183         set n $nextviewnum
10184         incr nextviewnum
10185         set viewname($n) [lindex $v 0]
10186         set viewfiles($n) [lindex $v 1]
10187         set viewargs($n) [lindex $v 2]
10188         set viewargscmd($n) [lindex $v 3]
10189         set viewperm($n) 1
10190         addviewmenu $n
10191     }
10193 getcommits {}