Code

gitk: Fix binding for <Return> in sha1 entry field
[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 makewindow {} {
1754     global canv canv2 canv3 linespc charspc ctext cflist cscroll
1755     global tabstop
1756     global findtype findtypemenu findloc findstring fstring geometry
1757     global entries sha1entry sha1string sha1but
1758     global diffcontextstring diffcontext
1759     global ignorespace
1760     global maincursor textcursor curtextcursor
1761     global rowctxmenu fakerowmenu mergemax wrapcomment
1762     global highlight_files gdttype
1763     global searchstring sstring
1764     global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1765     global headctxmenu progresscanv progressitem progresscoords statusw
1766     global fprogitem fprogcoord lastprogupdate progupdatepending
1767     global rprogitem rprogcoord rownumsel numcommits
1768     global have_tk85
1770     menu .bar
1771     .bar add cascade -label [mc "File"] -menu .bar.file
1772     menu .bar.file
1773     .bar.file add command -label [mc "Update"] -command updatecommits
1774     .bar.file add command -label [mc "Reload"] -command reloadcommits
1775     .bar.file add command -label [mc "Reread references"] -command rereadrefs
1776     .bar.file add command -label [mc "List references"] -command showrefs
1777     .bar.file add command -label [mc "Quit"] -command doquit
1778     menu .bar.edit
1779     .bar add cascade -label [mc "Edit"] -menu .bar.edit
1780     .bar.edit add command -label [mc "Preferences"] -command doprefs
1782     menu .bar.view
1783     .bar add cascade -label [mc "View"] -menu .bar.view
1784     .bar.view add command -label [mc "New view..."] -command {newview 0}
1785     .bar.view add command -label [mc "Edit view..."] -command editview \
1786         -state disabled
1787     .bar.view add command -label [mc "Delete view"] -command delview -state disabled
1788     .bar.view add separator
1789     .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
1790         -variable selectedview -value 0
1792     menu .bar.help
1793     .bar add cascade -label [mc "Help"] -menu .bar.help
1794     .bar.help add command -label [mc "About gitk"] -command about
1795     .bar.help add command -label [mc "Key bindings"] -command keys
1796     .bar.help configure
1797     . configure -menu .bar
1799     # the gui has upper and lower half, parts of a paned window.
1800     panedwindow .ctop -orient vertical
1802     # possibly use assumed geometry
1803     if {![info exists geometry(pwsash0)]} {
1804         set geometry(topheight) [expr {15 * $linespc}]
1805         set geometry(topwidth) [expr {80 * $charspc}]
1806         set geometry(botheight) [expr {15 * $linespc}]
1807         set geometry(botwidth) [expr {50 * $charspc}]
1808         set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1809         set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1810     }
1812     # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1813     frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1814     frame .tf.histframe
1815     panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1817     # create three canvases
1818     set cscroll .tf.histframe.csb
1819     set canv .tf.histframe.pwclist.canv
1820     canvas $canv \
1821         -selectbackground $selectbgcolor \
1822         -background $bgcolor -bd 0 \
1823         -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1824     .tf.histframe.pwclist add $canv
1825     set canv2 .tf.histframe.pwclist.canv2
1826     canvas $canv2 \
1827         -selectbackground $selectbgcolor \
1828         -background $bgcolor -bd 0 -yscrollincr $linespc
1829     .tf.histframe.pwclist add $canv2
1830     set canv3 .tf.histframe.pwclist.canv3
1831     canvas $canv3 \
1832         -selectbackground $selectbgcolor \
1833         -background $bgcolor -bd 0 -yscrollincr $linespc
1834     .tf.histframe.pwclist add $canv3
1835     eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1836     eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1838     # a scroll bar to rule them
1839     scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1840     pack $cscroll -side right -fill y
1841     bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1842     lappend bglist $canv $canv2 $canv3
1843     pack .tf.histframe.pwclist -fill both -expand 1 -side left
1845     # we have two button bars at bottom of top frame. Bar 1
1846     frame .tf.bar
1847     frame .tf.lbar -height 15
1849     set sha1entry .tf.bar.sha1
1850     set entries $sha1entry
1851     set sha1but .tf.bar.sha1label
1852     button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1853         -command gotocommit -width 8
1854     $sha1but conf -disabledforeground [$sha1but cget -foreground]
1855     pack .tf.bar.sha1label -side left
1856     entry $sha1entry -width 40 -font textfont -textvariable sha1string
1857     trace add variable sha1string write sha1change
1858     pack $sha1entry -side left -pady 2
1860     image create bitmap bm-left -data {
1861         #define left_width 16
1862         #define left_height 16
1863         static unsigned char left_bits[] = {
1864         0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1865         0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1866         0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1867     }
1868     image create bitmap bm-right -data {
1869         #define right_width 16
1870         #define right_height 16
1871         static unsigned char right_bits[] = {
1872         0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1873         0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1874         0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1875     }
1876     button .tf.bar.leftbut -image bm-left -command goback \
1877         -state disabled -width 26
1878     pack .tf.bar.leftbut -side left -fill y
1879     button .tf.bar.rightbut -image bm-right -command goforw \
1880         -state disabled -width 26
1881     pack .tf.bar.rightbut -side left -fill y
1883     label .tf.bar.rowlabel -text [mc "Row"]
1884     set rownumsel {}
1885     label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
1886         -relief sunken -anchor e
1887     label .tf.bar.rowlabel2 -text "/"
1888     label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
1889         -relief sunken -anchor e
1890     pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
1891         -side left
1892     global selectedline
1893     trace add variable selectedline write selectedline_change
1895     # Status label and progress bar
1896     set statusw .tf.bar.status
1897     label $statusw -width 15 -relief sunken
1898     pack $statusw -side left -padx 5
1899     set h [expr {[font metrics uifont -linespace] + 2}]
1900     set progresscanv .tf.bar.progress
1901     canvas $progresscanv -relief sunken -height $h -borderwidth 2
1902     set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1903     set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1904     set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1905     pack $progresscanv -side right -expand 1 -fill x
1906     set progresscoords {0 0}
1907     set fprogcoord 0
1908     set rprogcoord 0
1909     bind $progresscanv <Configure> adjustprogress
1910     set lastprogupdate [clock clicks -milliseconds]
1911     set progupdatepending 0
1913     # build up the bottom bar of upper window
1914     label .tf.lbar.flabel -text "[mc "Find"] "
1915     button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
1916     button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
1917     label .tf.lbar.flab2 -text " [mc "commit"] "
1918     pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1919         -side left -fill y
1920     set gdttype [mc "containing:"]
1921     set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1922                 [mc "containing:"] \
1923                 [mc "touching paths:"] \
1924                 [mc "adding/removing string:"]]
1925     trace add variable gdttype write gdttype_change
1926     pack .tf.lbar.gdttype -side left -fill y
1928     set findstring {}
1929     set fstring .tf.lbar.findstring
1930     lappend entries $fstring
1931     entry $fstring -width 30 -font textfont -textvariable findstring
1932     trace add variable findstring write find_change
1933     set findtype [mc "Exact"]
1934     set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1935                       findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
1936     trace add variable findtype write findcom_change
1937     set findloc [mc "All fields"]
1938     tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
1939         [mc "Comments"] [mc "Author"] [mc "Committer"]
1940     trace add variable findloc write find_change
1941     pack .tf.lbar.findloc -side right
1942     pack .tf.lbar.findtype -side right
1943     pack $fstring -side left -expand 1 -fill x
1945     # Finish putting the upper half of the viewer together
1946     pack .tf.lbar -in .tf -side bottom -fill x
1947     pack .tf.bar -in .tf -side bottom -fill x
1948     pack .tf.histframe -fill both -side top -expand 1
1949     .ctop add .tf
1950     .ctop paneconfigure .tf -height $geometry(topheight)
1951     .ctop paneconfigure .tf -width $geometry(topwidth)
1953     # now build up the bottom
1954     panedwindow .pwbottom -orient horizontal
1956     # lower left, a text box over search bar, scroll bar to the right
1957     # if we know window height, then that will set the lower text height, otherwise
1958     # we set lower text height which will drive window height
1959     if {[info exists geometry(main)]} {
1960         frame .bleft -width $geometry(botwidth)
1961     } else {
1962         frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1963     }
1964     frame .bleft.top
1965     frame .bleft.mid
1966     frame .bleft.bottom
1968     button .bleft.top.search -text [mc "Search"] -command dosearch
1969     pack .bleft.top.search -side left -padx 5
1970     set sstring .bleft.top.sstring
1971     entry $sstring -width 20 -font textfont -textvariable searchstring
1972     lappend entries $sstring
1973     trace add variable searchstring write incrsearch
1974     pack $sstring -side left -expand 1 -fill x
1975     radiobutton .bleft.mid.diff -text [mc "Diff"] \
1976         -command changediffdisp -variable diffelide -value {0 0}
1977     radiobutton .bleft.mid.old -text [mc "Old version"] \
1978         -command changediffdisp -variable diffelide -value {0 1}
1979     radiobutton .bleft.mid.new -text [mc "New version"] \
1980         -command changediffdisp -variable diffelide -value {1 0}
1981     label .bleft.mid.labeldiffcontext -text "      [mc "Lines of context"]: "
1982     pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1983     spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1984         -from 1 -increment 1 -to 10000000 \
1985         -validate all -validatecommand "diffcontextvalidate %P" \
1986         -textvariable diffcontextstring
1987     .bleft.mid.diffcontext set $diffcontext
1988     trace add variable diffcontextstring write diffcontextchange
1989     lappend entries .bleft.mid.diffcontext
1990     pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1991     checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
1992         -command changeignorespace -variable ignorespace
1993     pack .bleft.mid.ignspace -side left -padx 5
1994     set ctext .bleft.bottom.ctext
1995     text $ctext -background $bgcolor -foreground $fgcolor \
1996         -state disabled -font textfont \
1997         -yscrollcommand scrolltext -wrap none \
1998         -xscrollcommand ".bleft.bottom.sbhorizontal set"
1999     if {$have_tk85} {
2000         $ctext conf -tabstyle wordprocessor
2001     }
2002     scrollbar .bleft.bottom.sb -command "$ctext yview"
2003     scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2004         -width 10
2005     pack .bleft.top -side top -fill x
2006     pack .bleft.mid -side top -fill x
2007     grid $ctext .bleft.bottom.sb -sticky nsew
2008     grid .bleft.bottom.sbhorizontal -sticky ew
2009     grid columnconfigure .bleft.bottom 0 -weight 1
2010     grid rowconfigure .bleft.bottom 0 -weight 1
2011     grid rowconfigure .bleft.bottom 1 -weight 0
2012     pack .bleft.bottom -side top -fill both -expand 1
2013     lappend bglist $ctext
2014     lappend fglist $ctext
2016     $ctext tag conf comment -wrap $wrapcomment
2017     $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2018     $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2019     $ctext tag conf d0 -fore [lindex $diffcolors 0]
2020     $ctext tag conf d1 -fore [lindex $diffcolors 1]
2021     $ctext tag conf m0 -fore red
2022     $ctext tag conf m1 -fore blue
2023     $ctext tag conf m2 -fore green
2024     $ctext tag conf m3 -fore purple
2025     $ctext tag conf m4 -fore brown
2026     $ctext tag conf m5 -fore "#009090"
2027     $ctext tag conf m6 -fore magenta
2028     $ctext tag conf m7 -fore "#808000"
2029     $ctext tag conf m8 -fore "#009000"
2030     $ctext tag conf m9 -fore "#ff0080"
2031     $ctext tag conf m10 -fore cyan
2032     $ctext tag conf m11 -fore "#b07070"
2033     $ctext tag conf m12 -fore "#70b0f0"
2034     $ctext tag conf m13 -fore "#70f0b0"
2035     $ctext tag conf m14 -fore "#f0b070"
2036     $ctext tag conf m15 -fore "#ff70b0"
2037     $ctext tag conf mmax -fore darkgrey
2038     set mergemax 16
2039     $ctext tag conf mresult -font textfontbold
2040     $ctext tag conf msep -font textfontbold
2041     $ctext tag conf found -back yellow
2043     .pwbottom add .bleft
2044     .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2046     # lower right
2047     frame .bright
2048     frame .bright.mode
2049     radiobutton .bright.mode.patch -text [mc "Patch"] \
2050         -command reselectline -variable cmitmode -value "patch"
2051     radiobutton .bright.mode.tree -text [mc "Tree"] \
2052         -command reselectline -variable cmitmode -value "tree"
2053     grid .bright.mode.patch .bright.mode.tree -sticky ew
2054     pack .bright.mode -side top -fill x
2055     set cflist .bright.cfiles
2056     set indent [font measure mainfont "nn"]
2057     text $cflist \
2058         -selectbackground $selectbgcolor \
2059         -background $bgcolor -foreground $fgcolor \
2060         -font mainfont \
2061         -tabs [list $indent [expr {2 * $indent}]] \
2062         -yscrollcommand ".bright.sb set" \
2063         -cursor [. cget -cursor] \
2064         -spacing1 1 -spacing3 1
2065     lappend bglist $cflist
2066     lappend fglist $cflist
2067     scrollbar .bright.sb -command "$cflist yview"
2068     pack .bright.sb -side right -fill y
2069     pack $cflist -side left -fill both -expand 1
2070     $cflist tag configure highlight \
2071         -background [$cflist cget -selectbackground]
2072     $cflist tag configure bold -font mainfontbold
2074     .pwbottom add .bright
2075     .ctop add .pwbottom
2077     # restore window width & height if known
2078     if {[info exists geometry(main)]} {
2079         if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2080             if {$w > [winfo screenwidth .]} {
2081                 set w [winfo screenwidth .]
2082             }
2083             if {$h > [winfo screenheight .]} {
2084                 set h [winfo screenheight .]
2085             }
2086             wm geometry . "${w}x$h"
2087         }
2088     }
2090     if {[tk windowingsystem] eq {aqua}} {
2091         set M1B M1
2092     } else {
2093         set M1B Control
2094     }
2096     bind .pwbottom <Configure> {resizecdetpanes %W %w}
2097     pack .ctop -fill both -expand 1
2098     bindall <1> {selcanvline %W %x %y}
2099     #bindall <B1-Motion> {selcanvline %W %x %y}
2100     if {[tk windowingsystem] == "win32"} {
2101         bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2102         bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2103     } else {
2104         bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2105         bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2106         if {[tk windowingsystem] eq "aqua"} {
2107             bindall <MouseWheel> {
2108                 set delta [expr {- (%D)}]
2109                 allcanvs yview scroll $delta units
2110             }
2111         }
2112     }
2113     bindall <2> "canvscan mark %W %x %y"
2114     bindall <B2-Motion> "canvscan dragto %W %x %y"
2115     bindkey <Home> selfirstline
2116     bindkey <End> sellastline
2117     bind . <Key-Up> "selnextline -1"
2118     bind . <Key-Down> "selnextline 1"
2119     bind . <Shift-Key-Up> "dofind -1 0"
2120     bind . <Shift-Key-Down> "dofind 1 0"
2121     bindkey <Key-Right> "goforw"
2122     bindkey <Key-Left> "goback"
2123     bind . <Key-Prior> "selnextpage -1"
2124     bind . <Key-Next> "selnextpage 1"
2125     bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2126     bind . <$M1B-End> "allcanvs yview moveto 1.0"
2127     bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2128     bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2129     bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2130     bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2131     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2132     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2133     bindkey <Key-space> "$ctext yview scroll 1 pages"
2134     bindkey p "selnextline -1"
2135     bindkey n "selnextline 1"
2136     bindkey z "goback"
2137     bindkey x "goforw"
2138     bindkey i "selnextline -1"
2139     bindkey k "selnextline 1"
2140     bindkey j "goback"
2141     bindkey l "goforw"
2142     bindkey b prevfile
2143     bindkey d "$ctext yview scroll 18 units"
2144     bindkey u "$ctext yview scroll -18 units"
2145     bindkey / {dofind 1 1}
2146     bindkey <Key-Return> {dofind 1 1}
2147     bindkey ? {dofind -1 1}
2148     bindkey f nextfile
2149     bindkey <F5> updatecommits
2150     bind . <$M1B-q> doquit
2151     bind . <$M1B-f> {dofind 1 1}
2152     bind . <$M1B-g> {dofind 1 0}
2153     bind . <$M1B-r> dosearchback
2154     bind . <$M1B-s> dosearch
2155     bind . <$M1B-equal> {incrfont 1}
2156     bind . <$M1B-plus> {incrfont 1}
2157     bind . <$M1B-KP_Add> {incrfont 1}
2158     bind . <$M1B-minus> {incrfont -1}
2159     bind . <$M1B-KP_Subtract> {incrfont -1}
2160     wm protocol . WM_DELETE_WINDOW doquit
2161     bind . <Destroy> {stop_backends}
2162     bind . <Button-1> "click %W"
2163     bind $fstring <Key-Return> {dofind 1 1}
2164     bind $sha1entry <Key-Return> {gotocommit; break}
2165     bind $sha1entry <<PasteSelection>> clearsha1
2166     bind $cflist <1> {sel_flist %W %x %y; break}
2167     bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2168     bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2169     global ctxbut
2170     bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2172     set maincursor [. cget -cursor]
2173     set textcursor [$ctext cget -cursor]
2174     set curtextcursor $textcursor
2176     set rowctxmenu .rowctxmenu
2177     menu $rowctxmenu -tearoff 0
2178     $rowctxmenu add command -label [mc "Diff this -> selected"] \
2179         -command {diffvssel 0}
2180     $rowctxmenu add command -label [mc "Diff selected -> this"] \
2181         -command {diffvssel 1}
2182     $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
2183     $rowctxmenu add command -label [mc "Create tag"] -command mktag
2184     $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
2185     $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
2186     $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
2187         -command cherrypick
2188     $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
2189         -command resethead
2191     set fakerowmenu .fakerowmenu
2192     menu $fakerowmenu -tearoff 0
2193     $fakerowmenu add command -label [mc "Diff this -> selected"] \
2194         -command {diffvssel 0}
2195     $fakerowmenu add command -label [mc "Diff selected -> this"] \
2196         -command {diffvssel 1}
2197     $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
2198 #    $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
2199 #    $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
2200 #    $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
2202     set headctxmenu .headctxmenu
2203     menu $headctxmenu -tearoff 0
2204     $headctxmenu add command -label [mc "Check out this branch"] \
2205         -command cobranch
2206     $headctxmenu add command -label [mc "Remove this branch"] \
2207         -command rmbranch
2209     global flist_menu
2210     set flist_menu .flistctxmenu
2211     menu $flist_menu -tearoff 0
2212     $flist_menu add command -label [mc "Highlight this too"] \
2213         -command {flist_hl 0}
2214     $flist_menu add command -label [mc "Highlight this only"] \
2215         -command {flist_hl 1}
2216     $flist_menu add command -label [mc "External diff"] \
2217         -command {external_diff}
2218     $flist_menu add command -label [mc "Blame parent commit"] \
2219         -command {external_blame 1}
2222 # Windows sends all mouse wheel events to the current focused window, not
2223 # the one where the mouse hovers, so bind those events here and redirect
2224 # to the correct window
2225 proc windows_mousewheel_redirector {W X Y D} {
2226     global canv canv2 canv3
2227     set w [winfo containing -displayof $W $X $Y]
2228     if {$w ne ""} {
2229         set u [expr {$D < 0 ? 5 : -5}]
2230         if {$w == $canv || $w == $canv2 || $w == $canv3} {
2231             allcanvs yview scroll $u units
2232         } else {
2233             catch {
2234                 $w yview scroll $u units
2235             }
2236         }
2237     }
2240 # Update row number label when selectedline changes
2241 proc selectedline_change {n1 n2 op} {
2242     global selectedline rownumsel
2244     if {$selectedline eq {}} {
2245         set rownumsel {}
2246     } else {
2247         set rownumsel [expr {$selectedline + 1}]
2248     }
2251 # mouse-2 makes all windows scan vertically, but only the one
2252 # the cursor is in scans horizontally
2253 proc canvscan {op w x y} {
2254     global canv canv2 canv3
2255     foreach c [list $canv $canv2 $canv3] {
2256         if {$c == $w} {
2257             $c scan $op $x $y
2258         } else {
2259             $c scan $op 0 $y
2260         }
2261     }
2264 proc scrollcanv {cscroll f0 f1} {
2265     $cscroll set $f0 $f1
2266     drawvisible
2267     flushhighlights
2270 # when we make a key binding for the toplevel, make sure
2271 # it doesn't get triggered when that key is pressed in the
2272 # find string entry widget.
2273 proc bindkey {ev script} {
2274     global entries
2275     bind . $ev $script
2276     set escript [bind Entry $ev]
2277     if {$escript == {}} {
2278         set escript [bind Entry <Key>]
2279     }
2280     foreach e $entries {
2281         bind $e $ev "$escript; break"
2282     }
2285 # set the focus back to the toplevel for any click outside
2286 # the entry widgets
2287 proc click {w} {
2288     global ctext entries
2289     foreach e [concat $entries $ctext] {
2290         if {$w == $e} return
2291     }
2292     focus .
2295 # Adjust the progress bar for a change in requested extent or canvas size
2296 proc adjustprogress {} {
2297     global progresscanv progressitem progresscoords
2298     global fprogitem fprogcoord lastprogupdate progupdatepending
2299     global rprogitem rprogcoord
2301     set w [expr {[winfo width $progresscanv] - 4}]
2302     set x0 [expr {$w * [lindex $progresscoords 0]}]
2303     set x1 [expr {$w * [lindex $progresscoords 1]}]
2304     set h [winfo height $progresscanv]
2305     $progresscanv coords $progressitem $x0 0 $x1 $h
2306     $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2307     $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2308     set now [clock clicks -milliseconds]
2309     if {$now >= $lastprogupdate + 100} {
2310         set progupdatepending 0
2311         update
2312     } elseif {!$progupdatepending} {
2313         set progupdatepending 1
2314         after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2315     }
2318 proc doprogupdate {} {
2319     global lastprogupdate progupdatepending
2321     if {$progupdatepending} {
2322         set progupdatepending 0
2323         set lastprogupdate [clock clicks -milliseconds]
2324         update
2325     }
2328 proc savestuff {w} {
2329     global canv canv2 canv3 mainfont textfont uifont tabstop
2330     global stuffsaved findmergefiles maxgraphpct
2331     global maxwidth showneartags showlocalchanges
2332     global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2333     global cmitmode wrapcomment datetimeformat limitdiffs
2334     global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2335     global autoselect extdifftool perfile_attrs
2337     if {$stuffsaved} return
2338     if {![winfo viewable .]} return
2339     catch {
2340         set f [open "~/.gitk-new" w]
2341         puts $f [list set mainfont $mainfont]
2342         puts $f [list set textfont $textfont]
2343         puts $f [list set uifont $uifont]
2344         puts $f [list set tabstop $tabstop]
2345         puts $f [list set findmergefiles $findmergefiles]
2346         puts $f [list set maxgraphpct $maxgraphpct]
2347         puts $f [list set maxwidth $maxwidth]
2348         puts $f [list set cmitmode $cmitmode]
2349         puts $f [list set wrapcomment $wrapcomment]
2350         puts $f [list set autoselect $autoselect]
2351         puts $f [list set showneartags $showneartags]
2352         puts $f [list set showlocalchanges $showlocalchanges]
2353         puts $f [list set datetimeformat $datetimeformat]
2354         puts $f [list set limitdiffs $limitdiffs]
2355         puts $f [list set bgcolor $bgcolor]
2356         puts $f [list set fgcolor $fgcolor]
2357         puts $f [list set colors $colors]
2358         puts $f [list set diffcolors $diffcolors]
2359         puts $f [list set diffcontext $diffcontext]
2360         puts $f [list set selectbgcolor $selectbgcolor]
2361         puts $f [list set extdifftool $extdifftool]
2362         puts $f [list set perfile_attrs $perfile_attrs]
2364         puts $f "set geometry(main) [wm geometry .]"
2365         puts $f "set geometry(topwidth) [winfo width .tf]"
2366         puts $f "set geometry(topheight) [winfo height .tf]"
2367         puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2368         puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2369         puts $f "set geometry(botwidth) [winfo width .bleft]"
2370         puts $f "set geometry(botheight) [winfo height .bleft]"
2372         puts -nonewline $f "set permviews {"
2373         for {set v 0} {$v < $nextviewnum} {incr v} {
2374             if {$viewperm($v)} {
2375                 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2376             }
2377         }
2378         puts $f "}"
2379         close $f
2380         file rename -force "~/.gitk-new" "~/.gitk"
2381     }
2382     set stuffsaved 1
2385 proc resizeclistpanes {win w} {
2386     global oldwidth
2387     if {[info exists oldwidth($win)]} {
2388         set s0 [$win sash coord 0]
2389         set s1 [$win sash coord 1]
2390         if {$w < 60} {
2391             set sash0 [expr {int($w/2 - 2)}]
2392             set sash1 [expr {int($w*5/6 - 2)}]
2393         } else {
2394             set factor [expr {1.0 * $w / $oldwidth($win)}]
2395             set sash0 [expr {int($factor * [lindex $s0 0])}]
2396             set sash1 [expr {int($factor * [lindex $s1 0])}]
2397             if {$sash0 < 30} {
2398                 set sash0 30
2399             }
2400             if {$sash1 < $sash0 + 20} {
2401                 set sash1 [expr {$sash0 + 20}]
2402             }
2403             if {$sash1 > $w - 10} {
2404                 set sash1 [expr {$w - 10}]
2405                 if {$sash0 > $sash1 - 20} {
2406                     set sash0 [expr {$sash1 - 20}]
2407                 }
2408             }
2409         }
2410         $win sash place 0 $sash0 [lindex $s0 1]
2411         $win sash place 1 $sash1 [lindex $s1 1]
2412     }
2413     set oldwidth($win) $w
2416 proc resizecdetpanes {win w} {
2417     global oldwidth
2418     if {[info exists oldwidth($win)]} {
2419         set s0 [$win sash coord 0]
2420         if {$w < 60} {
2421             set sash0 [expr {int($w*3/4 - 2)}]
2422         } else {
2423             set factor [expr {1.0 * $w / $oldwidth($win)}]
2424             set sash0 [expr {int($factor * [lindex $s0 0])}]
2425             if {$sash0 < 45} {
2426                 set sash0 45
2427             }
2428             if {$sash0 > $w - 15} {
2429                 set sash0 [expr {$w - 15}]
2430             }
2431         }
2432         $win sash place 0 $sash0 [lindex $s0 1]
2433     }
2434     set oldwidth($win) $w
2437 proc allcanvs args {
2438     global canv canv2 canv3
2439     eval $canv $args
2440     eval $canv2 $args
2441     eval $canv3 $args
2444 proc bindall {event action} {
2445     global canv canv2 canv3
2446     bind $canv $event $action
2447     bind $canv2 $event $action
2448     bind $canv3 $event $action
2451 proc about {} {
2452     global uifont
2453     set w .about
2454     if {[winfo exists $w]} {
2455         raise $w
2456         return
2457     }
2458     toplevel $w
2459     wm title $w [mc "About gitk"]
2460     message $w.m -text [mc "
2461 Gitk - a commit viewer for git
2463 Copyright © 2005-2008 Paul Mackerras
2465 Use and redistribute under the terms of the GNU General Public License"] \
2466             -justify center -aspect 400 -border 2 -bg white -relief groove
2467     pack $w.m -side top -fill x -padx 2 -pady 2
2468     button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2469     pack $w.ok -side bottom
2470     bind $w <Visibility> "focus $w.ok"
2471     bind $w <Key-Escape> "destroy $w"
2472     bind $w <Key-Return> "destroy $w"
2475 proc keys {} {
2476     set w .keys
2477     if {[winfo exists $w]} {
2478         raise $w
2479         return
2480     }
2481     if {[tk windowingsystem] eq {aqua}} {
2482         set M1T Cmd
2483     } else {
2484         set M1T Ctrl
2485     }
2486     toplevel $w
2487     wm title $w [mc "Gitk key bindings"]
2488     message $w.m -text "
2489 [mc "Gitk key bindings:"]
2491 [mc "<%s-Q>             Quit" $M1T]
2492 [mc "<Home>             Move to first commit"]
2493 [mc "<End>              Move to last commit"]
2494 [mc "<Up>, p, i Move up one commit"]
2495 [mc "<Down>, n, k       Move down one commit"]
2496 [mc "<Left>, z, j       Go back in history list"]
2497 [mc "<Right>, x, l      Go forward in history list"]
2498 [mc "<PageUp>   Move up one page in commit list"]
2499 [mc "<PageDown> Move down one page in commit list"]
2500 [mc "<%s-Home>  Scroll to top of commit list" $M1T]
2501 [mc "<%s-End>   Scroll to bottom of commit list" $M1T]
2502 [mc "<%s-Up>    Scroll commit list up one line" $M1T]
2503 [mc "<%s-Down>  Scroll commit list down one line" $M1T]
2504 [mc "<%s-PageUp>        Scroll commit list up one page" $M1T]
2505 [mc "<%s-PageDown>      Scroll commit list down one page" $M1T]
2506 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2507 [mc "<Shift-Down>       Find forwards (downwards, earlier commits)"]
2508 [mc "<Delete>, b        Scroll diff view up one page"]
2509 [mc "<Backspace>        Scroll diff view up one page"]
2510 [mc "<Space>            Scroll diff view down one page"]
2511 [mc "u          Scroll diff view up 18 lines"]
2512 [mc "d          Scroll diff view down 18 lines"]
2513 [mc "<%s-F>             Find" $M1T]
2514 [mc "<%s-G>             Move to next find hit" $M1T]
2515 [mc "<Return>   Move to next find hit"]
2516 [mc "/          Move to next find hit, or redo find"]
2517 [mc "?          Move to previous find hit"]
2518 [mc "f          Scroll diff view to next file"]
2519 [mc "<%s-S>             Search for next hit in diff view" $M1T]
2520 [mc "<%s-R>             Search for previous hit in diff view" $M1T]
2521 [mc "<%s-KP+>   Increase font size" $M1T]
2522 [mc "<%s-plus>  Increase font size" $M1T]
2523 [mc "<%s-KP->   Decrease font size" $M1T]
2524 [mc "<%s-minus> Decrease font size" $M1T]
2525 [mc "<F5>               Update"]
2526 " \
2527             -justify left -bg white -border 2 -relief groove
2528     pack $w.m -side top -fill both -padx 2 -pady 2
2529     button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2530     pack $w.ok -side bottom
2531     bind $w <Visibility> "focus $w.ok"
2532     bind $w <Key-Escape> "destroy $w"
2533     bind $w <Key-Return> "destroy $w"
2536 # Procedures for manipulating the file list window at the
2537 # bottom right of the overall window.
2539 proc treeview {w l openlevs} {
2540     global treecontents treediropen treeheight treeparent treeindex
2542     set ix 0
2543     set treeindex() 0
2544     set lev 0
2545     set prefix {}
2546     set prefixend -1
2547     set prefendstack {}
2548     set htstack {}
2549     set ht 0
2550     set treecontents() {}
2551     $w conf -state normal
2552     foreach f $l {
2553         while {[string range $f 0 $prefixend] ne $prefix} {
2554             if {$lev <= $openlevs} {
2555                 $w mark set e:$treeindex($prefix) "end -1c"
2556                 $w mark gravity e:$treeindex($prefix) left
2557             }
2558             set treeheight($prefix) $ht
2559             incr ht [lindex $htstack end]
2560             set htstack [lreplace $htstack end end]
2561             set prefixend [lindex $prefendstack end]
2562             set prefendstack [lreplace $prefendstack end end]
2563             set prefix [string range $prefix 0 $prefixend]
2564             incr lev -1
2565         }
2566         set tail [string range $f [expr {$prefixend+1}] end]
2567         while {[set slash [string first "/" $tail]] >= 0} {
2568             lappend htstack $ht
2569             set ht 0
2570             lappend prefendstack $prefixend
2571             incr prefixend [expr {$slash + 1}]
2572             set d [string range $tail 0 $slash]
2573             lappend treecontents($prefix) $d
2574             set oldprefix $prefix
2575             append prefix $d
2576             set treecontents($prefix) {}
2577             set treeindex($prefix) [incr ix]
2578             set treeparent($prefix) $oldprefix
2579             set tail [string range $tail [expr {$slash+1}] end]
2580             if {$lev <= $openlevs} {
2581                 set ht 1
2582                 set treediropen($prefix) [expr {$lev < $openlevs}]
2583                 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2584                 $w mark set d:$ix "end -1c"
2585                 $w mark gravity d:$ix left
2586                 set str "\n"
2587                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2588                 $w insert end $str
2589                 $w image create end -align center -image $bm -padx 1 \
2590                     -name a:$ix
2591                 $w insert end $d [highlight_tag $prefix]
2592                 $w mark set s:$ix "end -1c"
2593                 $w mark gravity s:$ix left
2594             }
2595             incr lev
2596         }
2597         if {$tail ne {}} {
2598             if {$lev <= $openlevs} {
2599                 incr ht
2600                 set str "\n"
2601                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2602                 $w insert end $str
2603                 $w insert end $tail [highlight_tag $f]
2604             }
2605             lappend treecontents($prefix) $tail
2606         }
2607     }
2608     while {$htstack ne {}} {
2609         set treeheight($prefix) $ht
2610         incr ht [lindex $htstack end]
2611         set htstack [lreplace $htstack end end]
2612         set prefixend [lindex $prefendstack end]
2613         set prefendstack [lreplace $prefendstack end end]
2614         set prefix [string range $prefix 0 $prefixend]
2615     }
2616     $w conf -state disabled
2619 proc linetoelt {l} {
2620     global treeheight treecontents
2622     set y 2
2623     set prefix {}
2624     while {1} {
2625         foreach e $treecontents($prefix) {
2626             if {$y == $l} {
2627                 return "$prefix$e"
2628             }
2629             set n 1
2630             if {[string index $e end] eq "/"} {
2631                 set n $treeheight($prefix$e)
2632                 if {$y + $n > $l} {
2633                     append prefix $e
2634                     incr y
2635                     break
2636                 }
2637             }
2638             incr y $n
2639         }
2640     }
2643 proc highlight_tree {y prefix} {
2644     global treeheight treecontents cflist
2646     foreach e $treecontents($prefix) {
2647         set path $prefix$e
2648         if {[highlight_tag $path] ne {}} {
2649             $cflist tag add bold $y.0 "$y.0 lineend"
2650         }
2651         incr y
2652         if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2653             set y [highlight_tree $y $path]
2654         }
2655     }
2656     return $y
2659 proc treeclosedir {w dir} {
2660     global treediropen treeheight treeparent treeindex
2662     set ix $treeindex($dir)
2663     $w conf -state normal
2664     $w delete s:$ix e:$ix
2665     set treediropen($dir) 0
2666     $w image configure a:$ix -image tri-rt
2667     $w conf -state disabled
2668     set n [expr {1 - $treeheight($dir)}]
2669     while {$dir ne {}} {
2670         incr treeheight($dir) $n
2671         set dir $treeparent($dir)
2672     }
2675 proc treeopendir {w dir} {
2676     global treediropen treeheight treeparent treecontents treeindex
2678     set ix $treeindex($dir)
2679     $w conf -state normal
2680     $w image configure a:$ix -image tri-dn
2681     $w mark set e:$ix s:$ix
2682     $w mark gravity e:$ix right
2683     set lev 0
2684     set str "\n"
2685     set n [llength $treecontents($dir)]
2686     for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2687         incr lev
2688         append str "\t"
2689         incr treeheight($x) $n
2690     }
2691     foreach e $treecontents($dir) {
2692         set de $dir$e
2693         if {[string index $e end] eq "/"} {
2694             set iy $treeindex($de)
2695             $w mark set d:$iy e:$ix
2696             $w mark gravity d:$iy left
2697             $w insert e:$ix $str
2698             set treediropen($de) 0
2699             $w image create e:$ix -align center -image tri-rt -padx 1 \
2700                 -name a:$iy
2701             $w insert e:$ix $e [highlight_tag $de]
2702             $w mark set s:$iy e:$ix
2703             $w mark gravity s:$iy left
2704             set treeheight($de) 1
2705         } else {
2706             $w insert e:$ix $str
2707             $w insert e:$ix $e [highlight_tag $de]
2708         }
2709     }
2710     $w mark gravity e:$ix right
2711     $w conf -state disabled
2712     set treediropen($dir) 1
2713     set top [lindex [split [$w index @0,0] .] 0]
2714     set ht [$w cget -height]
2715     set l [lindex [split [$w index s:$ix] .] 0]
2716     if {$l < $top} {
2717         $w yview $l.0
2718     } elseif {$l + $n + 1 > $top + $ht} {
2719         set top [expr {$l + $n + 2 - $ht}]
2720         if {$l < $top} {
2721             set top $l
2722         }
2723         $w yview $top.0
2724     }
2727 proc treeclick {w x y} {
2728     global treediropen cmitmode ctext cflist cflist_top
2730     if {$cmitmode ne "tree"} return
2731     if {![info exists cflist_top]} return
2732     set l [lindex [split [$w index "@$x,$y"] "."] 0]
2733     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2734     $cflist tag add highlight $l.0 "$l.0 lineend"
2735     set cflist_top $l
2736     if {$l == 1} {
2737         $ctext yview 1.0
2738         return
2739     }
2740     set e [linetoelt $l]
2741     if {[string index $e end] ne "/"} {
2742         showfile $e
2743     } elseif {$treediropen($e)} {
2744         treeclosedir $w $e
2745     } else {
2746         treeopendir $w $e
2747     }
2750 proc setfilelist {id} {
2751     global treefilelist cflist
2753     treeview $cflist $treefilelist($id) 0
2756 image create bitmap tri-rt -background black -foreground blue -data {
2757     #define tri-rt_width 13
2758     #define tri-rt_height 13
2759     static unsigned char tri-rt_bits[] = {
2760        0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2761        0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2762        0x00, 0x00};
2763 } -maskdata {
2764     #define tri-rt-mask_width 13
2765     #define tri-rt-mask_height 13
2766     static unsigned char tri-rt-mask_bits[] = {
2767        0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2768        0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2769        0x08, 0x00};
2771 image create bitmap tri-dn -background black -foreground blue -data {
2772     #define tri-dn_width 13
2773     #define tri-dn_height 13
2774     static unsigned char tri-dn_bits[] = {
2775        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2776        0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2777        0x00, 0x00};
2778 } -maskdata {
2779     #define tri-dn-mask_width 13
2780     #define tri-dn-mask_height 13
2781     static unsigned char tri-dn-mask_bits[] = {
2782        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2783        0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2784        0x00, 0x00};
2787 image create bitmap reficon-T -background black -foreground yellow -data {
2788     #define tagicon_width 13
2789     #define tagicon_height 9
2790     static unsigned char tagicon_bits[] = {
2791        0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2792        0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2793 } -maskdata {
2794     #define tagicon-mask_width 13
2795     #define tagicon-mask_height 9
2796     static unsigned char tagicon-mask_bits[] = {
2797        0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2798        0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2800 set rectdata {
2801     #define headicon_width 13
2802     #define headicon_height 9
2803     static unsigned char headicon_bits[] = {
2804        0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2805        0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2807 set rectmask {
2808     #define headicon-mask_width 13
2809     #define headicon-mask_height 9
2810     static unsigned char headicon-mask_bits[] = {
2811        0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2812        0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2814 image create bitmap reficon-H -background black -foreground green \
2815     -data $rectdata -maskdata $rectmask
2816 image create bitmap reficon-o -background black -foreground "#ddddff" \
2817     -data $rectdata -maskdata $rectmask
2819 proc init_flist {first} {
2820     global cflist cflist_top difffilestart
2822     $cflist conf -state normal
2823     $cflist delete 0.0 end
2824     if {$first ne {}} {
2825         $cflist insert end $first
2826         set cflist_top 1
2827         $cflist tag add highlight 1.0 "1.0 lineend"
2828     } else {
2829         catch {unset cflist_top}
2830     }
2831     $cflist conf -state disabled
2832     set difffilestart {}
2835 proc highlight_tag {f} {
2836     global highlight_paths
2838     foreach p $highlight_paths {
2839         if {[string match $p $f]} {
2840             return "bold"
2841         }
2842     }
2843     return {}
2846 proc highlight_filelist {} {
2847     global cmitmode cflist
2849     $cflist conf -state normal
2850     if {$cmitmode ne "tree"} {
2851         set end [lindex [split [$cflist index end] .] 0]
2852         for {set l 2} {$l < $end} {incr l} {
2853             set line [$cflist get $l.0 "$l.0 lineend"]
2854             if {[highlight_tag $line] ne {}} {
2855                 $cflist tag add bold $l.0 "$l.0 lineend"
2856             }
2857         }
2858     } else {
2859         highlight_tree 2 {}
2860     }
2861     $cflist conf -state disabled
2864 proc unhighlight_filelist {} {
2865     global cflist
2867     $cflist conf -state normal
2868     $cflist tag remove bold 1.0 end
2869     $cflist conf -state disabled
2872 proc add_flist {fl} {
2873     global cflist
2875     $cflist conf -state normal
2876     foreach f $fl {
2877         $cflist insert end "\n"
2878         $cflist insert end $f [highlight_tag $f]
2879     }
2880     $cflist conf -state disabled
2883 proc sel_flist {w x y} {
2884     global ctext difffilestart cflist cflist_top cmitmode
2886     if {$cmitmode eq "tree"} return
2887     if {![info exists cflist_top]} return
2888     set l [lindex [split [$w index "@$x,$y"] "."] 0]
2889     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2890     $cflist tag add highlight $l.0 "$l.0 lineend"
2891     set cflist_top $l
2892     if {$l == 1} {
2893         $ctext yview 1.0
2894     } else {
2895         catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2896     }
2899 proc pop_flist_menu {w X Y x y} {
2900     global ctext cflist cmitmode flist_menu flist_menu_file
2901     global treediffs diffids
2903     stopfinding
2904     set l [lindex [split [$w index "@$x,$y"] "."] 0]
2905     if {$l <= 1} return
2906     if {$cmitmode eq "tree"} {
2907         set e [linetoelt $l]
2908         if {[string index $e end] eq "/"} return
2909     } else {
2910         set e [lindex $treediffs($diffids) [expr {$l-2}]]
2911     }
2912     set flist_menu_file $e
2913     set xdiffstate "normal"
2914     if {$cmitmode eq "tree"} {
2915         set xdiffstate "disabled"
2916     }
2917     # Disable "External diff" item in tree mode
2918     $flist_menu entryconf 2 -state $xdiffstate
2919     tk_popup $flist_menu $X $Y
2922 proc flist_hl {only} {
2923     global flist_menu_file findstring gdttype
2925     set x [shellquote $flist_menu_file]
2926     if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
2927         set findstring $x
2928     } else {
2929         append findstring " " $x
2930     }
2931     set gdttype [mc "touching paths:"]
2934 proc save_file_from_commit {filename output what} {
2935     global nullfile
2937     if {[catch {exec git show $filename -- > $output} err]} {
2938         if {[string match "fatal: bad revision *" $err]} {
2939             return $nullfile
2940         }
2941         error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
2942         return {}
2943     }
2944     return $output
2947 proc external_diff_get_one_file {diffid filename diffdir} {
2948     global nullid nullid2 nullfile
2949     global gitdir
2951     if {$diffid == $nullid} {
2952         set difffile [file join [file dirname $gitdir] $filename]
2953         if {[file exists $difffile]} {
2954             return $difffile
2955         }
2956         return $nullfile
2957     }
2958     if {$diffid == $nullid2} {
2959         set difffile [file join $diffdir "\[index\] [file tail $filename]"]
2960         return [save_file_from_commit :$filename $difffile index]
2961     }
2962     set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
2963     return [save_file_from_commit $diffid:$filename $difffile \
2964                "revision $diffid"]
2967 proc external_diff {} {
2968     global gitktmpdir nullid nullid2
2969     global flist_menu_file
2970     global diffids
2971     global diffnum
2972     global gitdir extdifftool
2974     if {[llength $diffids] == 1} {
2975         # no reference commit given
2976         set diffidto [lindex $diffids 0]
2977         if {$diffidto eq $nullid} {
2978             # diffing working copy with index
2979             set diffidfrom $nullid2
2980         } elseif {$diffidto eq $nullid2} {
2981             # diffing index with HEAD
2982             set diffidfrom "HEAD"
2983         } else {
2984             # use first parent commit
2985             global parentlist selectedline
2986             set diffidfrom [lindex $parentlist $selectedline 0]
2987         }
2988     } else {
2989         set diffidfrom [lindex $diffids 0]
2990         set diffidto [lindex $diffids 1]
2991     }
2993     # make sure that several diffs wont collide
2994     if {![info exists gitktmpdir]} {
2995         set gitktmpdir [file join [file dirname $gitdir] \
2996                             [format ".gitk-tmp.%s" [pid]]]
2997         if {[catch {file mkdir $gitktmpdir} err]} {
2998             error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
2999             unset gitktmpdir
3000             return
3001         }
3002         set diffnum 0
3003     }
3004     incr diffnum
3005     set diffdir [file join $gitktmpdir $diffnum]
3006     if {[catch {file mkdir $diffdir} err]} {
3007         error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3008         return
3009     }
3011     # gather files to diff
3012     set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3013     set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3015     if {$difffromfile ne {} && $difftofile ne {}} {
3016         set cmd [concat | [shellsplit $extdifftool] \
3017                      [list $difffromfile $difftofile]]
3018         if {[catch {set fl [open $cmd r]} err]} {
3019             file delete -force $diffdir
3020             error_popup "$extdifftool: [mc "command failed:"] $err"
3021         } else {
3022             fconfigure $fl -blocking 0
3023             filerun $fl [list delete_at_eof $fl $diffdir]
3024         }
3025     }
3028 proc external_blame {parent_idx} {
3029     global flist_menu_file
3030     global nullid nullid2
3031     global parentlist selectedline currentid
3033     if {$parent_idx > 0} {
3034         set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3035     } else {
3036         set base_commit $currentid
3037     }
3039     if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3040         error_popup [mc "No such commit"]
3041         return
3042     }
3044     if {[catch {exec git gui blame $base_commit $flist_menu_file &} err]} {
3045         error_popup "[mc "git gui blame: command failed:"] $err"
3046     }
3049 # delete $dir when we see eof on $f (presumably because the child has exited)
3050 proc delete_at_eof {f dir} {
3051     while {[gets $f line] >= 0} {}
3052     if {[eof $f]} {
3053         if {[catch {close $f} err]} {
3054             error_popup "[mc "External diff viewer failed:"] $err"
3055         }
3056         file delete -force $dir
3057         return 0
3058     }
3059     return 1
3062 # Functions for adding and removing shell-type quoting
3064 proc shellquote {str} {
3065     if {![string match "*\['\"\\ \t]*" $str]} {
3066         return $str
3067     }
3068     if {![string match "*\['\"\\]*" $str]} {
3069         return "\"$str\""
3070     }
3071     if {![string match "*'*" $str]} {
3072         return "'$str'"
3073     }
3074     return "\"[string map {\" \\\" \\ \\\\} $str]\""
3077 proc shellarglist {l} {
3078     set str {}
3079     foreach a $l {
3080         if {$str ne {}} {
3081             append str " "
3082         }
3083         append str [shellquote $a]
3084     }
3085     return $str
3088 proc shelldequote {str} {
3089     set ret {}
3090     set used -1
3091     while {1} {
3092         incr used
3093         if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3094             append ret [string range $str $used end]
3095             set used [string length $str]
3096             break
3097         }
3098         set first [lindex $first 0]
3099         set ch [string index $str $first]
3100         if {$first > $used} {
3101             append ret [string range $str $used [expr {$first - 1}]]
3102             set used $first
3103         }
3104         if {$ch eq " " || $ch eq "\t"} break
3105         incr used
3106         if {$ch eq "'"} {
3107             set first [string first "'" $str $used]
3108             if {$first < 0} {
3109                 error "unmatched single-quote"
3110             }
3111             append ret [string range $str $used [expr {$first - 1}]]
3112             set used $first
3113             continue
3114         }
3115         if {$ch eq "\\"} {
3116             if {$used >= [string length $str]} {
3117                 error "trailing backslash"
3118             }
3119             append ret [string index $str $used]
3120             continue
3121         }
3122         # here ch == "\""
3123         while {1} {
3124             if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3125                 error "unmatched double-quote"
3126             }
3127             set first [lindex $first 0]
3128             set ch [string index $str $first]
3129             if {$first > $used} {
3130                 append ret [string range $str $used [expr {$first - 1}]]
3131                 set used $first
3132             }
3133             if {$ch eq "\""} break
3134             incr used
3135             append ret [string index $str $used]
3136             incr used
3137         }
3138     }
3139     return [list $used $ret]
3142 proc shellsplit {str} {
3143     set l {}
3144     while {1} {
3145         set str [string trimleft $str]
3146         if {$str eq {}} break
3147         set dq [shelldequote $str]
3148         set n [lindex $dq 0]
3149         set word [lindex $dq 1]
3150         set str [string range $str $n end]
3151         lappend l $word
3152     }
3153     return $l
3156 # Code to implement multiple views
3158 proc newview {ishighlight} {
3159     global nextviewnum newviewname newviewperm newishighlight
3160     global newviewargs revtreeargs viewargscmd newviewargscmd curview
3162     set newishighlight $ishighlight
3163     set top .gitkview
3164     if {[winfo exists $top]} {
3165         raise $top
3166         return
3167     }
3168     set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3169     set newviewperm($nextviewnum) 0
3170     set newviewargs($nextviewnum) [shellarglist $revtreeargs]
3171     set newviewargscmd($nextviewnum) $viewargscmd($curview)
3172     vieweditor $top $nextviewnum [mc "Gitk view definition"]
3175 proc editview {} {
3176     global curview
3177     global viewname viewperm newviewname newviewperm
3178     global viewargs newviewargs viewargscmd newviewargscmd
3180     set top .gitkvedit-$curview
3181     if {[winfo exists $top]} {
3182         raise $top
3183         return
3184     }
3185     set newviewname($curview) $viewname($curview)
3186     set newviewperm($curview) $viewperm($curview)
3187     set newviewargs($curview) [shellarglist $viewargs($curview)]
3188     set newviewargscmd($curview) $viewargscmd($curview)
3189     vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3192 proc vieweditor {top n title} {
3193     global newviewname newviewperm viewfiles bgcolor
3195     toplevel $top
3196     wm title $top $title
3197     label $top.nl -text [mc "Name"]
3198     entry $top.name -width 20 -textvariable newviewname($n)
3199     grid $top.nl $top.name -sticky w -pady 5
3200     checkbutton $top.perm -text [mc "Remember this view"] \
3201         -variable newviewperm($n)
3202     grid $top.perm - -pady 5 -sticky w
3203     message $top.al -aspect 1000 \
3204         -text [mc "Commits to include (arguments to git log):"]
3205     grid $top.al - -sticky w -pady 5
3206     entry $top.args -width 50 -textvariable newviewargs($n) \
3207         -background $bgcolor
3208     grid $top.args - -sticky ew -padx 5
3210     message $top.ac -aspect 1000 \
3211         -text [mc "Command to generate more commits to include:"]
3212     grid $top.ac - -sticky w -pady 5
3213     entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
3214         -background white
3215     grid $top.argscmd - -sticky ew -padx 5
3217     message $top.l -aspect 1000 \
3218         -text [mc "Enter files and directories to include, one per line:"]
3219     grid $top.l - -sticky w
3220     text $top.t -width 40 -height 10 -background $bgcolor -font uifont
3221     if {[info exists viewfiles($n)]} {
3222         foreach f $viewfiles($n) {
3223             $top.t insert end $f
3224             $top.t insert end "\n"
3225         }
3226         $top.t delete {end - 1c} end
3227         $top.t mark set insert 0.0
3228     }
3229     grid $top.t - -sticky ew -padx 5
3230     frame $top.buts
3231     button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3232     button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3233     grid $top.buts.ok $top.buts.can
3234     grid columnconfigure $top.buts 0 -weight 1 -uniform a
3235     grid columnconfigure $top.buts 1 -weight 1 -uniform a
3236     grid $top.buts - -pady 10 -sticky ew
3237     focus $top.t
3240 proc doviewmenu {m first cmd op argv} {
3241     set nmenu [$m index end]
3242     for {set i $first} {$i <= $nmenu} {incr i} {
3243         if {[$m entrycget $i -command] eq $cmd} {
3244             eval $m $op $i $argv
3245             break
3246         }
3247     }
3250 proc allviewmenus {n op args} {
3251     # global viewhlmenu
3253     doviewmenu .bar.view 5 [list showview $n] $op $args
3254     # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3257 proc newviewok {top n} {
3258     global nextviewnum newviewperm newviewname newishighlight
3259     global viewname viewfiles viewperm selectedview curview
3260     global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
3262     if {[catch {
3263         set newargs [shellsplit $newviewargs($n)]
3264     } err]} {
3265         error_popup "[mc "Error in commit selection arguments:"] $err"
3266         wm raise $top
3267         focus $top
3268         return
3269     }
3270     set files {}
3271     foreach f [split [$top.t get 0.0 end] "\n"] {
3272         set ft [string trim $f]
3273         if {$ft ne {}} {
3274             lappend files $ft
3275         }
3276     }
3277     if {![info exists viewfiles($n)]} {
3278         # creating a new view
3279         incr nextviewnum
3280         set viewname($n) $newviewname($n)
3281         set viewperm($n) $newviewperm($n)
3282         set viewfiles($n) $files
3283         set viewargs($n) $newargs
3284         set viewargscmd($n) $newviewargscmd($n)
3285         addviewmenu $n
3286         if {!$newishighlight} {
3287             run showview $n
3288         } else {
3289             run addvhighlight $n
3290         }
3291     } else {
3292         # editing an existing view
3293         set viewperm($n) $newviewperm($n)
3294         if {$newviewname($n) ne $viewname($n)} {
3295             set viewname($n) $newviewname($n)
3296             doviewmenu .bar.view 5 [list showview $n] \
3297                 entryconf [list -label $viewname($n)]
3298             # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3299                 # entryconf [list -label $viewname($n) -value $viewname($n)]
3300         }
3301         if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3302                 $newviewargscmd($n) ne $viewargscmd($n)} {
3303             set viewfiles($n) $files
3304             set viewargs($n) $newargs
3305             set viewargscmd($n) $newviewargscmd($n)
3306             if {$curview == $n} {
3307                 run reloadcommits
3308             }
3309         }
3310     }
3311     catch {destroy $top}
3314 proc delview {} {
3315     global curview viewperm hlview selectedhlview
3317     if {$curview == 0} return
3318     if {[info exists hlview] && $hlview == $curview} {
3319         set selectedhlview [mc "None"]
3320         unset hlview
3321     }
3322     allviewmenus $curview delete
3323     set viewperm($curview) 0
3324     showview 0
3327 proc addviewmenu {n} {
3328     global viewname viewhlmenu
3330     .bar.view add radiobutton -label $viewname($n) \
3331         -command [list showview $n] -variable selectedview -value $n
3332     #$viewhlmenu add radiobutton -label $viewname($n) \
3333     #   -command [list addvhighlight $n] -variable selectedhlview
3336 proc showview {n} {
3337     global curview cached_commitrow ordertok
3338     global displayorder parentlist rowidlist rowisopt rowfinal
3339     global colormap rowtextx nextcolor canvxmax
3340     global numcommits viewcomplete
3341     global selectedline currentid canv canvy0
3342     global treediffs
3343     global pending_select mainheadid
3344     global commitidx
3345     global selectedview
3346     global hlview selectedhlview commitinterest
3348     if {$n == $curview} return
3349     set selid {}
3350     set ymax [lindex [$canv cget -scrollregion] 3]
3351     set span [$canv yview]
3352     set ytop [expr {[lindex $span 0] * $ymax}]
3353     set ybot [expr {[lindex $span 1] * $ymax}]
3354     set yscreen [expr {($ybot - $ytop) / 2}]
3355     if {$selectedline ne {}} {
3356         set selid $currentid
3357         set y [yc $selectedline]
3358         if {$ytop < $y && $y < $ybot} {
3359             set yscreen [expr {$y - $ytop}]
3360         }
3361     } elseif {[info exists pending_select]} {
3362         set selid $pending_select
3363         unset pending_select
3364     }
3365     unselectline
3366     normalline
3367     catch {unset treediffs}
3368     clear_display
3369     if {[info exists hlview] && $hlview == $n} {
3370         unset hlview
3371         set selectedhlview [mc "None"]
3372     }
3373     catch {unset commitinterest}
3374     catch {unset cached_commitrow}
3375     catch {unset ordertok}
3377     set curview $n
3378     set selectedview $n
3379     .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3380     .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3382     run refill_reflist
3383     if {![info exists viewcomplete($n)]} {
3384         getcommits $selid
3385         return
3386     }
3388     set displayorder {}
3389     set parentlist {}
3390     set rowidlist {}
3391     set rowisopt {}
3392     set rowfinal {}
3393     set numcommits $commitidx($n)
3395     catch {unset colormap}
3396     catch {unset rowtextx}
3397     set nextcolor 0
3398     set canvxmax [$canv cget -width]
3399     set curview $n
3400     set row 0
3401     setcanvscroll
3402     set yf 0
3403     set row {}
3404     if {$selid ne {} && [commitinview $selid $n]} {
3405         set row [rowofcommit $selid]
3406         # try to get the selected row in the same position on the screen
3407         set ymax [lindex [$canv cget -scrollregion] 3]
3408         set ytop [expr {[yc $row] - $yscreen}]
3409         if {$ytop < 0} {
3410             set ytop 0
3411         }
3412         set yf [expr {$ytop * 1.0 / $ymax}]
3413     }
3414     allcanvs yview moveto $yf
3415     drawvisible
3416     if {$row ne {}} {
3417         selectline $row 0
3418     } elseif {!$viewcomplete($n)} {
3419         reset_pending_select $selid
3420     } else {
3421         reset_pending_select {}
3423         if {[commitinview $pending_select $curview]} {
3424             selectline [rowofcommit $pending_select] 1
3425         } else {
3426             set row [first_real_row]
3427             if {$row < $numcommits} {
3428                 selectline $row 0
3429             }
3430         }
3431     }
3432     if {!$viewcomplete($n)} {
3433         if {$numcommits == 0} {
3434             show_status [mc "Reading commits..."]
3435         }
3436     } elseif {$numcommits == 0} {
3437         show_status [mc "No commits selected"]
3438     }
3441 # Stuff relating to the highlighting facility
3443 proc ishighlighted {id} {
3444     global vhighlights fhighlights nhighlights rhighlights
3446     if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3447         return $nhighlights($id)
3448     }
3449     if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
3450         return $vhighlights($id)
3451     }
3452     if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
3453         return $fhighlights($id)
3454     }
3455     if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
3456         return $rhighlights($id)
3457     }
3458     return 0
3461 proc bolden {row font} {
3462     global canv linehtag selectedline boldrows
3464     lappend boldrows $row
3465     $canv itemconf $linehtag($row) -font $font
3466     if {$row == $selectedline} {
3467         $canv delete secsel
3468         set t [eval $canv create rect [$canv bbox $linehtag($row)] \
3469                    -outline {{}} -tags secsel \
3470                    -fill [$canv cget -selectbackground]]
3471         $canv lower $t
3472     }
3475 proc bolden_name {row font} {
3476     global canv2 linentag selectedline boldnamerows
3478     lappend boldnamerows $row
3479     $canv2 itemconf $linentag($row) -font $font
3480     if {$row == $selectedline} {
3481         $canv2 delete secsel
3482         set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
3483                    -outline {{}} -tags secsel \
3484                    -fill [$canv2 cget -selectbackground]]
3485         $canv2 lower $t
3486     }
3489 proc unbolden {} {
3490     global boldrows
3492     set stillbold {}
3493     foreach row $boldrows {
3494         if {![ishighlighted [commitonrow $row]]} {
3495             bolden $row mainfont
3496         } else {
3497             lappend stillbold $row
3498         }
3499     }
3500     set boldrows $stillbold
3503 proc addvhighlight {n} {
3504     global hlview viewcomplete curview vhl_done commitidx
3506     if {[info exists hlview]} {
3507         delvhighlight
3508     }
3509     set hlview $n
3510     if {$n != $curview && ![info exists viewcomplete($n)]} {
3511         start_rev_list $n
3512     }
3513     set vhl_done $commitidx($hlview)
3514     if {$vhl_done > 0} {
3515         drawvisible
3516     }
3519 proc delvhighlight {} {
3520     global hlview vhighlights
3522     if {![info exists hlview]} return
3523     unset hlview
3524     catch {unset vhighlights}
3525     unbolden
3528 proc vhighlightmore {} {
3529     global hlview vhl_done commitidx vhighlights curview
3531     set max $commitidx($hlview)
3532     set vr [visiblerows]
3533     set r0 [lindex $vr 0]
3534     set r1 [lindex $vr 1]
3535     for {set i $vhl_done} {$i < $max} {incr i} {
3536         set id [commitonrow $i $hlview]
3537         if {[commitinview $id $curview]} {
3538             set row [rowofcommit $id]
3539             if {$r0 <= $row && $row <= $r1} {
3540                 if {![highlighted $row]} {
3541                     bolden $row mainfontbold
3542                 }
3543                 set vhighlights($id) 1
3544             }
3545         }
3546     }
3547     set vhl_done $max
3548     return 0
3551 proc askvhighlight {row id} {
3552     global hlview vhighlights iddrawn
3554     if {[commitinview $id $hlview]} {
3555         if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
3556             bolden $row mainfontbold
3557         }
3558         set vhighlights($id) 1
3559     } else {
3560         set vhighlights($id) 0
3561     }
3564 proc hfiles_change {} {
3565     global highlight_files filehighlight fhighlights fh_serial
3566     global highlight_paths gdttype
3568     if {[info exists filehighlight]} {
3569         # delete previous highlights
3570         catch {close $filehighlight}
3571         unset filehighlight
3572         catch {unset fhighlights}
3573         unbolden
3574         unhighlight_filelist
3575     }
3576     set highlight_paths {}
3577     after cancel do_file_hl $fh_serial
3578     incr fh_serial
3579     if {$highlight_files ne {}} {
3580         after 300 do_file_hl $fh_serial
3581     }
3584 proc gdttype_change {name ix op} {
3585     global gdttype highlight_files findstring findpattern
3587     stopfinding
3588     if {$findstring ne {}} {
3589         if {$gdttype eq [mc "containing:"]} {
3590             if {$highlight_files ne {}} {
3591                 set highlight_files {}
3592                 hfiles_change
3593             }
3594             findcom_change
3595         } else {
3596             if {$findpattern ne {}} {
3597                 set findpattern {}
3598                 findcom_change
3599             }
3600             set highlight_files $findstring
3601             hfiles_change
3602         }
3603         drawvisible
3604     }
3605     # enable/disable findtype/findloc menus too
3608 proc find_change {name ix op} {
3609     global gdttype findstring highlight_files
3611     stopfinding
3612     if {$gdttype eq [mc "containing:"]} {
3613         findcom_change
3614     } else {
3615         if {$highlight_files ne $findstring} {
3616             set highlight_files $findstring
3617             hfiles_change
3618         }
3619     }
3620     drawvisible
3623 proc findcom_change args {
3624     global nhighlights boldnamerows
3625     global findpattern findtype findstring gdttype
3627     stopfinding
3628     # delete previous highlights, if any
3629     foreach row $boldnamerows {
3630         bolden_name $row mainfont
3631     }
3632     set boldnamerows {}
3633     catch {unset nhighlights}
3634     unbolden
3635     unmarkmatches
3636     if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
3637         set findpattern {}
3638     } elseif {$findtype eq [mc "Regexp"]} {
3639         set findpattern $findstring
3640     } else {
3641         set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
3642                    $findstring]
3643         set findpattern "*$e*"
3644     }
3647 proc makepatterns {l} {
3648     set ret {}
3649     foreach e $l {
3650         set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
3651         if {[string index $ee end] eq "/"} {
3652             lappend ret "$ee*"
3653         } else {
3654             lappend ret $ee
3655             lappend ret "$ee/*"
3656         }
3657     }
3658     return $ret
3661 proc do_file_hl {serial} {
3662     global highlight_files filehighlight highlight_paths gdttype fhl_list
3664     if {$gdttype eq [mc "touching paths:"]} {
3665         if {[catch {set paths [shellsplit $highlight_files]}]} return
3666         set highlight_paths [makepatterns $paths]
3667         highlight_filelist
3668         set gdtargs [concat -- $paths]
3669     } elseif {$gdttype eq [mc "adding/removing string:"]} {
3670         set gdtargs [list "-S$highlight_files"]
3671     } else {
3672         # must be "containing:", i.e. we're searching commit info
3673         return
3674     }
3675     set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3676     set filehighlight [open $cmd r+]
3677     fconfigure $filehighlight -blocking 0
3678     filerun $filehighlight readfhighlight
3679     set fhl_list {}
3680     drawvisible
3681     flushhighlights
3684 proc flushhighlights {} {
3685     global filehighlight fhl_list
3687     if {[info exists filehighlight]} {
3688         lappend fhl_list {}
3689         puts $filehighlight ""
3690         flush $filehighlight
3691     }
3694 proc askfilehighlight {row id} {
3695     global filehighlight fhighlights fhl_list
3697     lappend fhl_list $id
3698     set fhighlights($id) -1
3699     puts $filehighlight $id
3702 proc readfhighlight {} {
3703     global filehighlight fhighlights curview iddrawn
3704     global fhl_list find_dirn
3706     if {![info exists filehighlight]} {
3707         return 0
3708     }
3709     set nr 0
3710     while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3711         set line [string trim $line]
3712         set i [lsearch -exact $fhl_list $line]
3713         if {$i < 0} continue
3714         for {set j 0} {$j < $i} {incr j} {
3715             set id [lindex $fhl_list $j]
3716             set fhighlights($id) 0
3717         }
3718         set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3719         if {$line eq {}} continue
3720         if {![commitinview $line $curview]} continue
3721         set row [rowofcommit $line]
3722         if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
3723             bolden $row mainfontbold
3724         }
3725         set fhighlights($line) 1
3726     }
3727     if {[eof $filehighlight]} {
3728         # strange...
3729         puts "oops, git diff-tree died"
3730         catch {close $filehighlight}
3731         unset filehighlight
3732         return 0
3733     }
3734     if {[info exists find_dirn]} {
3735         run findmore
3736     }
3737     return 1
3740 proc doesmatch {f} {
3741     global findtype findpattern
3743     if {$findtype eq [mc "Regexp"]} {
3744         return [regexp $findpattern $f]
3745     } elseif {$findtype eq [mc "IgnCase"]} {
3746         return [string match -nocase $findpattern $f]
3747     } else {
3748         return [string match $findpattern $f]
3749     }
3752 proc askfindhighlight {row id} {
3753     global nhighlights commitinfo iddrawn
3754     global findloc
3755     global markingmatches
3757     if {![info exists commitinfo($id)]} {
3758         getcommit $id
3759     }
3760     set info $commitinfo($id)
3761     set isbold 0
3762     set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
3763     foreach f $info ty $fldtypes {
3764         if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
3765             [doesmatch $f]} {
3766             if {$ty eq [mc "Author"]} {
3767                 set isbold 2
3768                 break
3769             }
3770             set isbold 1
3771         }
3772     }
3773     if {$isbold && [info exists iddrawn($id)]} {
3774         if {![ishighlighted $id]} {
3775             bolden $row mainfontbold
3776             if {$isbold > 1} {
3777                 bolden_name $row mainfontbold
3778             }
3779         }
3780         if {$markingmatches} {
3781             markrowmatches $row $id
3782         }
3783     }
3784     set nhighlights($id) $isbold
3787 proc markrowmatches {row id} {
3788     global canv canv2 linehtag linentag commitinfo findloc
3790     set headline [lindex $commitinfo($id) 0]
3791     set author [lindex $commitinfo($id) 1]
3792     $canv delete match$row
3793     $canv2 delete match$row
3794     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
3795         set m [findmatches $headline]
3796         if {$m ne {}} {
3797             markmatches $canv $row $headline $linehtag($row) $m \
3798                 [$canv itemcget $linehtag($row) -font] $row
3799         }
3800     }
3801     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
3802         set m [findmatches $author]
3803         if {$m ne {}} {
3804             markmatches $canv2 $row $author $linentag($row) $m \
3805                 [$canv2 itemcget $linentag($row) -font] $row
3806         }
3807     }
3810 proc vrel_change {name ix op} {
3811     global highlight_related
3813     rhighlight_none
3814     if {$highlight_related ne [mc "None"]} {
3815         run drawvisible
3816     }
3819 # prepare for testing whether commits are descendents or ancestors of a
3820 proc rhighlight_sel {a} {
3821     global descendent desc_todo ancestor anc_todo
3822     global highlight_related
3824     catch {unset descendent}
3825     set desc_todo [list $a]
3826     catch {unset ancestor}
3827     set anc_todo [list $a]
3828     if {$highlight_related ne [mc "None"]} {
3829         rhighlight_none
3830         run drawvisible
3831     }
3834 proc rhighlight_none {} {
3835     global rhighlights
3837     catch {unset rhighlights}
3838     unbolden
3841 proc is_descendent {a} {
3842     global curview children descendent desc_todo
3844     set v $curview
3845     set la [rowofcommit $a]
3846     set todo $desc_todo
3847     set leftover {}
3848     set done 0
3849     for {set i 0} {$i < [llength $todo]} {incr i} {
3850         set do [lindex $todo $i]
3851         if {[rowofcommit $do] < $la} {
3852             lappend leftover $do
3853             continue
3854         }
3855         foreach nk $children($v,$do) {
3856             if {![info exists descendent($nk)]} {
3857                 set descendent($nk) 1
3858                 lappend todo $nk
3859                 if {$nk eq $a} {
3860                     set done 1
3861                 }
3862             }
3863         }
3864         if {$done} {
3865             set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3866             return
3867         }
3868     }
3869     set descendent($a) 0
3870     set desc_todo $leftover
3873 proc is_ancestor {a} {
3874     global curview parents ancestor anc_todo
3876     set v $curview
3877     set la [rowofcommit $a]
3878     set todo $anc_todo
3879     set leftover {}
3880     set done 0
3881     for {set i 0} {$i < [llength $todo]} {incr i} {
3882         set do [lindex $todo $i]
3883         if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3884             lappend leftover $do
3885             continue
3886         }
3887         foreach np $parents($v,$do) {
3888             if {![info exists ancestor($np)]} {
3889                 set ancestor($np) 1
3890                 lappend todo $np
3891                 if {$np eq $a} {
3892                     set done 1
3893                 }
3894             }
3895         }
3896         if {$done} {
3897             set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3898             return
3899         }
3900     }
3901     set ancestor($a) 0
3902     set anc_todo $leftover
3905 proc askrelhighlight {row id} {
3906     global descendent highlight_related iddrawn rhighlights
3907     global selectedline ancestor
3909     if {$selectedline eq {}} return
3910     set isbold 0
3911     if {$highlight_related eq [mc "Descendant"] ||
3912         $highlight_related eq [mc "Not descendant"]} {
3913         if {![info exists descendent($id)]} {
3914             is_descendent $id
3915         }
3916         if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
3917             set isbold 1
3918         }
3919     } elseif {$highlight_related eq [mc "Ancestor"] ||
3920               $highlight_related eq [mc "Not ancestor"]} {
3921         if {![info exists ancestor($id)]} {
3922             is_ancestor $id
3923         }
3924         if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
3925             set isbold 1
3926         }
3927     }
3928     if {[info exists iddrawn($id)]} {
3929         if {$isbold && ![ishighlighted $id]} {
3930             bolden $row mainfontbold
3931         }
3932     }
3933     set rhighlights($id) $isbold
3936 # Graph layout functions
3938 proc shortids {ids} {
3939     set res {}
3940     foreach id $ids {
3941         if {[llength $id] > 1} {
3942             lappend res [shortids $id]
3943         } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3944             lappend res [string range $id 0 7]
3945         } else {
3946             lappend res $id
3947         }
3948     }
3949     return $res
3952 proc ntimes {n o} {
3953     set ret {}
3954     set o [list $o]
3955     for {set mask 1} {$mask <= $n} {incr mask $mask} {
3956         if {($n & $mask) != 0} {
3957             set ret [concat $ret $o]
3958         }
3959         set o [concat $o $o]
3960     }
3961     return $ret
3964 proc ordertoken {id} {
3965     global ordertok curview varcid varcstart varctok curview parents children
3966     global nullid nullid2
3968     if {[info exists ordertok($id)]} {
3969         return $ordertok($id)
3970     }
3971     set origid $id
3972     set todo {}
3973     while {1} {
3974         if {[info exists varcid($curview,$id)]} {
3975             set a $varcid($curview,$id)
3976             set p [lindex $varcstart($curview) $a]
3977         } else {
3978             set p [lindex $children($curview,$id) 0]
3979         }
3980         if {[info exists ordertok($p)]} {
3981             set tok $ordertok($p)
3982             break
3983         }
3984         set id [first_real_child $curview,$p]
3985         if {$id eq {}} {
3986             # it's a root
3987             set tok [lindex $varctok($curview) $varcid($curview,$p)]
3988             break
3989         }
3990         if {[llength $parents($curview,$id)] == 1} {
3991             lappend todo [list $p {}]
3992         } else {
3993             set j [lsearch -exact $parents($curview,$id) $p]
3994             if {$j < 0} {
3995                 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3996             }
3997             lappend todo [list $p [strrep $j]]
3998         }
3999     }
4000     for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4001         set p [lindex $todo $i 0]
4002         append tok [lindex $todo $i 1]
4003         set ordertok($p) $tok
4004     }
4005     set ordertok($origid) $tok
4006     return $tok
4009 # Work out where id should go in idlist so that order-token
4010 # values increase from left to right
4011 proc idcol {idlist id {i 0}} {
4012     set t [ordertoken $id]
4013     if {$i < 0} {
4014         set i 0
4015     }
4016     if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4017         if {$i > [llength $idlist]} {
4018             set i [llength $idlist]
4019         }
4020         while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4021         incr i
4022     } else {
4023         if {$t > [ordertoken [lindex $idlist $i]]} {
4024             while {[incr i] < [llength $idlist] &&
4025                    $t >= [ordertoken [lindex $idlist $i]]} {}
4026         }
4027     }
4028     return $i
4031 proc initlayout {} {
4032     global rowidlist rowisopt rowfinal displayorder parentlist
4033     global numcommits canvxmax canv
4034     global nextcolor
4035     global colormap rowtextx
4037     set numcommits 0
4038     set displayorder {}
4039     set parentlist {}
4040     set nextcolor 0
4041     set rowidlist {}
4042     set rowisopt {}
4043     set rowfinal {}
4044     set canvxmax [$canv cget -width]
4045     catch {unset colormap}
4046     catch {unset rowtextx}
4047     setcanvscroll
4050 proc setcanvscroll {} {
4051     global canv canv2 canv3 numcommits linespc canvxmax canvy0
4052     global lastscrollset lastscrollrows
4054     set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4055     $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4056     $canv2 conf -scrollregion [list 0 0 0 $ymax]
4057     $canv3 conf -scrollregion [list 0 0 0 $ymax]
4058     set lastscrollset [clock clicks -milliseconds]
4059     set lastscrollrows $numcommits
4062 proc visiblerows {} {
4063     global canv numcommits linespc
4065     set ymax [lindex [$canv cget -scrollregion] 3]
4066     if {$ymax eq {} || $ymax == 0} return
4067     set f [$canv yview]
4068     set y0 [expr {int([lindex $f 0] * $ymax)}]
4069     set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4070     if {$r0 < 0} {
4071         set r0 0
4072     }
4073     set y1 [expr {int([lindex $f 1] * $ymax)}]
4074     set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4075     if {$r1 >= $numcommits} {
4076         set r1 [expr {$numcommits - 1}]
4077     }
4078     return [list $r0 $r1]
4081 proc layoutmore {} {
4082     global commitidx viewcomplete curview
4083     global numcommits pending_select curview
4084     global lastscrollset lastscrollrows commitinterest
4086     if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4087         [clock clicks -milliseconds] - $lastscrollset > 500} {
4088         setcanvscroll
4089     }
4090     if {[info exists pending_select] &&
4091         [commitinview $pending_select $curview]} {
4092         update
4093         selectline [rowofcommit $pending_select] 1
4094     }
4095     drawvisible
4098 proc doshowlocalchanges {} {
4099     global curview mainheadid
4101     if {$mainheadid eq {}} return
4102     if {[commitinview $mainheadid $curview]} {
4103         dodiffindex
4104     } else {
4105         lappend commitinterest($mainheadid) {dodiffindex}
4106     }
4109 proc dohidelocalchanges {} {
4110     global nullid nullid2 lserial curview
4112     if {[commitinview $nullid $curview]} {
4113         removefakerow $nullid
4114     }
4115     if {[commitinview $nullid2 $curview]} {
4116         removefakerow $nullid2
4117     }
4118     incr lserial
4121 # spawn off a process to do git diff-index --cached HEAD
4122 proc dodiffindex {} {
4123     global lserial showlocalchanges
4124     global isworktree
4126     if {!$showlocalchanges || !$isworktree} return
4127     incr lserial
4128     set fd [open "|git diff-index --cached HEAD" r]
4129     fconfigure $fd -blocking 0
4130     set i [reg_instance $fd]
4131     filerun $fd [list readdiffindex $fd $lserial $i]
4134 proc readdiffindex {fd serial inst} {
4135     global mainheadid nullid nullid2 curview commitinfo commitdata lserial
4137     set isdiff 1
4138     if {[gets $fd line] < 0} {
4139         if {![eof $fd]} {
4140             return 1
4141         }
4142         set isdiff 0
4143     }
4144     # we only need to see one line and we don't really care what it says...
4145     stop_instance $inst
4147     if {$serial != $lserial} {
4148         return 0
4149     }
4151     # now see if there are any local changes not checked in to the index
4152     set fd [open "|git diff-files" r]
4153     fconfigure $fd -blocking 0
4154     set i [reg_instance $fd]
4155     filerun $fd [list readdifffiles $fd $serial $i]
4157     if {$isdiff && ![commitinview $nullid2 $curview]} {
4158         # add the line for the changes in the index to the graph
4159         set hl [mc "Local changes checked in to index but not committed"]
4160         set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
4161         set commitdata($nullid2) "\n    $hl\n"
4162         if {[commitinview $nullid $curview]} {
4163             removefakerow $nullid
4164         }
4165         insertfakerow $nullid2 $mainheadid
4166     } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4167         removefakerow $nullid2
4168     }
4169     return 0
4172 proc readdifffiles {fd serial inst} {
4173     global mainheadid nullid nullid2 curview
4174     global commitinfo commitdata lserial
4176     set isdiff 1
4177     if {[gets $fd line] < 0} {
4178         if {![eof $fd]} {
4179             return 1
4180         }
4181         set isdiff 0
4182     }
4183     # we only need to see one line and we don't really care what it says...
4184     stop_instance $inst
4186     if {$serial != $lserial} {
4187         return 0
4188     }
4190     if {$isdiff && ![commitinview $nullid $curview]} {
4191         # add the line for the local diff to the graph
4192         set hl [mc "Local uncommitted changes, not checked in to index"]
4193         set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
4194         set commitdata($nullid) "\n    $hl\n"
4195         if {[commitinview $nullid2 $curview]} {
4196             set p $nullid2
4197         } else {
4198             set p $mainheadid
4199         }
4200         insertfakerow $nullid $p
4201     } elseif {!$isdiff && [commitinview $nullid $curview]} {
4202         removefakerow $nullid
4203     }
4204     return 0
4207 proc nextuse {id row} {
4208     global curview children
4210     if {[info exists children($curview,$id)]} {
4211         foreach kid $children($curview,$id) {
4212             if {![commitinview $kid $curview]} {
4213                 return -1
4214             }
4215             if {[rowofcommit $kid] > $row} {
4216                 return [rowofcommit $kid]
4217             }
4218         }
4219     }
4220     if {[commitinview $id $curview]} {
4221         return [rowofcommit $id]
4222     }
4223     return -1
4226 proc prevuse {id row} {
4227     global curview children
4229     set ret -1
4230     if {[info exists children($curview,$id)]} {
4231         foreach kid $children($curview,$id) {
4232             if {![commitinview $kid $curview]} break
4233             if {[rowofcommit $kid] < $row} {
4234                 set ret [rowofcommit $kid]
4235             }
4236         }
4237     }
4238     return $ret
4241 proc make_idlist {row} {
4242     global displayorder parentlist uparrowlen downarrowlen mingaplen
4243     global commitidx curview children
4245     set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4246     if {$r < 0} {
4247         set r 0
4248     }
4249     set ra [expr {$row - $downarrowlen}]
4250     if {$ra < 0} {
4251         set ra 0
4252     }
4253     set rb [expr {$row + $uparrowlen}]
4254     if {$rb > $commitidx($curview)} {
4255         set rb $commitidx($curview)
4256     }
4257     make_disporder $r [expr {$rb + 1}]
4258     set ids {}
4259     for {} {$r < $ra} {incr r} {
4260         set nextid [lindex $displayorder [expr {$r + 1}]]
4261         foreach p [lindex $parentlist $r] {
4262             if {$p eq $nextid} continue
4263             set rn [nextuse $p $r]
4264             if {$rn >= $row &&
4265                 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4266                 lappend ids [list [ordertoken $p] $p]
4267             }
4268         }
4269     }
4270     for {} {$r < $row} {incr r} {
4271         set nextid [lindex $displayorder [expr {$r + 1}]]
4272         foreach p [lindex $parentlist $r] {
4273             if {$p eq $nextid} continue
4274             set rn [nextuse $p $r]
4275             if {$rn < 0 || $rn >= $row} {
4276                 lappend ids [list [ordertoken $p] $p]
4277             }
4278         }
4279     }
4280     set id [lindex $displayorder $row]
4281     lappend ids [list [ordertoken $id] $id]
4282     while {$r < $rb} {
4283         foreach p [lindex $parentlist $r] {
4284             set firstkid [lindex $children($curview,$p) 0]
4285             if {[rowofcommit $firstkid] < $row} {
4286                 lappend ids [list [ordertoken $p] $p]
4287             }
4288         }
4289         incr r
4290         set id [lindex $displayorder $r]
4291         if {$id ne {}} {
4292             set firstkid [lindex $children($curview,$id) 0]
4293             if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4294                 lappend ids [list [ordertoken $id] $id]
4295             }
4296         }
4297     }
4298     set idlist {}
4299     foreach idx [lsort -unique $ids] {
4300         lappend idlist [lindex $idx 1]
4301     }
4302     return $idlist
4305 proc rowsequal {a b} {
4306     while {[set i [lsearch -exact $a {}]] >= 0} {
4307         set a [lreplace $a $i $i]
4308     }
4309     while {[set i [lsearch -exact $b {}]] >= 0} {
4310         set b [lreplace $b $i $i]
4311     }
4312     return [expr {$a eq $b}]
4315 proc makeupline {id row rend col} {
4316     global rowidlist uparrowlen downarrowlen mingaplen
4318     for {set r $rend} {1} {set r $rstart} {
4319         set rstart [prevuse $id $r]
4320         if {$rstart < 0} return
4321         if {$rstart < $row} break
4322     }
4323     if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4324         set rstart [expr {$rend - $uparrowlen - 1}]
4325     }
4326     for {set r $rstart} {[incr r] <= $row} {} {
4327         set idlist [lindex $rowidlist $r]
4328         if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4329             set col [idcol $idlist $id $col]
4330             lset rowidlist $r [linsert $idlist $col $id]
4331             changedrow $r
4332         }
4333     }
4336 proc layoutrows {row endrow} {
4337     global rowidlist rowisopt rowfinal displayorder
4338     global uparrowlen downarrowlen maxwidth mingaplen
4339     global children parentlist
4340     global commitidx viewcomplete curview
4342     make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4343     set idlist {}
4344     if {$row > 0} {
4345         set rm1 [expr {$row - 1}]
4346         foreach id [lindex $rowidlist $rm1] {
4347             if {$id ne {}} {
4348                 lappend idlist $id
4349             }
4350         }
4351         set final [lindex $rowfinal $rm1]
4352     }
4353     for {} {$row < $endrow} {incr row} {
4354         set rm1 [expr {$row - 1}]
4355         if {$rm1 < 0 || $idlist eq {}} {
4356             set idlist [make_idlist $row]
4357             set final 1
4358         } else {
4359             set id [lindex $displayorder $rm1]
4360             set col [lsearch -exact $idlist $id]
4361             set idlist [lreplace $idlist $col $col]
4362             foreach p [lindex $parentlist $rm1] {
4363                 if {[lsearch -exact $idlist $p] < 0} {
4364                     set col [idcol $idlist $p $col]
4365                     set idlist [linsert $idlist $col $p]
4366                     # if not the first child, we have to insert a line going up
4367                     if {$id ne [lindex $children($curview,$p) 0]} {
4368                         makeupline $p $rm1 $row $col
4369                     }
4370                 }
4371             }
4372             set id [lindex $displayorder $row]
4373             if {$row > $downarrowlen} {
4374                 set termrow [expr {$row - $downarrowlen - 1}]
4375                 foreach p [lindex $parentlist $termrow] {
4376                     set i [lsearch -exact $idlist $p]
4377                     if {$i < 0} continue
4378                     set nr [nextuse $p $termrow]
4379                     if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4380                         set idlist [lreplace $idlist $i $i]
4381                     }
4382                 }
4383             }
4384             set col [lsearch -exact $idlist $id]
4385             if {$col < 0} {
4386                 set col [idcol $idlist $id]
4387                 set idlist [linsert $idlist $col $id]
4388                 if {$children($curview,$id) ne {}} {
4389                     makeupline $id $rm1 $row $col
4390                 }
4391             }
4392             set r [expr {$row + $uparrowlen - 1}]
4393             if {$r < $commitidx($curview)} {
4394                 set x $col
4395                 foreach p [lindex $parentlist $r] {
4396                     if {[lsearch -exact $idlist $p] >= 0} continue
4397                     set fk [lindex $children($curview,$p) 0]
4398                     if {[rowofcommit $fk] < $row} {
4399                         set x [idcol $idlist $p $x]
4400                         set idlist [linsert $idlist $x $p]
4401                     }
4402                 }
4403                 if {[incr r] < $commitidx($curview)} {
4404                     set p [lindex $displayorder $r]
4405                     if {[lsearch -exact $idlist $p] < 0} {
4406                         set fk [lindex $children($curview,$p) 0]
4407                         if {$fk ne {} && [rowofcommit $fk] < $row} {
4408                             set x [idcol $idlist $p $x]
4409                             set idlist [linsert $idlist $x $p]
4410                         }
4411                     }
4412                 }
4413             }
4414         }
4415         if {$final && !$viewcomplete($curview) &&
4416             $row + $uparrowlen + $mingaplen + $downarrowlen
4417                 >= $commitidx($curview)} {
4418             set final 0
4419         }
4420         set l [llength $rowidlist]
4421         if {$row == $l} {
4422             lappend rowidlist $idlist
4423             lappend rowisopt 0
4424             lappend rowfinal $final
4425         } elseif {$row < $l} {
4426             if {![rowsequal $idlist [lindex $rowidlist $row]]} {
4427                 lset rowidlist $row $idlist
4428                 changedrow $row
4429             }
4430             lset rowfinal $row $final
4431         } else {
4432             set pad [ntimes [expr {$row - $l}] {}]
4433             set rowidlist [concat $rowidlist $pad]
4434             lappend rowidlist $idlist
4435             set rowfinal [concat $rowfinal $pad]
4436             lappend rowfinal $final
4437             set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
4438         }
4439     }
4440     return $row
4443 proc changedrow {row} {
4444     global displayorder iddrawn rowisopt need_redisplay
4446     set l [llength $rowisopt]
4447     if {$row < $l} {
4448         lset rowisopt $row 0
4449         if {$row + 1 < $l} {
4450             lset rowisopt [expr {$row + 1}] 0
4451             if {$row + 2 < $l} {
4452                 lset rowisopt [expr {$row + 2}] 0
4453             }
4454         }
4455     }
4456     set id [lindex $displayorder $row]
4457     if {[info exists iddrawn($id)]} {
4458         set need_redisplay 1
4459     }
4462 proc insert_pad {row col npad} {
4463     global rowidlist
4465     set pad [ntimes $npad {}]
4466     set idlist [lindex $rowidlist $row]
4467     set bef [lrange $idlist 0 [expr {$col - 1}]]
4468     set aft [lrange $idlist $col end]
4469     set i [lsearch -exact $aft {}]
4470     if {$i > 0} {
4471         set aft [lreplace $aft $i $i]
4472     }
4473     lset rowidlist $row [concat $bef $pad $aft]
4474     changedrow $row
4477 proc optimize_rows {row col endrow} {
4478     global rowidlist rowisopt displayorder curview children
4480     if {$row < 1} {
4481         set row 1
4482     }
4483     for {} {$row < $endrow} {incr row; set col 0} {
4484         if {[lindex $rowisopt $row]} continue
4485         set haspad 0
4486         set y0 [expr {$row - 1}]
4487         set ym [expr {$row - 2}]
4488         set idlist [lindex $rowidlist $row]
4489         set previdlist [lindex $rowidlist $y0]
4490         if {$idlist eq {} || $previdlist eq {}} continue
4491         if {$ym >= 0} {
4492             set pprevidlist [lindex $rowidlist $ym]
4493             if {$pprevidlist eq {}} continue
4494         } else {
4495             set pprevidlist {}
4496         }
4497         set x0 -1
4498         set xm -1
4499         for {} {$col < [llength $idlist]} {incr col} {
4500             set id [lindex $idlist $col]
4501             if {[lindex $previdlist $col] eq $id} continue
4502             if {$id eq {}} {
4503                 set haspad 1
4504                 continue
4505             }
4506             set x0 [lsearch -exact $previdlist $id]
4507             if {$x0 < 0} continue
4508             set z [expr {$x0 - $col}]
4509             set isarrow 0
4510             set z0 {}
4511             if {$ym >= 0} {
4512                 set xm [lsearch -exact $pprevidlist $id]
4513                 if {$xm >= 0} {
4514                     set z0 [expr {$xm - $x0}]
4515                 }
4516             }
4517             if {$z0 eq {}} {
4518                 # if row y0 is the first child of $id then it's not an arrow
4519                 if {[lindex $children($curview,$id) 0] ne
4520                     [lindex $displayorder $y0]} {
4521                     set isarrow 1
4522                 }
4523             }
4524             if {!$isarrow && $id ne [lindex $displayorder $row] &&
4525                 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
4526                 set isarrow 1
4527             }
4528             # Looking at lines from this row to the previous row,
4529             # make them go straight up if they end in an arrow on
4530             # the previous row; otherwise make them go straight up
4531             # or at 45 degrees.
4532             if {$z < -1 || ($z < 0 && $isarrow)} {
4533                 # Line currently goes left too much;
4534                 # insert pads in the previous row, then optimize it
4535                 set npad [expr {-1 - $z + $isarrow}]
4536                 insert_pad $y0 $x0 $npad
4537                 if {$y0 > 0} {
4538                     optimize_rows $y0 $x0 $row
4539                 }
4540                 set previdlist [lindex $rowidlist $y0]
4541                 set x0 [lsearch -exact $previdlist $id]
4542                 set z [expr {$x0 - $col}]
4543                 if {$z0 ne {}} {
4544                     set pprevidlist [lindex $rowidlist $ym]
4545                     set xm [lsearch -exact $pprevidlist $id]
4546                     set z0 [expr {$xm - $x0}]
4547                 }
4548             } elseif {$z > 1 || ($z > 0 && $isarrow)} {
4549                 # Line currently goes right too much;
4550                 # insert pads in this line
4551                 set npad [expr {$z - 1 + $isarrow}]
4552                 insert_pad $row $col $npad
4553                 set idlist [lindex $rowidlist $row]
4554                 incr col $npad
4555                 set z [expr {$x0 - $col}]
4556                 set haspad 1
4557             }
4558             if {$z0 eq {} && !$isarrow && $ym >= 0} {
4559                 # this line links to its first child on row $row-2
4560                 set id [lindex $displayorder $ym]
4561                 set xc [lsearch -exact $pprevidlist $id]
4562                 if {$xc >= 0} {
4563                     set z0 [expr {$xc - $x0}]
4564                 }
4565             }
4566             # avoid lines jigging left then immediately right
4567             if {$z0 ne {} && $z < 0 && $z0 > 0} {
4568                 insert_pad $y0 $x0 1
4569                 incr x0
4570                 optimize_rows $y0 $x0 $row
4571                 set previdlist [lindex $rowidlist $y0]
4572             }
4573         }
4574         if {!$haspad} {
4575             # Find the first column that doesn't have a line going right
4576             for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
4577                 set id [lindex $idlist $col]
4578                 if {$id eq {}} break
4579                 set x0 [lsearch -exact $previdlist $id]
4580                 if {$x0 < 0} {
4581                     # check if this is the link to the first child
4582                     set kid [lindex $displayorder $y0]
4583                     if {[lindex $children($curview,$id) 0] eq $kid} {
4584                         # it is, work out offset to child
4585                         set x0 [lsearch -exact $previdlist $kid]
4586                     }
4587                 }
4588                 if {$x0 <= $col} break
4589             }
4590             # Insert a pad at that column as long as it has a line and
4591             # isn't the last column
4592             if {$x0 >= 0 && [incr col] < [llength $idlist]} {
4593                 set idlist [linsert $idlist $col {}]
4594                 lset rowidlist $row $idlist
4595                 changedrow $row
4596             }
4597         }
4598     }
4601 proc xc {row col} {
4602     global canvx0 linespc
4603     return [expr {$canvx0 + $col * $linespc}]
4606 proc yc {row} {
4607     global canvy0 linespc
4608     return [expr {$canvy0 + $row * $linespc}]
4611 proc linewidth {id} {
4612     global thickerline lthickness
4614     set wid $lthickness
4615     if {[info exists thickerline] && $id eq $thickerline} {
4616         set wid [expr {2 * $lthickness}]
4617     }
4618     return $wid
4621 proc rowranges {id} {
4622     global curview children uparrowlen downarrowlen
4623     global rowidlist
4625     set kids $children($curview,$id)
4626     if {$kids eq {}} {
4627         return {}
4628     }
4629     set ret {}
4630     lappend kids $id
4631     foreach child $kids {
4632         if {![commitinview $child $curview]} break
4633         set row [rowofcommit $child]
4634         if {![info exists prev]} {
4635             lappend ret [expr {$row + 1}]
4636         } else {
4637             if {$row <= $prevrow} {
4638                 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
4639             }
4640             # see if the line extends the whole way from prevrow to row
4641             if {$row > $prevrow + $uparrowlen + $downarrowlen &&
4642                 [lsearch -exact [lindex $rowidlist \
4643                             [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
4644                 # it doesn't, see where it ends
4645                 set r [expr {$prevrow + $downarrowlen}]
4646                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4647                     while {[incr r -1] > $prevrow &&
4648                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4649                 } else {
4650                     while {[incr r] <= $row &&
4651                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4652                     incr r -1
4653                 }
4654                 lappend ret $r
4655                 # see where it starts up again
4656                 set r [expr {$row - $uparrowlen}]
4657                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4658                     while {[incr r] < $row &&
4659                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4660                 } else {
4661                     while {[incr r -1] >= $prevrow &&
4662                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4663                     incr r
4664                 }
4665                 lappend ret $r
4666             }
4667         }
4668         if {$child eq $id} {
4669             lappend ret $row
4670         }
4671         set prev $child
4672         set prevrow $row
4673     }
4674     return $ret
4677 proc drawlineseg {id row endrow arrowlow} {
4678     global rowidlist displayorder iddrawn linesegs
4679     global canv colormap linespc curview maxlinelen parentlist
4681     set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4682     set le [expr {$row + 1}]
4683     set arrowhigh 1
4684     while {1} {
4685         set c [lsearch -exact [lindex $rowidlist $le] $id]
4686         if {$c < 0} {
4687             incr le -1
4688             break
4689         }
4690         lappend cols $c
4691         set x [lindex $displayorder $le]
4692         if {$x eq $id} {
4693             set arrowhigh 0
4694             break
4695         }
4696         if {[info exists iddrawn($x)] || $le == $endrow} {
4697             set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4698             if {$c >= 0} {
4699                 lappend cols $c
4700                 set arrowhigh 0
4701             }
4702             break
4703         }
4704         incr le
4705     }
4706     if {$le <= $row} {
4707         return $row
4708     }
4710     set lines {}
4711     set i 0
4712     set joinhigh 0
4713     if {[info exists linesegs($id)]} {
4714         set lines $linesegs($id)
4715         foreach li $lines {
4716             set r0 [lindex $li 0]
4717             if {$r0 > $row} {
4718                 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4719                     set joinhigh 1
4720                 }
4721                 break
4722             }
4723             incr i
4724         }
4725     }
4726     set joinlow 0
4727     if {$i > 0} {
4728         set li [lindex $lines [expr {$i-1}]]
4729         set r1 [lindex $li 1]
4730         if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4731             set joinlow 1
4732         }
4733     }
4735     set x [lindex $cols [expr {$le - $row}]]
4736     set xp [lindex $cols [expr {$le - 1 - $row}]]
4737     set dir [expr {$xp - $x}]
4738     if {$joinhigh} {
4739         set ith [lindex $lines $i 2]
4740         set coords [$canv coords $ith]
4741         set ah [$canv itemcget $ith -arrow]
4742         set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4743         set x2 [lindex $cols [expr {$le + 1 - $row}]]
4744         if {$x2 ne {} && $x - $x2 == $dir} {
4745             set coords [lrange $coords 0 end-2]
4746         }
4747     } else {
4748         set coords [list [xc $le $x] [yc $le]]
4749     }
4750     if {$joinlow} {
4751         set itl [lindex $lines [expr {$i-1}] 2]
4752         set al [$canv itemcget $itl -arrow]
4753         set arrowlow [expr {$al eq "last" || $al eq "both"}]
4754     } elseif {$arrowlow} {
4755         if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4756             [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4757             set arrowlow 0
4758         }
4759     }
4760     set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4761     for {set y $le} {[incr y -1] > $row} {} {
4762         set x $xp
4763         set xp [lindex $cols [expr {$y - 1 - $row}]]
4764         set ndir [expr {$xp - $x}]
4765         if {$dir != $ndir || $xp < 0} {
4766             lappend coords [xc $y $x] [yc $y]
4767         }
4768         set dir $ndir
4769     }
4770     if {!$joinlow} {
4771         if {$xp < 0} {
4772             # join parent line to first child
4773             set ch [lindex $displayorder $row]
4774             set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4775             if {$xc < 0} {
4776                 puts "oops: drawlineseg: child $ch not on row $row"
4777             } elseif {$xc != $x} {
4778                 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4779                     set d [expr {int(0.5 * $linespc)}]
4780                     set x1 [xc $row $x]
4781                     if {$xc < $x} {
4782                         set x2 [expr {$x1 - $d}]
4783                     } else {
4784                         set x2 [expr {$x1 + $d}]
4785                     }
4786                     set y2 [yc $row]
4787                     set y1 [expr {$y2 + $d}]
4788                     lappend coords $x1 $y1 $x2 $y2
4789                 } elseif {$xc < $x - 1} {
4790                     lappend coords [xc $row [expr {$x-1}]] [yc $row]
4791                 } elseif {$xc > $x + 1} {
4792                     lappend coords [xc $row [expr {$x+1}]] [yc $row]
4793                 }
4794                 set x $xc
4795             }
4796             lappend coords [xc $row $x] [yc $row]
4797         } else {
4798             set xn [xc $row $xp]
4799             set yn [yc $row]
4800             lappend coords $xn $yn
4801         }
4802         if {!$joinhigh} {
4803             assigncolor $id
4804             set t [$canv create line $coords -width [linewidth $id] \
4805                        -fill $colormap($id) -tags lines.$id -arrow $arrow]
4806             $canv lower $t
4807             bindline $t $id
4808             set lines [linsert $lines $i [list $row $le $t]]
4809         } else {
4810             $canv coords $ith $coords
4811             if {$arrow ne $ah} {
4812                 $canv itemconf $ith -arrow $arrow
4813             }
4814             lset lines $i 0 $row
4815         }
4816     } else {
4817         set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4818         set ndir [expr {$xo - $xp}]
4819         set clow [$canv coords $itl]
4820         if {$dir == $ndir} {
4821             set clow [lrange $clow 2 end]
4822         }
4823         set coords [concat $coords $clow]
4824         if {!$joinhigh} {
4825             lset lines [expr {$i-1}] 1 $le
4826         } else {
4827             # coalesce two pieces
4828             $canv delete $ith
4829             set b [lindex $lines [expr {$i-1}] 0]
4830             set e [lindex $lines $i 1]
4831             set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4832         }
4833         $canv coords $itl $coords
4834         if {$arrow ne $al} {
4835             $canv itemconf $itl -arrow $arrow
4836         }
4837     }
4839     set linesegs($id) $lines
4840     return $le
4843 proc drawparentlinks {id row} {
4844     global rowidlist canv colormap curview parentlist
4845     global idpos linespc
4847     set rowids [lindex $rowidlist $row]
4848     set col [lsearch -exact $rowids $id]
4849     if {$col < 0} return
4850     set olds [lindex $parentlist $row]
4851     set row2 [expr {$row + 1}]
4852     set x [xc $row $col]
4853     set y [yc $row]
4854     set y2 [yc $row2]
4855     set d [expr {int(0.5 * $linespc)}]
4856     set ymid [expr {$y + $d}]
4857     set ids [lindex $rowidlist $row2]
4858     # rmx = right-most X coord used
4859     set rmx 0
4860     foreach p $olds {
4861         set i [lsearch -exact $ids $p]
4862         if {$i < 0} {
4863             puts "oops, parent $p of $id not in list"
4864             continue
4865         }
4866         set x2 [xc $row2 $i]
4867         if {$x2 > $rmx} {
4868             set rmx $x2
4869         }
4870         set j [lsearch -exact $rowids $p]
4871         if {$j < 0} {
4872             # drawlineseg will do this one for us
4873             continue
4874         }
4875         assigncolor $p
4876         # should handle duplicated parents here...
4877         set coords [list $x $y]
4878         if {$i != $col} {
4879             # if attaching to a vertical segment, draw a smaller
4880             # slant for visual distinctness
4881             if {$i == $j} {
4882                 if {$i < $col} {
4883                     lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4884                 } else {
4885                     lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4886                 }
4887             } elseif {$i < $col && $i < $j} {
4888                 # segment slants towards us already
4889                 lappend coords [xc $row $j] $y
4890             } else {
4891                 if {$i < $col - 1} {
4892                     lappend coords [expr {$x2 + $linespc}] $y
4893                 } elseif {$i > $col + 1} {
4894                     lappend coords [expr {$x2 - $linespc}] $y
4895                 }
4896                 lappend coords $x2 $y2
4897             }
4898         } else {
4899             lappend coords $x2 $y2
4900         }
4901         set t [$canv create line $coords -width [linewidth $p] \
4902                    -fill $colormap($p) -tags lines.$p]
4903         $canv lower $t
4904         bindline $t $p
4905     }
4906     if {$rmx > [lindex $idpos($id) 1]} {
4907         lset idpos($id) 1 $rmx
4908         redrawtags $id
4909     }
4912 proc drawlines {id} {
4913     global canv
4915     $canv itemconf lines.$id -width [linewidth $id]
4918 proc drawcmittext {id row col} {
4919     global linespc canv canv2 canv3 fgcolor curview
4920     global cmitlisted commitinfo rowidlist parentlist
4921     global rowtextx idpos idtags idheads idotherrefs
4922     global linehtag linentag linedtag selectedline
4923     global canvxmax boldrows boldnamerows fgcolor
4924     global mainheadid nullid nullid2 circleitem circlecolors ctxbut
4926     # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
4927     set listed $cmitlisted($curview,$id)
4928     if {$id eq $nullid} {
4929         set ofill red
4930     } elseif {$id eq $nullid2} {
4931         set ofill green
4932     } elseif {$id eq $mainheadid} {
4933         set ofill yellow
4934     } else {
4935         set ofill [lindex $circlecolors $listed]
4936     }
4937     set x [xc $row $col]
4938     set y [yc $row]
4939     set orad [expr {$linespc / 3}]
4940     if {$listed <= 2} {
4941         set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4942                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4943                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
4944     } elseif {$listed == 3} {
4945         # triangle pointing left for left-side commits
4946         set t [$canv create polygon \
4947                    [expr {$x - $orad}] $y \
4948                    [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4949                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4950                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
4951     } else {
4952         # triangle pointing right for right-side commits
4953         set t [$canv create polygon \
4954                    [expr {$x + $orad - 1}] $y \
4955                    [expr {$x - $orad}] [expr {$y - $orad}] \
4956                    [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4957                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
4958     }
4959     set circleitem($row) $t
4960     $canv raise $t
4961     $canv bind $t <1> {selcanvline {} %x %y}
4962     set rmx [llength [lindex $rowidlist $row]]
4963     set olds [lindex $parentlist $row]
4964     if {$olds ne {}} {
4965         set nextids [lindex $rowidlist [expr {$row + 1}]]
4966         foreach p $olds {
4967             set i [lsearch -exact $nextids $p]
4968             if {$i > $rmx} {
4969                 set rmx $i
4970             }
4971         }
4972     }
4973     set xt [xc $row $rmx]
4974     set rowtextx($row) $xt
4975     set idpos($id) [list $x $xt $y]
4976     if {[info exists idtags($id)] || [info exists idheads($id)]
4977         || [info exists idotherrefs($id)]} {
4978         set xt [drawtags $id $x $xt $y]
4979     }
4980     set headline [lindex $commitinfo($id) 0]
4981     set name [lindex $commitinfo($id) 1]
4982     set date [lindex $commitinfo($id) 2]
4983     set date [formatdate $date]
4984     set font mainfont
4985     set nfont mainfont
4986     set isbold [ishighlighted $id]
4987     if {$isbold > 0} {
4988         lappend boldrows $row
4989         set font mainfontbold
4990         if {$isbold > 1} {
4991             lappend boldnamerows $row
4992             set nfont mainfontbold
4993         }
4994     }
4995     set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4996                             -text $headline -font $font -tags text]
4997     $canv bind $linehtag($row) $ctxbut "rowmenu %X %Y $id"
4998     set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4999                             -text $name -font $nfont -tags text]
5000     set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5001                             -text $date -font mainfont -tags text]
5002     if {$selectedline == $row} {
5003         make_secsel $row
5004     }
5005     set xr [expr {$xt + [font measure $font $headline]}]
5006     if {$xr > $canvxmax} {
5007         set canvxmax $xr
5008         setcanvscroll
5009     }
5012 proc drawcmitrow {row} {
5013     global displayorder rowidlist nrows_drawn
5014     global iddrawn markingmatches
5015     global commitinfo numcommits
5016     global filehighlight fhighlights findpattern nhighlights
5017     global hlview vhighlights
5018     global highlight_related rhighlights
5020     if {$row >= $numcommits} return
5022     set id [lindex $displayorder $row]
5023     if {[info exists hlview] && ![info exists vhighlights($id)]} {
5024         askvhighlight $row $id
5025     }
5026     if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5027         askfilehighlight $row $id
5028     }
5029     if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5030         askfindhighlight $row $id
5031     }
5032     if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5033         askrelhighlight $row $id
5034     }
5035     if {![info exists iddrawn($id)]} {
5036         set col [lsearch -exact [lindex $rowidlist $row] $id]
5037         if {$col < 0} {
5038             puts "oops, row $row id $id not in list"
5039             return
5040         }
5041         if {![info exists commitinfo($id)]} {
5042             getcommit $id
5043         }
5044         assigncolor $id
5045         drawcmittext $id $row $col
5046         set iddrawn($id) 1
5047         incr nrows_drawn
5048     }
5049     if {$markingmatches} {
5050         markrowmatches $row $id
5051     }
5054 proc drawcommits {row {endrow {}}} {
5055     global numcommits iddrawn displayorder curview need_redisplay
5056     global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5058     if {$row < 0} {
5059         set row 0
5060     }
5061     if {$endrow eq {}} {
5062         set endrow $row
5063     }
5064     if {$endrow >= $numcommits} {
5065         set endrow [expr {$numcommits - 1}]
5066     }
5068     set rl1 [expr {$row - $downarrowlen - 3}]
5069     if {$rl1 < 0} {
5070         set rl1 0
5071     }
5072     set ro1 [expr {$row - 3}]
5073     if {$ro1 < 0} {
5074         set ro1 0
5075     }
5076     set r2 [expr {$endrow + $uparrowlen + 3}]
5077     if {$r2 > $numcommits} {
5078         set r2 $numcommits
5079     }
5080     for {set r $rl1} {$r < $r2} {incr r} {
5081         if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5082             if {$rl1 < $r} {
5083                 layoutrows $rl1 $r
5084             }
5085             set rl1 [expr {$r + 1}]
5086         }
5087     }
5088     if {$rl1 < $r} {
5089         layoutrows $rl1 $r
5090     }
5091     optimize_rows $ro1 0 $r2
5092     if {$need_redisplay || $nrows_drawn > 2000} {
5093         clear_display
5094         drawvisible
5095     }
5097     # make the lines join to already-drawn rows either side
5098     set r [expr {$row - 1}]
5099     if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5100         set r $row
5101     }
5102     set er [expr {$endrow + 1}]
5103     if {$er >= $numcommits ||
5104         ![info exists iddrawn([lindex $displayorder $er])]} {
5105         set er $endrow
5106     }
5107     for {} {$r <= $er} {incr r} {
5108         set id [lindex $displayorder $r]
5109         set wasdrawn [info exists iddrawn($id)]
5110         drawcmitrow $r
5111         if {$r == $er} break
5112         set nextid [lindex $displayorder [expr {$r + 1}]]
5113         if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5114         drawparentlinks $id $r
5116         set rowids [lindex $rowidlist $r]
5117         foreach lid $rowids {
5118             if {$lid eq {}} continue
5119             if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5120             if {$lid eq $id} {
5121                 # see if this is the first child of any of its parents
5122                 foreach p [lindex $parentlist $r] {
5123                     if {[lsearch -exact $rowids $p] < 0} {
5124                         # make this line extend up to the child
5125                         set lineend($p) [drawlineseg $p $r $er 0]
5126                     }
5127                 }
5128             } else {
5129                 set lineend($lid) [drawlineseg $lid $r $er 1]
5130             }
5131         }
5132     }
5135 proc undolayout {row} {
5136     global uparrowlen mingaplen downarrowlen
5137     global rowidlist rowisopt rowfinal need_redisplay
5139     set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5140     if {$r < 0} {
5141         set r 0
5142     }
5143     if {[llength $rowidlist] > $r} {
5144         incr r -1
5145         set rowidlist [lrange $rowidlist 0 $r]
5146         set rowfinal [lrange $rowfinal 0 $r]
5147         set rowisopt [lrange $rowisopt 0 $r]
5148         set need_redisplay 1
5149         run drawvisible
5150     }
5153 proc drawvisible {} {
5154     global canv linespc curview vrowmod selectedline targetrow targetid
5155     global need_redisplay cscroll numcommits
5157     set fs [$canv yview]
5158     set ymax [lindex [$canv cget -scrollregion] 3]
5159     if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5160     set f0 [lindex $fs 0]
5161     set f1 [lindex $fs 1]
5162     set y0 [expr {int($f0 * $ymax)}]
5163     set y1 [expr {int($f1 * $ymax)}]
5165     if {[info exists targetid]} {
5166         if {[commitinview $targetid $curview]} {
5167             set r [rowofcommit $targetid]
5168             if {$r != $targetrow} {
5169                 # Fix up the scrollregion and change the scrolling position
5170                 # now that our target row has moved.
5171                 set diff [expr {($r - $targetrow) * $linespc}]
5172                 set targetrow $r
5173                 setcanvscroll
5174                 set ymax [lindex [$canv cget -scrollregion] 3]
5175                 incr y0 $diff
5176                 incr y1 $diff
5177                 set f0 [expr {$y0 / $ymax}]
5178                 set f1 [expr {$y1 / $ymax}]
5179                 allcanvs yview moveto $f0
5180                 $cscroll set $f0 $f1
5181                 set need_redisplay 1
5182             }
5183         } else {
5184             unset targetid
5185         }
5186     }
5188     set row [expr {int(($y0 - 3) / $linespc) - 1}]
5189     set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5190     if {$endrow >= $vrowmod($curview)} {
5191         update_arcrows $curview
5192     }
5193     if {$selectedline ne {} &&
5194         $row <= $selectedline && $selectedline <= $endrow} {
5195         set targetrow $selectedline
5196     } elseif {[info exists targetid]} {
5197         set targetrow [expr {int(($row + $endrow) / 2)}]
5198     }
5199     if {[info exists targetrow]} {
5200         if {$targetrow >= $numcommits} {
5201             set targetrow [expr {$numcommits - 1}]
5202         }
5203         set targetid [commitonrow $targetrow]
5204     }
5205     drawcommits $row $endrow
5208 proc clear_display {} {
5209     global iddrawn linesegs need_redisplay nrows_drawn
5210     global vhighlights fhighlights nhighlights rhighlights
5211     global linehtag linentag linedtag boldrows boldnamerows
5213     allcanvs delete all
5214     catch {unset iddrawn}
5215     catch {unset linesegs}
5216     catch {unset linehtag}
5217     catch {unset linentag}
5218     catch {unset linedtag}
5219     set boldrows {}
5220     set boldnamerows {}
5221     catch {unset vhighlights}
5222     catch {unset fhighlights}
5223     catch {unset nhighlights}
5224     catch {unset rhighlights}
5225     set need_redisplay 0
5226     set nrows_drawn 0
5229 proc findcrossings {id} {
5230     global rowidlist parentlist numcommits displayorder
5232     set cross {}
5233     set ccross {}
5234     foreach {s e} [rowranges $id] {
5235         if {$e >= $numcommits} {
5236             set e [expr {$numcommits - 1}]
5237         }
5238         if {$e <= $s} continue
5239         for {set row $e} {[incr row -1] >= $s} {} {
5240             set x [lsearch -exact [lindex $rowidlist $row] $id]
5241             if {$x < 0} break
5242             set olds [lindex $parentlist $row]
5243             set kid [lindex $displayorder $row]
5244             set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5245             if {$kidx < 0} continue
5246             set nextrow [lindex $rowidlist [expr {$row + 1}]]
5247             foreach p $olds {
5248                 set px [lsearch -exact $nextrow $p]
5249                 if {$px < 0} continue
5250                 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5251                     if {[lsearch -exact $ccross $p] >= 0} continue
5252                     if {$x == $px + ($kidx < $px? -1: 1)} {
5253                         lappend ccross $p
5254                     } elseif {[lsearch -exact $cross $p] < 0} {
5255                         lappend cross $p
5256                     }
5257                 }
5258             }
5259         }
5260     }
5261     return [concat $ccross {{}} $cross]
5264 proc assigncolor {id} {
5265     global colormap colors nextcolor
5266     global parents children children curview
5268     if {[info exists colormap($id)]} return
5269     set ncolors [llength $colors]
5270     if {[info exists children($curview,$id)]} {
5271         set kids $children($curview,$id)
5272     } else {
5273         set kids {}
5274     }
5275     if {[llength $kids] == 1} {
5276         set child [lindex $kids 0]
5277         if {[info exists colormap($child)]
5278             && [llength $parents($curview,$child)] == 1} {
5279             set colormap($id) $colormap($child)
5280             return
5281         }
5282     }
5283     set badcolors {}
5284     set origbad {}
5285     foreach x [findcrossings $id] {
5286         if {$x eq {}} {
5287             # delimiter between corner crossings and other crossings
5288             if {[llength $badcolors] >= $ncolors - 1} break
5289             set origbad $badcolors
5290         }
5291         if {[info exists colormap($x)]
5292             && [lsearch -exact $badcolors $colormap($x)] < 0} {
5293             lappend badcolors $colormap($x)
5294         }
5295     }
5296     if {[llength $badcolors] >= $ncolors} {
5297         set badcolors $origbad
5298     }
5299     set origbad $badcolors
5300     if {[llength $badcolors] < $ncolors - 1} {
5301         foreach child $kids {
5302             if {[info exists colormap($child)]
5303                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5304                 lappend badcolors $colormap($child)
5305             }
5306             foreach p $parents($curview,$child) {
5307                 if {[info exists colormap($p)]
5308                     && [lsearch -exact $badcolors $colormap($p)] < 0} {
5309                     lappend badcolors $colormap($p)
5310                 }
5311             }
5312         }
5313         if {[llength $badcolors] >= $ncolors} {
5314             set badcolors $origbad
5315         }
5316     }
5317     for {set i 0} {$i <= $ncolors} {incr i} {
5318         set c [lindex $colors $nextcolor]
5319         if {[incr nextcolor] >= $ncolors} {
5320             set nextcolor 0
5321         }
5322         if {[lsearch -exact $badcolors $c]} break
5323     }
5324     set colormap($id) $c
5327 proc bindline {t id} {
5328     global canv
5330     $canv bind $t <Enter> "lineenter %x %y $id"
5331     $canv bind $t <Motion> "linemotion %x %y $id"
5332     $canv bind $t <Leave> "lineleave $id"
5333     $canv bind $t <Button-1> "lineclick %x %y $id 1"
5336 proc drawtags {id x xt y1} {
5337     global idtags idheads idotherrefs mainhead
5338     global linespc lthickness
5339     global canv rowtextx curview fgcolor bgcolor ctxbut
5341     set marks {}
5342     set ntags 0
5343     set nheads 0
5344     if {[info exists idtags($id)]} {
5345         set marks $idtags($id)
5346         set ntags [llength $marks]
5347     }
5348     if {[info exists idheads($id)]} {
5349         set marks [concat $marks $idheads($id)]
5350         set nheads [llength $idheads($id)]
5351     }
5352     if {[info exists idotherrefs($id)]} {
5353         set marks [concat $marks $idotherrefs($id)]
5354     }
5355     if {$marks eq {}} {
5356         return $xt
5357     }
5359     set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5360     set yt [expr {$y1 - 0.5 * $linespc}]
5361     set yb [expr {$yt + $linespc - 1}]
5362     set xvals {}
5363     set wvals {}
5364     set i -1
5365     foreach tag $marks {
5366         incr i
5367         if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5368             set wid [font measure mainfontbold $tag]
5369         } else {
5370             set wid [font measure mainfont $tag]
5371         }
5372         lappend xvals $xt
5373         lappend wvals $wid
5374         set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5375     }
5376     set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5377                -width $lthickness -fill black -tags tag.$id]
5378     $canv lower $t
5379     foreach tag $marks x $xvals wid $wvals {
5380         set xl [expr {$x + $delta}]
5381         set xr [expr {$x + $delta + $wid + $lthickness}]
5382         set font mainfont
5383         if {[incr ntags -1] >= 0} {
5384             # draw a tag
5385             set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5386                        $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5387                        -width 1 -outline black -fill yellow -tags tag.$id]
5388             $canv bind $t <1> [list showtag $tag 1]
5389             set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5390         } else {
5391             # draw a head or other ref
5392             if {[incr nheads -1] >= 0} {
5393                 set col green
5394                 if {$tag eq $mainhead} {
5395                     set font mainfontbold
5396                 }
5397             } else {
5398                 set col "#ddddff"
5399             }
5400             set xl [expr {$xl - $delta/2}]
5401             $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
5402                 -width 1 -outline black -fill $col -tags tag.$id
5403             if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
5404                 set rwid [font measure mainfont $remoteprefix]
5405                 set xi [expr {$x + 1}]
5406                 set yti [expr {$yt + 1}]
5407                 set xri [expr {$x + $rwid}]
5408                 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
5409                         -width 0 -fill "#ffddaa" -tags tag.$id
5410             }
5411         }
5412         set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
5413                    -font $font -tags [list tag.$id text]]
5414         if {$ntags >= 0} {
5415             $canv bind $t <1> [list showtag $tag 1]
5416         } elseif {$nheads >= 0} {
5417             $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
5418         }
5419     }
5420     return $xt
5423 proc xcoord {i level ln} {
5424     global canvx0 xspc1 xspc2
5426     set x [expr {$canvx0 + $i * $xspc1($ln)}]
5427     if {$i > 0 && $i == $level} {
5428         set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
5429     } elseif {$i > $level} {
5430         set x [expr {$x + $xspc2 - $xspc1($ln)}]
5431     }
5432     return $x
5435 proc show_status {msg} {
5436     global canv fgcolor
5438     clear_display
5439     $canv create text 3 3 -anchor nw -text $msg -font mainfont \
5440         -tags text -fill $fgcolor
5443 # Don't change the text pane cursor if it is currently the hand cursor,
5444 # showing that we are over a sha1 ID link.
5445 proc settextcursor {c} {
5446     global ctext curtextcursor
5448     if {[$ctext cget -cursor] == $curtextcursor} {
5449         $ctext config -cursor $c
5450     }
5451     set curtextcursor $c
5454 proc nowbusy {what {name {}}} {
5455     global isbusy busyname statusw
5457     if {[array names isbusy] eq {}} {
5458         . config -cursor watch
5459         settextcursor watch
5460     }
5461     set isbusy($what) 1
5462     set busyname($what) $name
5463     if {$name ne {}} {
5464         $statusw conf -text $name
5465     }
5468 proc notbusy {what} {
5469     global isbusy maincursor textcursor busyname statusw
5471     catch {
5472         unset isbusy($what)
5473         if {$busyname($what) ne {} &&
5474             [$statusw cget -text] eq $busyname($what)} {
5475             $statusw conf -text {}
5476         }
5477     }
5478     if {[array names isbusy] eq {}} {
5479         . config -cursor $maincursor
5480         settextcursor $textcursor
5481     }
5484 proc findmatches {f} {
5485     global findtype findstring
5486     if {$findtype == [mc "Regexp"]} {
5487         set matches [regexp -indices -all -inline $findstring $f]
5488     } else {
5489         set fs $findstring
5490         if {$findtype == [mc "IgnCase"]} {
5491             set f [string tolower $f]
5492             set fs [string tolower $fs]
5493         }
5494         set matches {}
5495         set i 0
5496         set l [string length $fs]
5497         while {[set j [string first $fs $f $i]] >= 0} {
5498             lappend matches [list $j [expr {$j+$l-1}]]
5499             set i [expr {$j + $l}]
5500         }
5501     }
5502     return $matches
5505 proc dofind {{dirn 1} {wrap 1}} {
5506     global findstring findstartline findcurline selectedline numcommits
5507     global gdttype filehighlight fh_serial find_dirn findallowwrap
5509     if {[info exists find_dirn]} {
5510         if {$find_dirn == $dirn} return
5511         stopfinding
5512     }
5513     focus .
5514     if {$findstring eq {} || $numcommits == 0} return
5515     if {$selectedline eq {}} {
5516         set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
5517     } else {
5518         set findstartline $selectedline
5519     }
5520     set findcurline $findstartline
5521     nowbusy finding [mc "Searching"]
5522     if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
5523         after cancel do_file_hl $fh_serial
5524         do_file_hl $fh_serial
5525     }
5526     set find_dirn $dirn
5527     set findallowwrap $wrap
5528     run findmore
5531 proc stopfinding {} {
5532     global find_dirn findcurline fprogcoord
5534     if {[info exists find_dirn]} {
5535         unset find_dirn
5536         unset findcurline
5537         notbusy finding
5538         set fprogcoord 0
5539         adjustprogress
5540     }
5543 proc findmore {} {
5544     global commitdata commitinfo numcommits findpattern findloc
5545     global findstartline findcurline findallowwrap
5546     global find_dirn gdttype fhighlights fprogcoord
5547     global curview varcorder vrownum varccommits vrowmod
5549     if {![info exists find_dirn]} {
5550         return 0
5551     }
5552     set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
5553     set l $findcurline
5554     set moretodo 0
5555     if {$find_dirn > 0} {
5556         incr l
5557         if {$l >= $numcommits} {
5558             set l 0
5559         }
5560         if {$l <= $findstartline} {
5561             set lim [expr {$findstartline + 1}]
5562         } else {
5563             set lim $numcommits
5564             set moretodo $findallowwrap
5565         }
5566     } else {
5567         if {$l == 0} {
5568             set l $numcommits
5569         }
5570         incr l -1
5571         if {$l >= $findstartline} {
5572             set lim [expr {$findstartline - 1}]
5573         } else {
5574             set lim -1
5575             set moretodo $findallowwrap
5576         }
5577     }
5578     set n [expr {($lim - $l) * $find_dirn}]
5579     if {$n > 500} {
5580         set n 500
5581         set moretodo 1
5582     }
5583     if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
5584         update_arcrows $curview
5585     }
5586     set found 0
5587     set domore 1
5588     set ai [bsearch $vrownum($curview) $l]
5589     set a [lindex $varcorder($curview) $ai]
5590     set arow [lindex $vrownum($curview) $ai]
5591     set ids [lindex $varccommits($curview,$a)]
5592     set arowend [expr {$arow + [llength $ids]}]
5593     if {$gdttype eq [mc "containing:"]} {
5594         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
5595             if {$l < $arow || $l >= $arowend} {
5596                 incr ai $find_dirn
5597                 set a [lindex $varcorder($curview) $ai]
5598                 set arow [lindex $vrownum($curview) $ai]
5599                 set ids [lindex $varccommits($curview,$a)]
5600                 set arowend [expr {$arow + [llength $ids]}]
5601             }
5602             set id [lindex $ids [expr {$l - $arow}]]
5603             # shouldn't happen unless git log doesn't give all the commits...
5604             if {![info exists commitdata($id)] ||
5605                 ![doesmatch $commitdata($id)]} {
5606                 continue
5607             }
5608             if {![info exists commitinfo($id)]} {
5609                 getcommit $id
5610             }
5611             set info $commitinfo($id)
5612             foreach f $info ty $fldtypes {
5613                 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5614                     [doesmatch $f]} {
5615                     set found 1
5616                     break
5617                 }
5618             }
5619             if {$found} break
5620         }
5621     } else {
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             if {![info exists fhighlights($id)]} {
5632                 # this sets fhighlights($id) to -1
5633                 askfilehighlight $l $id
5634             }
5635             if {$fhighlights($id) > 0} {
5636                 set found $domore
5637                 break
5638             }
5639             if {$fhighlights($id) < 0} {
5640                 if {$domore} {
5641                     set domore 0
5642                     set findcurline [expr {$l - $find_dirn}]
5643                 }
5644             }
5645         }
5646     }
5647     if {$found || ($domore && !$moretodo)} {
5648         unset findcurline
5649         unset find_dirn
5650         notbusy finding
5651         set fprogcoord 0
5652         adjustprogress
5653         if {$found} {
5654             findselectline $l
5655         } else {
5656             bell
5657         }
5658         return 0
5659     }
5660     if {!$domore} {
5661         flushhighlights
5662     } else {
5663         set findcurline [expr {$l - $find_dirn}]
5664     }
5665     set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
5666     if {$n < 0} {
5667         incr n $numcommits
5668     }
5669     set fprogcoord [expr {$n * 1.0 / $numcommits}]
5670     adjustprogress
5671     return $domore
5674 proc findselectline {l} {
5675     global findloc commentend ctext findcurline markingmatches gdttype
5677     set markingmatches 1
5678     set findcurline $l
5679     selectline $l 1
5680     if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
5681         # highlight the matches in the comments
5682         set f [$ctext get 1.0 $commentend]
5683         set matches [findmatches $f]
5684         foreach match $matches {
5685             set start [lindex $match 0]
5686             set end [expr {[lindex $match 1] + 1}]
5687             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
5688         }
5689     }
5690     drawvisible
5693 # mark the bits of a headline or author that match a find string
5694 proc markmatches {canv l str tag matches font row} {
5695     global selectedline
5697     set bbox [$canv bbox $tag]
5698     set x0 [lindex $bbox 0]
5699     set y0 [lindex $bbox 1]
5700     set y1 [lindex $bbox 3]
5701     foreach match $matches {
5702         set start [lindex $match 0]
5703         set end [lindex $match 1]
5704         if {$start > $end} continue
5705         set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
5706         set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5707         set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5708                    [expr {$x0+$xlen+2}] $y1 \
5709                    -outline {} -tags [list match$l matches] -fill yellow]
5710         $canv lower $t
5711         if {$row == $selectedline} {
5712             $canv raise $t secsel
5713         }
5714     }
5717 proc unmarkmatches {} {
5718     global markingmatches
5720     allcanvs delete matches
5721     set markingmatches 0
5722     stopfinding
5725 proc selcanvline {w x y} {
5726     global canv canvy0 ctext linespc
5727     global rowtextx
5728     set ymax [lindex [$canv cget -scrollregion] 3]
5729     if {$ymax == {}} return
5730     set yfrac [lindex [$canv yview] 0]
5731     set y [expr {$y + $yfrac * $ymax}]
5732     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5733     if {$l < 0} {
5734         set l 0
5735     }
5736     if {$w eq $canv} {
5737         set xmax [lindex [$canv cget -scrollregion] 2]
5738         set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
5739         if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
5740     }
5741     unmarkmatches
5742     selectline $l 1
5745 proc commit_descriptor {p} {
5746     global commitinfo
5747     if {![info exists commitinfo($p)]} {
5748         getcommit $p
5749     }
5750     set l "..."
5751     if {[llength $commitinfo($p)] > 1} {
5752         set l [lindex $commitinfo($p) 0]
5753     }
5754     return "$p ($l)\n"
5757 # append some text to the ctext widget, and make any SHA1 ID
5758 # that we know about be a clickable link.
5759 proc appendwithlinks {text tags} {
5760     global ctext linknum curview pendinglinks
5762     set start [$ctext index "end - 1c"]
5763     $ctext insert end $text $tags
5764     set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5765     foreach l $links {
5766         set s [lindex $l 0]
5767         set e [lindex $l 1]
5768         set linkid [string range $text $s $e]
5769         incr e
5770         $ctext tag delete link$linknum
5771         $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5772         setlink $linkid link$linknum
5773         incr linknum
5774     }
5777 proc setlink {id lk} {
5778     global curview ctext pendinglinks commitinterest
5780     if {[commitinview $id $curview]} {
5781         $ctext tag conf $lk -foreground blue -underline 1
5782         $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5783         $ctext tag bind $lk <Enter> {linkcursor %W 1}
5784         $ctext tag bind $lk <Leave> {linkcursor %W -1}
5785     } else {
5786         lappend pendinglinks($id) $lk
5787         lappend commitinterest($id) {makelink %I}
5788     }
5791 proc makelink {id} {
5792     global pendinglinks
5794     if {![info exists pendinglinks($id)]} return
5795     foreach lk $pendinglinks($id) {
5796         setlink $id $lk
5797     }
5798     unset pendinglinks($id)
5801 proc linkcursor {w inc} {
5802     global linkentercount curtextcursor
5804     if {[incr linkentercount $inc] > 0} {
5805         $w configure -cursor hand2
5806     } else {
5807         $w configure -cursor $curtextcursor
5808         if {$linkentercount < 0} {
5809             set linkentercount 0
5810         }
5811     }
5814 proc viewnextline {dir} {
5815     global canv linespc
5817     $canv delete hover
5818     set ymax [lindex [$canv cget -scrollregion] 3]
5819     set wnow [$canv yview]
5820     set wtop [expr {[lindex $wnow 0] * $ymax}]
5821     set newtop [expr {$wtop + $dir * $linespc}]
5822     if {$newtop < 0} {
5823         set newtop 0
5824     } elseif {$newtop > $ymax} {
5825         set newtop $ymax
5826     }
5827     allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5830 # add a list of tag or branch names at position pos
5831 # returns the number of names inserted
5832 proc appendrefs {pos ids var} {
5833     global ctext linknum curview $var maxrefs
5835     if {[catch {$ctext index $pos}]} {
5836         return 0
5837     }
5838     $ctext conf -state normal
5839     $ctext delete $pos "$pos lineend"
5840     set tags {}
5841     foreach id $ids {
5842         foreach tag [set $var\($id\)] {
5843             lappend tags [list $tag $id]
5844         }
5845     }
5846     if {[llength $tags] > $maxrefs} {
5847         $ctext insert $pos "many ([llength $tags])"
5848     } else {
5849         set tags [lsort -index 0 -decreasing $tags]
5850         set sep {}
5851         foreach ti $tags {
5852             set id [lindex $ti 1]
5853             set lk link$linknum
5854             incr linknum
5855             $ctext tag delete $lk
5856             $ctext insert $pos $sep
5857             $ctext insert $pos [lindex $ti 0] $lk
5858             setlink $id $lk
5859             set sep ", "
5860         }
5861     }
5862     $ctext conf -state disabled
5863     return [llength $tags]
5866 # called when we have finished computing the nearby tags
5867 proc dispneartags {delay} {
5868     global selectedline currentid showneartags tagphase
5870     if {$selectedline eq {} || !$showneartags} return
5871     after cancel dispnexttag
5872     if {$delay} {
5873         after 200 dispnexttag
5874         set tagphase -1
5875     } else {
5876         after idle dispnexttag
5877         set tagphase 0
5878     }
5881 proc dispnexttag {} {
5882     global selectedline currentid showneartags tagphase ctext
5884     if {$selectedline eq {} || !$showneartags} return
5885     switch -- $tagphase {
5886         0 {
5887             set dtags [desctags $currentid]
5888             if {$dtags ne {}} {
5889                 appendrefs precedes $dtags idtags
5890             }
5891         }
5892         1 {
5893             set atags [anctags $currentid]
5894             if {$atags ne {}} {
5895                 appendrefs follows $atags idtags
5896             }
5897         }
5898         2 {
5899             set dheads [descheads $currentid]
5900             if {$dheads ne {}} {
5901                 if {[appendrefs branch $dheads idheads] > 1
5902                     && [$ctext get "branch -3c"] eq "h"} {
5903                     # turn "Branch" into "Branches"
5904                     $ctext conf -state normal
5905                     $ctext insert "branch -2c" "es"
5906                     $ctext conf -state disabled
5907                 }
5908             }
5909         }
5910     }
5911     if {[incr tagphase] <= 2} {
5912         after idle dispnexttag
5913     }
5916 proc make_secsel {l} {
5917     global linehtag linentag linedtag canv canv2 canv3
5919     if {![info exists linehtag($l)]} return
5920     $canv delete secsel
5921     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5922                -tags secsel -fill [$canv cget -selectbackground]]
5923     $canv lower $t
5924     $canv2 delete secsel
5925     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5926                -tags secsel -fill [$canv2 cget -selectbackground]]
5927     $canv2 lower $t
5928     $canv3 delete secsel
5929     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5930                -tags secsel -fill [$canv3 cget -selectbackground]]
5931     $canv3 lower $t
5934 proc selectline {l isnew} {
5935     global canv ctext commitinfo selectedline
5936     global canvy0 linespc parents children curview
5937     global currentid sha1entry
5938     global commentend idtags linknum
5939     global mergemax numcommits pending_select
5940     global cmitmode showneartags allcommits
5941     global targetrow targetid lastscrollrows
5942     global autoselect
5944     catch {unset pending_select}
5945     $canv delete hover
5946     normalline
5947     unsel_reflist
5948     stopfinding
5949     if {$l < 0 || $l >= $numcommits} return
5950     set id [commitonrow $l]
5951     set targetid $id
5952     set targetrow $l
5953     set selectedline $l
5954     set currentid $id
5955     if {$lastscrollrows < $numcommits} {
5956         setcanvscroll
5957     }
5959     set y [expr {$canvy0 + $l * $linespc}]
5960     set ymax [lindex [$canv cget -scrollregion] 3]
5961     set ytop [expr {$y - $linespc - 1}]
5962     set ybot [expr {$y + $linespc + 1}]
5963     set wnow [$canv yview]
5964     set wtop [expr {[lindex $wnow 0] * $ymax}]
5965     set wbot [expr {[lindex $wnow 1] * $ymax}]
5966     set wh [expr {$wbot - $wtop}]
5967     set newtop $wtop
5968     if {$ytop < $wtop} {
5969         if {$ybot < $wtop} {
5970             set newtop [expr {$y - $wh / 2.0}]
5971         } else {
5972             set newtop $ytop
5973             if {$newtop > $wtop - $linespc} {
5974                 set newtop [expr {$wtop - $linespc}]
5975             }
5976         }
5977     } elseif {$ybot > $wbot} {
5978         if {$ytop > $wbot} {
5979             set newtop [expr {$y - $wh / 2.0}]
5980         } else {
5981             set newtop [expr {$ybot - $wh}]
5982             if {$newtop < $wtop + $linespc} {
5983                 set newtop [expr {$wtop + $linespc}]
5984             }
5985         }
5986     }
5987     if {$newtop != $wtop} {
5988         if {$newtop < 0} {
5989             set newtop 0
5990         }
5991         allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5992         drawvisible
5993     }
5995     make_secsel $l
5997     if {$isnew} {
5998         addtohistory [list selbyid $id]
5999     }
6001     $sha1entry delete 0 end
6002     $sha1entry insert 0 $id
6003     if {$autoselect} {
6004         $sha1entry selection from 0
6005         $sha1entry selection to end
6006     }
6007     rhighlight_sel $id
6009     $ctext conf -state normal
6010     clear_ctext
6011     set linknum 0
6012     if {![info exists commitinfo($id)]} {
6013         getcommit $id
6014     }
6015     set info $commitinfo($id)
6016     set date [formatdate [lindex $info 2]]
6017     $ctext insert end "[mc "Author"]: [lindex $info 1]  $date\n"
6018     set date [formatdate [lindex $info 4]]
6019     $ctext insert end "[mc "Committer"]: [lindex $info 3]  $date\n"
6020     if {[info exists idtags($id)]} {
6021         $ctext insert end [mc "Tags:"]
6022         foreach tag $idtags($id) {
6023             $ctext insert end " $tag"
6024         }
6025         $ctext insert end "\n"
6026     }
6028     set headers {}
6029     set olds $parents($curview,$id)
6030     if {[llength $olds] > 1} {
6031         set np 0
6032         foreach p $olds {
6033             if {$np >= $mergemax} {
6034                 set tag mmax
6035             } else {
6036                 set tag m$np
6037             }
6038             $ctext insert end "[mc "Parent"]: " $tag
6039             appendwithlinks [commit_descriptor $p] {}
6040             incr np
6041         }
6042     } else {
6043         foreach p $olds {
6044             append headers "[mc "Parent"]: [commit_descriptor $p]"
6045         }
6046     }
6048     foreach c $children($curview,$id) {
6049         append headers "[mc "Child"]:  [commit_descriptor $c]"
6050     }
6052     # make anything that looks like a SHA1 ID be a clickable link
6053     appendwithlinks $headers {}
6054     if {$showneartags} {
6055         if {![info exists allcommits]} {
6056             getallcommits
6057         }
6058         $ctext insert end "[mc "Branch"]: "
6059         $ctext mark set branch "end -1c"
6060         $ctext mark gravity branch left
6061         $ctext insert end "\n[mc "Follows"]: "
6062         $ctext mark set follows "end -1c"
6063         $ctext mark gravity follows left
6064         $ctext insert end "\n[mc "Precedes"]: "
6065         $ctext mark set precedes "end -1c"
6066         $ctext mark gravity precedes left
6067         $ctext insert end "\n"
6068         dispneartags 1
6069     }
6070     $ctext insert end "\n"
6071     set comment [lindex $info 5]
6072     if {[string first "\r" $comment] >= 0} {
6073         set comment [string map {"\r" "\n    "} $comment]
6074     }
6075     appendwithlinks $comment {comment}
6077     $ctext tag remove found 1.0 end
6078     $ctext conf -state disabled
6079     set commentend [$ctext index "end - 1c"]
6081     init_flist [mc "Comments"]
6082     if {$cmitmode eq "tree"} {
6083         gettree $id
6084     } elseif {[llength $olds] <= 1} {
6085         startdiff $id
6086     } else {
6087         mergediff $id
6088     }
6091 proc selfirstline {} {
6092     unmarkmatches
6093     selectline 0 1
6096 proc sellastline {} {
6097     global numcommits
6098     unmarkmatches
6099     set l [expr {$numcommits - 1}]
6100     selectline $l 1
6103 proc selnextline {dir} {
6104     global selectedline
6105     focus .
6106     if {$selectedline eq {}} return
6107     set l [expr {$selectedline + $dir}]
6108     unmarkmatches
6109     selectline $l 1
6112 proc selnextpage {dir} {
6113     global canv linespc selectedline numcommits
6115     set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6116     if {$lpp < 1} {
6117         set lpp 1
6118     }
6119     allcanvs yview scroll [expr {$dir * $lpp}] units
6120     drawvisible
6121     if {$selectedline eq {}} return
6122     set l [expr {$selectedline + $dir * $lpp}]
6123     if {$l < 0} {
6124         set l 0
6125     } elseif {$l >= $numcommits} {
6126         set l [expr $numcommits - 1]
6127     }
6128     unmarkmatches
6129     selectline $l 1
6132 proc unselectline {} {
6133     global selectedline currentid
6135     set selectedline {}
6136     catch {unset currentid}
6137     allcanvs delete secsel
6138     rhighlight_none
6141 proc reselectline {} {
6142     global selectedline
6144     if {$selectedline ne {}} {
6145         selectline $selectedline 0
6146     }
6149 proc addtohistory {cmd} {
6150     global history historyindex curview
6152     set elt [list $curview $cmd]
6153     if {$historyindex > 0
6154         && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6155         return
6156     }
6158     if {$historyindex < [llength $history]} {
6159         set history [lreplace $history $historyindex end $elt]
6160     } else {
6161         lappend history $elt
6162     }
6163     incr historyindex
6164     if {$historyindex > 1} {
6165         .tf.bar.leftbut conf -state normal
6166     } else {
6167         .tf.bar.leftbut conf -state disabled
6168     }
6169     .tf.bar.rightbut conf -state disabled
6172 proc godo {elt} {
6173     global curview
6175     set view [lindex $elt 0]
6176     set cmd [lindex $elt 1]
6177     if {$curview != $view} {
6178         showview $view
6179     }
6180     eval $cmd
6183 proc goback {} {
6184     global history historyindex
6185     focus .
6187     if {$historyindex > 1} {
6188         incr historyindex -1
6189         godo [lindex $history [expr {$historyindex - 1}]]
6190         .tf.bar.rightbut conf -state normal
6191     }
6192     if {$historyindex <= 1} {
6193         .tf.bar.leftbut conf -state disabled
6194     }
6197 proc goforw {} {
6198     global history historyindex
6199     focus .
6201     if {$historyindex < [llength $history]} {
6202         set cmd [lindex $history $historyindex]
6203         incr historyindex
6204         godo $cmd
6205         .tf.bar.leftbut conf -state normal
6206     }
6207     if {$historyindex >= [llength $history]} {
6208         .tf.bar.rightbut conf -state disabled
6209     }
6212 proc gettree {id} {
6213     global treefilelist treeidlist diffids diffmergeid treepending
6214     global nullid nullid2
6216     set diffids $id
6217     catch {unset diffmergeid}
6218     if {![info exists treefilelist($id)]} {
6219         if {![info exists treepending]} {
6220             if {$id eq $nullid} {
6221                 set cmd [list | git ls-files]
6222             } elseif {$id eq $nullid2} {
6223                 set cmd [list | git ls-files --stage -t]
6224             } else {
6225                 set cmd [list | git ls-tree -r $id]
6226             }
6227             if {[catch {set gtf [open $cmd r]}]} {
6228                 return
6229             }
6230             set treepending $id
6231             set treefilelist($id) {}
6232             set treeidlist($id) {}
6233             fconfigure $gtf -blocking 0 -encoding binary
6234             filerun $gtf [list gettreeline $gtf $id]
6235         }
6236     } else {
6237         setfilelist $id
6238     }
6241 proc gettreeline {gtf id} {
6242     global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6244     set nl 0
6245     while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6246         if {$diffids eq $nullid} {
6247             set fname $line
6248         } else {
6249             set i [string first "\t" $line]
6250             if {$i < 0} continue
6251             set fname [string range $line [expr {$i+1}] end]
6252             set line [string range $line 0 [expr {$i-1}]]
6253             if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6254             set sha1 [lindex $line 2]
6255             lappend treeidlist($id) $sha1
6256         }
6257         if {[string index $fname 0] eq "\""} {
6258             set fname [lindex $fname 0]
6259         }
6260         set fname [encoding convertfrom $fname]
6261         lappend treefilelist($id) $fname
6262     }
6263     if {![eof $gtf]} {
6264         return [expr {$nl >= 1000? 2: 1}]
6265     }
6266     close $gtf
6267     unset treepending
6268     if {$cmitmode ne "tree"} {
6269         if {![info exists diffmergeid]} {
6270             gettreediffs $diffids
6271         }
6272     } elseif {$id ne $diffids} {
6273         gettree $diffids
6274     } else {
6275         setfilelist $id
6276     }
6277     return 0
6280 proc showfile {f} {
6281     global treefilelist treeidlist diffids nullid nullid2
6282     global ctext commentend
6284     set i [lsearch -exact $treefilelist($diffids) $f]
6285     if {$i < 0} {
6286         puts "oops, $f not in list for id $diffids"
6287         return
6288     }
6289     if {$diffids eq $nullid} {
6290         if {[catch {set bf [open $f r]} err]} {
6291             puts "oops, can't read $f: $err"
6292             return
6293         }
6294     } else {
6295         set blob [lindex $treeidlist($diffids) $i]
6296         if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6297             puts "oops, error reading blob $blob: $err"
6298             return
6299         }
6300     }
6301     fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6302     filerun $bf [list getblobline $bf $diffids]
6303     $ctext config -state normal
6304     clear_ctext $commentend
6305     $ctext insert end "\n"
6306     $ctext insert end "$f\n" filesep
6307     $ctext config -state disabled
6308     $ctext yview $commentend
6309     settabs 0
6312 proc getblobline {bf id} {
6313     global diffids cmitmode ctext
6315     if {$id ne $diffids || $cmitmode ne "tree"} {
6316         catch {close $bf}
6317         return 0
6318     }
6319     $ctext config -state normal
6320     set nl 0
6321     while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6322         $ctext insert end "$line\n"
6323     }
6324     if {[eof $bf]} {
6325         # delete last newline
6326         $ctext delete "end - 2c" "end - 1c"
6327         close $bf
6328         return 0
6329     }
6330     $ctext config -state disabled
6331     return [expr {$nl >= 1000? 2: 1}]
6334 proc mergediff {id} {
6335     global diffmergeid mdifffd
6336     global diffids
6337     global parents
6338     global diffcontext
6339     global diffencoding
6340     global limitdiffs vfilelimit curview
6342     set diffmergeid $id
6343     set diffids $id
6344     # this doesn't seem to actually affect anything...
6345     set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
6346     if {$limitdiffs && $vfilelimit($curview) ne {}} {
6347         set cmd [concat $cmd -- $vfilelimit($curview)]
6348     }
6349     if {[catch {set mdf [open $cmd r]} err]} {
6350         error_popup "[mc "Error getting merge diffs:"] $err"
6351         return
6352     }
6353     fconfigure $mdf -blocking 0 -encoding binary
6354     set mdifffd($id) $mdf
6355     set np [llength $parents($curview,$id)]
6356     set diffencoding [get_path_encoding {}]
6357     settabs $np
6358     filerun $mdf [list getmergediffline $mdf $id $np]
6361 proc getmergediffline {mdf id np} {
6362     global diffmergeid ctext cflist mergemax
6363     global difffilestart mdifffd
6364     global diffencoding
6366     $ctext conf -state normal
6367     set nr 0
6368     while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
6369         if {![info exists diffmergeid] || $id != $diffmergeid
6370             || $mdf != $mdifffd($id)} {
6371             close $mdf
6372             return 0
6373         }
6374         if {[regexp {^diff --cc (.*)} $line match fname]} {
6375             # start of a new file
6376             set fname [encoding convertfrom $fname]
6377             $ctext insert end "\n"
6378             set here [$ctext index "end - 1c"]
6379             lappend difffilestart $here
6380             add_flist [list $fname]
6381             set diffencoding [get_path_encoding $fname]
6382             set l [expr {(78 - [string length $fname]) / 2}]
6383             set pad [string range "----------------------------------------" 1 $l]
6384             $ctext insert end "$pad $fname $pad\n" filesep
6385         } elseif {[regexp {^@@} $line]} {
6386             set line [encoding convertfrom $diffencoding $line]
6387             $ctext insert end "$line\n" hunksep
6388         } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
6389             # do nothing
6390         } else {
6391             set line [encoding convertfrom $diffencoding $line]
6392             # parse the prefix - one ' ', '-' or '+' for each parent
6393             set spaces {}
6394             set minuses {}
6395             set pluses {}
6396             set isbad 0
6397             for {set j 0} {$j < $np} {incr j} {
6398                 set c [string range $line $j $j]
6399                 if {$c == " "} {
6400                     lappend spaces $j
6401                 } elseif {$c == "-"} {
6402                     lappend minuses $j
6403                 } elseif {$c == "+"} {
6404                     lappend pluses $j
6405                 } else {
6406                     set isbad 1
6407                     break
6408                 }
6409             }
6410             set tags {}
6411             set num {}
6412             if {!$isbad && $minuses ne {} && $pluses eq {}} {
6413                 # line doesn't appear in result, parents in $minuses have the line
6414                 set num [lindex $minuses 0]
6415             } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
6416                 # line appears in result, parents in $pluses don't have the line
6417                 lappend tags mresult
6418                 set num [lindex $spaces 0]
6419             }
6420             if {$num ne {}} {
6421                 if {$num >= $mergemax} {
6422                     set num "max"
6423                 }
6424                 lappend tags m$num
6425             }
6426             $ctext insert end "$line\n" $tags
6427         }
6428     }
6429     $ctext conf -state disabled
6430     if {[eof $mdf]} {
6431         close $mdf
6432         return 0
6433     }
6434     return [expr {$nr >= 1000? 2: 1}]
6437 proc startdiff {ids} {
6438     global treediffs diffids treepending diffmergeid nullid nullid2
6440     settabs 1
6441     set diffids $ids
6442     catch {unset diffmergeid}
6443     if {![info exists treediffs($ids)] ||
6444         [lsearch -exact $ids $nullid] >= 0 ||
6445         [lsearch -exact $ids $nullid2] >= 0} {
6446         if {![info exists treepending]} {
6447             gettreediffs $ids
6448         }
6449     } else {
6450         addtocflist $ids
6451     }
6454 proc path_filter {filter name} {
6455     foreach p $filter {
6456         set l [string length $p]
6457         if {[string index $p end] eq "/"} {
6458             if {[string compare -length $l $p $name] == 0} {
6459                 return 1
6460             }
6461         } else {
6462             if {[string compare -length $l $p $name] == 0 &&
6463                 ([string length $name] == $l ||
6464                  [string index $name $l] eq "/")} {
6465                 return 1
6466             }
6467         }
6468     }
6469     return 0
6472 proc addtocflist {ids} {
6473     global treediffs
6475     add_flist $treediffs($ids)
6476     getblobdiffs $ids
6479 proc diffcmd {ids flags} {
6480     global nullid nullid2
6482     set i [lsearch -exact $ids $nullid]
6483     set j [lsearch -exact $ids $nullid2]
6484     if {$i >= 0} {
6485         if {[llength $ids] > 1 && $j < 0} {
6486             # comparing working directory with some specific revision
6487             set cmd [concat | git diff-index $flags]
6488             if {$i == 0} {
6489                 lappend cmd -R [lindex $ids 1]
6490             } else {
6491                 lappend cmd [lindex $ids 0]
6492             }
6493         } else {
6494             # comparing working directory with index
6495             set cmd [concat | git diff-files $flags]
6496             if {$j == 1} {
6497                 lappend cmd -R
6498             }
6499         }
6500     } elseif {$j >= 0} {
6501         set cmd [concat | git diff-index --cached $flags]
6502         if {[llength $ids] > 1} {
6503             # comparing index with specific revision
6504             if {$i == 0} {
6505                 lappend cmd -R [lindex $ids 1]
6506             } else {
6507                 lappend cmd [lindex $ids 0]
6508             }
6509         } else {
6510             # comparing index with HEAD
6511             lappend cmd HEAD
6512         }
6513     } else {
6514         set cmd [concat | git diff-tree -r $flags $ids]
6515     }
6516     return $cmd
6519 proc gettreediffs {ids} {
6520     global treediff treepending
6522     if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
6524     set treepending $ids
6525     set treediff {}
6526     fconfigure $gdtf -blocking 0 -encoding binary
6527     filerun $gdtf [list gettreediffline $gdtf $ids]
6530 proc gettreediffline {gdtf ids} {
6531     global treediff treediffs treepending diffids diffmergeid
6532     global cmitmode vfilelimit curview limitdiffs perfile_attrs
6534     set nr 0
6535     set sublist {}
6536     set max 1000
6537     if {$perfile_attrs} {
6538         # cache_gitattr is slow, and even slower on win32 where we
6539         # have to invoke it for only about 30 paths at a time
6540         set max 500
6541         if {[tk windowingsystem] == "win32"} {
6542             set max 120
6543         }
6544     }
6545     while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
6546         set i [string first "\t" $line]
6547         if {$i >= 0} {
6548             set file [string range $line [expr {$i+1}] end]
6549             if {[string index $file 0] eq "\""} {
6550                 set file [lindex $file 0]
6551             }
6552             set file [encoding convertfrom $file]
6553             lappend treediff $file
6554             lappend sublist $file
6555         }
6556     }
6557     if {$perfile_attrs} {
6558         cache_gitattr encoding $sublist
6559     }
6560     if {![eof $gdtf]} {
6561         return [expr {$nr >= $max? 2: 1}]
6562     }
6563     close $gdtf
6564     if {$limitdiffs && $vfilelimit($curview) ne {}} {
6565         set flist {}
6566         foreach f $treediff {
6567             if {[path_filter $vfilelimit($curview) $f]} {
6568                 lappend flist $f
6569             }
6570         }
6571         set treediffs($ids) $flist
6572     } else {
6573         set treediffs($ids) $treediff
6574     }
6575     unset treepending
6576     if {$cmitmode eq "tree"} {
6577         gettree $diffids
6578     } elseif {$ids != $diffids} {
6579         if {![info exists diffmergeid]} {
6580             gettreediffs $diffids
6581         }
6582     } else {
6583         addtocflist $ids
6584     }
6585     return 0
6588 # empty string or positive integer
6589 proc diffcontextvalidate {v} {
6590     return [regexp {^(|[1-9][0-9]*)$} $v]
6593 proc diffcontextchange {n1 n2 op} {
6594     global diffcontextstring diffcontext
6596     if {[string is integer -strict $diffcontextstring]} {
6597         if {$diffcontextstring > 0} {
6598             set diffcontext $diffcontextstring
6599             reselectline
6600         }
6601     }
6604 proc changeignorespace {} {
6605     reselectline
6608 proc getblobdiffs {ids} {
6609     global blobdifffd diffids env
6610     global diffinhdr treediffs
6611     global diffcontext
6612     global ignorespace
6613     global limitdiffs vfilelimit curview
6614     global diffencoding
6616     set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
6617     if {$ignorespace} {
6618         append cmd " -w"
6619     }
6620     if {$limitdiffs && $vfilelimit($curview) ne {}} {
6621         set cmd [concat $cmd -- $vfilelimit($curview)]
6622     }
6623     if {[catch {set bdf [open $cmd r]} err]} {
6624         puts "error getting diffs: $err"
6625         return
6626     }
6627     set diffinhdr 0
6628     set diffencoding [get_path_encoding {}]
6629     fconfigure $bdf -blocking 0 -encoding binary
6630     set blobdifffd($ids) $bdf
6631     filerun $bdf [list getblobdiffline $bdf $diffids]
6634 proc setinlist {var i val} {
6635     global $var
6637     while {[llength [set $var]] < $i} {
6638         lappend $var {}
6639     }
6640     if {[llength [set $var]] == $i} {
6641         lappend $var $val
6642     } else {
6643         lset $var $i $val
6644     }
6647 proc makediffhdr {fname ids} {
6648     global ctext curdiffstart treediffs
6650     set i [lsearch -exact $treediffs($ids) $fname]
6651     if {$i >= 0} {
6652         setinlist difffilestart $i $curdiffstart
6653     }
6654     set l [expr {(78 - [string length $fname]) / 2}]
6655     set pad [string range "----------------------------------------" 1 $l]
6656     $ctext insert $curdiffstart "$pad $fname $pad" filesep
6659 proc getblobdiffline {bdf ids} {
6660     global diffids blobdifffd ctext curdiffstart
6661     global diffnexthead diffnextnote difffilestart
6662     global diffinhdr treediffs
6663     global diffencoding
6665     set nr 0
6666     $ctext conf -state normal
6667     while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
6668         if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
6669             close $bdf
6670             return 0
6671         }
6672         if {![string compare -length 11 "diff --git " $line]} {
6673             # trim off "diff --git "
6674             set line [string range $line 11 end]
6675             set diffinhdr 1
6676             # start of a new file
6677             $ctext insert end "\n"
6678             set curdiffstart [$ctext index "end - 1c"]
6679             $ctext insert end "\n" filesep
6680             # If the name hasn't changed the length will be odd,
6681             # the middle char will be a space, and the two bits either
6682             # side will be a/name and b/name, or "a/name" and "b/name".
6683             # If the name has changed we'll get "rename from" and
6684             # "rename to" or "copy from" and "copy to" lines following this,
6685             # and we'll use them to get the filenames.
6686             # This complexity is necessary because spaces in the filename(s)
6687             # don't get escaped.
6688             set l [string length $line]
6689             set i [expr {$l / 2}]
6690             if {!(($l & 1) && [string index $line $i] eq " " &&
6691                   [string range $line 2 [expr {$i - 1}]] eq \
6692                       [string range $line [expr {$i + 3}] end])} {
6693                 continue
6694             }
6695             # unescape if quoted and chop off the a/ from the front
6696             if {[string index $line 0] eq "\""} {
6697                 set fname [string range [lindex $line 0] 2 end]
6698             } else {
6699                 set fname [string range $line 2 [expr {$i - 1}]]
6700             }
6701             set fname [encoding convertfrom $fname]
6702             set diffencoding [get_path_encoding $fname]
6703             makediffhdr $fname $ids
6705         } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
6706                        $line match f1l f1c f2l f2c rest]} {
6707             set line [encoding convertfrom $diffencoding $line]
6708             $ctext insert end "$line\n" hunksep
6709             set diffinhdr 0
6711         } elseif {$diffinhdr} {
6712             if {![string compare -length 12 "rename from " $line]} {
6713                 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
6714                 if {[string index $fname 0] eq "\""} {
6715                     set fname [lindex $fname 0]
6716                 }
6717                 set fname [encoding convertfrom $fname]
6718                 set i [lsearch -exact $treediffs($ids) $fname]
6719                 if {$i >= 0} {
6720                     setinlist difffilestart $i $curdiffstart
6721                 }
6722             } elseif {![string compare -length 10 $line "rename to "] ||
6723                       ![string compare -length 8 $line "copy to "]} {
6724                 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
6725                 if {[string index $fname 0] eq "\""} {
6726                     set fname [lindex $fname 0]
6727                 }
6728                 set fname [encoding convertfrom $fname]
6729                 set diffencoding [get_path_encoding $fname]
6730                 makediffhdr $fname $ids
6731             } elseif {[string compare -length 3 $line "---"] == 0} {
6732                 # do nothing
6733                 continue
6734             } elseif {[string compare -length 3 $line "+++"] == 0} {
6735                 set diffinhdr 0
6736                 continue
6737             }
6738             $ctext insert end "$line\n" filesep
6740         } else {
6741             set line [encoding convertfrom $diffencoding $line]
6742             set x [string range $line 0 0]
6743             if {$x == "-" || $x == "+"} {
6744                 set tag [expr {$x == "+"}]
6745                 $ctext insert end "$line\n" d$tag
6746             } elseif {$x == " "} {
6747                 $ctext insert end "$line\n"
6748             } else {
6749                 # "\ No newline at end of file",
6750                 # or something else we don't recognize
6751                 $ctext insert end "$line\n" hunksep
6752             }
6753         }
6754     }
6755     $ctext conf -state disabled
6756     if {[eof $bdf]} {
6757         close $bdf
6758         return 0
6759     }
6760     return [expr {$nr >= 1000? 2: 1}]
6763 proc changediffdisp {} {
6764     global ctext diffelide
6766     $ctext tag conf d0 -elide [lindex $diffelide 0]
6767     $ctext tag conf d1 -elide [lindex $diffelide 1]
6770 proc highlightfile {loc cline} {
6771     global ctext cflist cflist_top
6773     $ctext yview $loc
6774     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
6775     $cflist tag add highlight $cline.0 "$cline.0 lineend"
6776     $cflist see $cline.0
6777     set cflist_top $cline
6780 proc prevfile {} {
6781     global difffilestart ctext cmitmode
6783     if {$cmitmode eq "tree"} return
6784     set prev 0.0
6785     set prevline 1
6786     set here [$ctext index @0,0]
6787     foreach loc $difffilestart {
6788         if {[$ctext compare $loc >= $here]} {
6789             highlightfile $prev $prevline
6790             return
6791         }
6792         set prev $loc
6793         incr prevline
6794     }
6795     highlightfile $prev $prevline
6798 proc nextfile {} {
6799     global difffilestart ctext cmitmode
6801     if {$cmitmode eq "tree"} return
6802     set here [$ctext index @0,0]
6803     set line 1
6804     foreach loc $difffilestart {
6805         incr line
6806         if {[$ctext compare $loc > $here]} {
6807             highlightfile $loc $line
6808             return
6809         }
6810     }
6813 proc clear_ctext {{first 1.0}} {
6814     global ctext smarktop smarkbot
6815     global pendinglinks
6817     set l [lindex [split $first .] 0]
6818     if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6819         set smarktop $l
6820     }
6821     if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6822         set smarkbot $l
6823     }
6824     $ctext delete $first end
6825     if {$first eq "1.0"} {
6826         catch {unset pendinglinks}
6827     }
6830 proc settabs {{firstab {}}} {
6831     global firsttabstop tabstop ctext have_tk85
6833     if {$firstab ne {} && $have_tk85} {
6834         set firsttabstop $firstab
6835     }
6836     set w [font measure textfont "0"]
6837     if {$firsttabstop != 0} {
6838         $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6839                                [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6840     } elseif {$have_tk85 || $tabstop != 8} {
6841         $ctext conf -tabs [expr {$tabstop * $w}]
6842     } else {
6843         $ctext conf -tabs {}
6844     }
6847 proc incrsearch {name ix op} {
6848     global ctext searchstring searchdirn
6850     $ctext tag remove found 1.0 end
6851     if {[catch {$ctext index anchor}]} {
6852         # no anchor set, use start of selection, or of visible area
6853         set sel [$ctext tag ranges sel]
6854         if {$sel ne {}} {
6855             $ctext mark set anchor [lindex $sel 0]
6856         } elseif {$searchdirn eq "-forwards"} {
6857             $ctext mark set anchor @0,0
6858         } else {
6859             $ctext mark set anchor @0,[winfo height $ctext]
6860         }
6861     }
6862     if {$searchstring ne {}} {
6863         set here [$ctext search $searchdirn -- $searchstring anchor]
6864         if {$here ne {}} {
6865             $ctext see $here
6866         }
6867         searchmarkvisible 1
6868     }
6871 proc dosearch {} {
6872     global sstring ctext searchstring searchdirn
6874     focus $sstring
6875     $sstring icursor end
6876     set searchdirn -forwards
6877     if {$searchstring ne {}} {
6878         set sel [$ctext tag ranges sel]
6879         if {$sel ne {}} {
6880             set start "[lindex $sel 0] + 1c"
6881         } elseif {[catch {set start [$ctext index anchor]}]} {
6882             set start "@0,0"
6883         }
6884         set match [$ctext search -count mlen -- $searchstring $start]
6885         $ctext tag remove sel 1.0 end
6886         if {$match eq {}} {
6887             bell
6888             return
6889         }
6890         $ctext see $match
6891         set mend "$match + $mlen c"
6892         $ctext tag add sel $match $mend
6893         $ctext mark unset anchor
6894     }
6897 proc dosearchback {} {
6898     global sstring ctext searchstring searchdirn
6900     focus $sstring
6901     $sstring icursor end
6902     set searchdirn -backwards
6903     if {$searchstring ne {}} {
6904         set sel [$ctext tag ranges sel]
6905         if {$sel ne {}} {
6906             set start [lindex $sel 0]
6907         } elseif {[catch {set start [$ctext index anchor]}]} {
6908             set start @0,[winfo height $ctext]
6909         }
6910         set match [$ctext search -backwards -count ml -- $searchstring $start]
6911         $ctext tag remove sel 1.0 end
6912         if {$match eq {}} {
6913             bell
6914             return
6915         }
6916         $ctext see $match
6917         set mend "$match + $ml c"
6918         $ctext tag add sel $match $mend
6919         $ctext mark unset anchor
6920     }
6923 proc searchmark {first last} {
6924     global ctext searchstring
6926     set mend $first.0
6927     while {1} {
6928         set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6929         if {$match eq {}} break
6930         set mend "$match + $mlen c"
6931         $ctext tag add found $match $mend
6932     }
6935 proc searchmarkvisible {doall} {
6936     global ctext smarktop smarkbot
6938     set topline [lindex [split [$ctext index @0,0] .] 0]
6939     set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6940     if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6941         # no overlap with previous
6942         searchmark $topline $botline
6943         set smarktop $topline
6944         set smarkbot $botline
6945     } else {
6946         if {$topline < $smarktop} {
6947             searchmark $topline [expr {$smarktop-1}]
6948             set smarktop $topline
6949         }
6950         if {$botline > $smarkbot} {
6951             searchmark [expr {$smarkbot+1}] $botline
6952             set smarkbot $botline
6953         }
6954     }
6957 proc scrolltext {f0 f1} {
6958     global searchstring
6960     .bleft.bottom.sb set $f0 $f1
6961     if {$searchstring ne {}} {
6962         searchmarkvisible 0
6963     }
6966 proc setcoords {} {
6967     global linespc charspc canvx0 canvy0
6968     global xspc1 xspc2 lthickness
6970     set linespc [font metrics mainfont -linespace]
6971     set charspc [font measure mainfont "m"]
6972     set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6973     set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6974     set lthickness [expr {int($linespc / 9) + 1}]
6975     set xspc1(0) $linespc
6976     set xspc2 $linespc
6979 proc redisplay {} {
6980     global canv
6981     global selectedline
6983     set ymax [lindex [$canv cget -scrollregion] 3]
6984     if {$ymax eq {} || $ymax == 0} return
6985     set span [$canv yview]
6986     clear_display
6987     setcanvscroll
6988     allcanvs yview moveto [lindex $span 0]
6989     drawvisible
6990     if {$selectedline ne {}} {
6991         selectline $selectedline 0
6992         allcanvs yview moveto [lindex $span 0]
6993     }
6996 proc parsefont {f n} {
6997     global fontattr
6999     set fontattr($f,family) [lindex $n 0]
7000     set s [lindex $n 1]
7001     if {$s eq {} || $s == 0} {
7002         set s 10
7003     } elseif {$s < 0} {
7004         set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7005     }
7006     set fontattr($f,size) $s
7007     set fontattr($f,weight) normal
7008     set fontattr($f,slant) roman
7009     foreach style [lrange $n 2 end] {
7010         switch -- $style {
7011             "normal" -
7012             "bold"   {set fontattr($f,weight) $style}
7013             "roman" -
7014             "italic" {set fontattr($f,slant) $style}
7015         }
7016     }
7019 proc fontflags {f {isbold 0}} {
7020     global fontattr
7022     return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7023                 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7024                 -slant $fontattr($f,slant)]
7027 proc fontname {f} {
7028     global fontattr
7030     set n [list $fontattr($f,family) $fontattr($f,size)]
7031     if {$fontattr($f,weight) eq "bold"} {
7032         lappend n "bold"
7033     }
7034     if {$fontattr($f,slant) eq "italic"} {
7035         lappend n "italic"
7036     }
7037     return $n
7040 proc incrfont {inc} {
7041     global mainfont textfont ctext canv cflist showrefstop
7042     global stopped entries fontattr
7044     unmarkmatches
7045     set s $fontattr(mainfont,size)
7046     incr s $inc
7047     if {$s < 1} {
7048         set s 1
7049     }
7050     set fontattr(mainfont,size) $s
7051     font config mainfont -size $s
7052     font config mainfontbold -size $s
7053     set mainfont [fontname mainfont]
7054     set s $fontattr(textfont,size)
7055     incr s $inc
7056     if {$s < 1} {
7057         set s 1
7058     }
7059     set fontattr(textfont,size) $s
7060     font config textfont -size $s
7061     font config textfontbold -size $s
7062     set textfont [fontname textfont]
7063     setcoords
7064     settabs
7065     redisplay
7068 proc clearsha1 {} {
7069     global sha1entry sha1string
7070     if {[string length $sha1string] == 40} {
7071         $sha1entry delete 0 end
7072     }
7075 proc sha1change {n1 n2 op} {
7076     global sha1string currentid sha1but
7077     if {$sha1string == {}
7078         || ([info exists currentid] && $sha1string == $currentid)} {
7079         set state disabled
7080     } else {
7081         set state normal
7082     }
7083     if {[$sha1but cget -state] == $state} return
7084     if {$state == "normal"} {
7085         $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7086     } else {
7087         $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7088     }
7091 proc gotocommit {} {
7092     global sha1string tagids headids curview varcid
7094     if {$sha1string == {}
7095         || ([info exists currentid] && $sha1string == $currentid)} return
7096     if {[info exists tagids($sha1string)]} {
7097         set id $tagids($sha1string)
7098     } elseif {[info exists headids($sha1string)]} {
7099         set id $headids($sha1string)
7100     } else {
7101         set id [string tolower $sha1string]
7102         if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7103             set matches [array names varcid "$curview,$id*"]
7104             if {$matches ne {}} {
7105                 if {[llength $matches] > 1} {
7106                     error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7107                     return
7108                 }
7109                 set id [lindex [split [lindex $matches 0] ","] 1]
7110             }
7111         }
7112     }
7113     if {[commitinview $id $curview]} {
7114         selectline [rowofcommit $id] 1
7115         return
7116     }
7117     if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7118         set msg [mc "SHA1 id %s is not known" $sha1string]
7119     } else {
7120         set msg [mc "Tag/Head %s is not known" $sha1string]
7121     }
7122     error_popup $msg
7125 proc lineenter {x y id} {
7126     global hoverx hovery hoverid hovertimer
7127     global commitinfo canv
7129     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7130     set hoverx $x
7131     set hovery $y
7132     set hoverid $id
7133     if {[info exists hovertimer]} {
7134         after cancel $hovertimer
7135     }
7136     set hovertimer [after 500 linehover]
7137     $canv delete hover
7140 proc linemotion {x y id} {
7141     global hoverx hovery hoverid hovertimer
7143     if {[info exists hoverid] && $id == $hoverid} {
7144         set hoverx $x
7145         set hovery $y
7146         if {[info exists hovertimer]} {
7147             after cancel $hovertimer
7148         }
7149         set hovertimer [after 500 linehover]
7150     }
7153 proc lineleave {id} {
7154     global hoverid hovertimer canv
7156     if {[info exists hoverid] && $id == $hoverid} {
7157         $canv delete hover
7158         if {[info exists hovertimer]} {
7159             after cancel $hovertimer
7160             unset hovertimer
7161         }
7162         unset hoverid
7163     }
7166 proc linehover {} {
7167     global hoverx hovery hoverid hovertimer
7168     global canv linespc lthickness
7169     global commitinfo
7171     set text [lindex $commitinfo($hoverid) 0]
7172     set ymax [lindex [$canv cget -scrollregion] 3]
7173     if {$ymax == {}} return
7174     set yfrac [lindex [$canv yview] 0]
7175     set x [expr {$hoverx + 2 * $linespc}]
7176     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7177     set x0 [expr {$x - 2 * $lthickness}]
7178     set y0 [expr {$y - 2 * $lthickness}]
7179     set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7180     set y1 [expr {$y + $linespc + 2 * $lthickness}]
7181     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7182                -fill \#ffff80 -outline black -width 1 -tags hover]
7183     $canv raise $t
7184     set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7185                -font mainfont]
7186     $canv raise $t
7189 proc clickisonarrow {id y} {
7190     global lthickness
7192     set ranges [rowranges $id]
7193     set thresh [expr {2 * $lthickness + 6}]
7194     set n [expr {[llength $ranges] - 1}]
7195     for {set i 1} {$i < $n} {incr i} {
7196         set row [lindex $ranges $i]
7197         if {abs([yc $row] - $y) < $thresh} {
7198             return $i
7199         }
7200     }
7201     return {}
7204 proc arrowjump {id n y} {
7205     global canv
7207     # 1 <-> 2, 3 <-> 4, etc...
7208     set n [expr {(($n - 1) ^ 1) + 1}]
7209     set row [lindex [rowranges $id] $n]
7210     set yt [yc $row]
7211     set ymax [lindex [$canv cget -scrollregion] 3]
7212     if {$ymax eq {} || $ymax <= 0} return
7213     set view [$canv yview]
7214     set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7215     set yfrac [expr {$yt / $ymax - $yspan / 2}]
7216     if {$yfrac < 0} {
7217         set yfrac 0
7218     }
7219     allcanvs yview moveto $yfrac
7222 proc lineclick {x y id isnew} {
7223     global ctext commitinfo children canv thickerline curview
7225     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7226     unmarkmatches
7227     unselectline
7228     normalline
7229     $canv delete hover
7230     # draw this line thicker than normal
7231     set thickerline $id
7232     drawlines $id
7233     if {$isnew} {
7234         set ymax [lindex [$canv cget -scrollregion] 3]
7235         if {$ymax eq {}} return
7236         set yfrac [lindex [$canv yview] 0]
7237         set y [expr {$y + $yfrac * $ymax}]
7238     }
7239     set dirn [clickisonarrow $id $y]
7240     if {$dirn ne {}} {
7241         arrowjump $id $dirn $y
7242         return
7243     }
7245     if {$isnew} {
7246         addtohistory [list lineclick $x $y $id 0]
7247     }
7248     # fill the details pane with info about this line
7249     $ctext conf -state normal
7250     clear_ctext
7251     settabs 0
7252     $ctext insert end "[mc "Parent"]:\t"
7253     $ctext insert end $id link0
7254     setlink $id link0
7255     set info $commitinfo($id)
7256     $ctext insert end "\n\t[lindex $info 0]\n"
7257     $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7258     set date [formatdate [lindex $info 2]]
7259     $ctext insert end "\t[mc "Date"]:\t$date\n"
7260     set kids $children($curview,$id)
7261     if {$kids ne {}} {
7262         $ctext insert end "\n[mc "Children"]:"
7263         set i 0
7264         foreach child $kids {
7265             incr i
7266             if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7267             set info $commitinfo($child)
7268             $ctext insert end "\n\t"
7269             $ctext insert end $child link$i
7270             setlink $child link$i
7271             $ctext insert end "\n\t[lindex $info 0]"
7272             $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7273             set date [formatdate [lindex $info 2]]
7274             $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7275         }
7276     }
7277     $ctext conf -state disabled
7278     init_flist {}
7281 proc normalline {} {
7282     global thickerline
7283     if {[info exists thickerline]} {
7284         set id $thickerline
7285         unset thickerline
7286         drawlines $id
7287     }
7290 proc selbyid {id} {
7291     global curview
7292     if {[commitinview $id $curview]} {
7293         selectline [rowofcommit $id] 1
7294     }
7297 proc mstime {} {
7298     global startmstime
7299     if {![info exists startmstime]} {
7300         set startmstime [clock clicks -milliseconds]
7301     }
7302     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7305 proc rowmenu {x y id} {
7306     global rowctxmenu selectedline rowmenuid curview
7307     global nullid nullid2 fakerowmenu mainhead
7309     stopfinding
7310     set rowmenuid $id
7311     if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7312         set state disabled
7313     } else {
7314         set state normal
7315     }
7316     if {$id ne $nullid && $id ne $nullid2} {
7317         set menu $rowctxmenu
7318         if {$mainhead ne {}} {
7319             $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7320         } else {
7321             $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7322         }
7323     } else {
7324         set menu $fakerowmenu
7325     }
7326     $menu entryconfigure [mc "Diff this -> selected"] -state $state
7327     $menu entryconfigure [mc "Diff selected -> this"] -state $state
7328     $menu entryconfigure [mc "Make patch"] -state $state
7329     tk_popup $menu $x $y
7332 proc diffvssel {dirn} {
7333     global rowmenuid selectedline
7335     if {$selectedline eq {}} return
7336     if {$dirn} {
7337         set oldid [commitonrow $selectedline]
7338         set newid $rowmenuid
7339     } else {
7340         set oldid $rowmenuid
7341         set newid [commitonrow $selectedline]
7342     }
7343     addtohistory [list doseldiff $oldid $newid]
7344     doseldiff $oldid $newid
7347 proc doseldiff {oldid newid} {
7348     global ctext
7349     global commitinfo
7351     $ctext conf -state normal
7352     clear_ctext
7353     init_flist [mc "Top"]
7354     $ctext insert end "[mc "From"] "
7355     $ctext insert end $oldid link0
7356     setlink $oldid link0
7357     $ctext insert end "\n     "
7358     $ctext insert end [lindex $commitinfo($oldid) 0]
7359     $ctext insert end "\n\n[mc "To"]   "
7360     $ctext insert end $newid link1
7361     setlink $newid link1
7362     $ctext insert end "\n     "
7363     $ctext insert end [lindex $commitinfo($newid) 0]
7364     $ctext insert end "\n"
7365     $ctext conf -state disabled
7366     $ctext tag remove found 1.0 end
7367     startdiff [list $oldid $newid]
7370 proc mkpatch {} {
7371     global rowmenuid currentid commitinfo patchtop patchnum
7373     if {![info exists currentid]} return
7374     set oldid $currentid
7375     set oldhead [lindex $commitinfo($oldid) 0]
7376     set newid $rowmenuid
7377     set newhead [lindex $commitinfo($newid) 0]
7378     set top .patch
7379     set patchtop $top
7380     catch {destroy $top}
7381     toplevel $top
7382     label $top.title -text [mc "Generate patch"]
7383     grid $top.title - -pady 10
7384     label $top.from -text [mc "From:"]
7385     entry $top.fromsha1 -width 40 -relief flat
7386     $top.fromsha1 insert 0 $oldid
7387     $top.fromsha1 conf -state readonly
7388     grid $top.from $top.fromsha1 -sticky w
7389     entry $top.fromhead -width 60 -relief flat
7390     $top.fromhead insert 0 $oldhead
7391     $top.fromhead conf -state readonly
7392     grid x $top.fromhead -sticky w
7393     label $top.to -text [mc "To:"]
7394     entry $top.tosha1 -width 40 -relief flat
7395     $top.tosha1 insert 0 $newid
7396     $top.tosha1 conf -state readonly
7397     grid $top.to $top.tosha1 -sticky w
7398     entry $top.tohead -width 60 -relief flat
7399     $top.tohead insert 0 $newhead
7400     $top.tohead conf -state readonly
7401     grid x $top.tohead -sticky w
7402     button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
7403     grid $top.rev x -pady 10
7404     label $top.flab -text [mc "Output file:"]
7405     entry $top.fname -width 60
7406     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
7407     incr patchnum
7408     grid $top.flab $top.fname -sticky w
7409     frame $top.buts
7410     button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
7411     button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
7412     grid $top.buts.gen $top.buts.can
7413     grid columnconfigure $top.buts 0 -weight 1 -uniform a
7414     grid columnconfigure $top.buts 1 -weight 1 -uniform a
7415     grid $top.buts - -pady 10 -sticky ew
7416     focus $top.fname
7419 proc mkpatchrev {} {
7420     global patchtop
7422     set oldid [$patchtop.fromsha1 get]
7423     set oldhead [$patchtop.fromhead get]
7424     set newid [$patchtop.tosha1 get]
7425     set newhead [$patchtop.tohead get]
7426     foreach e [list fromsha1 fromhead tosha1 tohead] \
7427             v [list $newid $newhead $oldid $oldhead] {
7428         $patchtop.$e conf -state normal
7429         $patchtop.$e delete 0 end
7430         $patchtop.$e insert 0 $v
7431         $patchtop.$e conf -state readonly
7432     }
7435 proc mkpatchgo {} {
7436     global patchtop nullid nullid2
7438     set oldid [$patchtop.fromsha1 get]
7439     set newid [$patchtop.tosha1 get]
7440     set fname [$patchtop.fname get]
7441     set cmd [diffcmd [list $oldid $newid] -p]
7442     # trim off the initial "|"
7443     set cmd [lrange $cmd 1 end]
7444     lappend cmd >$fname &
7445     if {[catch {eval exec $cmd} err]} {
7446         error_popup "[mc "Error creating patch:"] $err"
7447     }
7448     catch {destroy $patchtop}
7449     unset patchtop
7452 proc mkpatchcan {} {
7453     global patchtop
7455     catch {destroy $patchtop}
7456     unset patchtop
7459 proc mktag {} {
7460     global rowmenuid mktagtop commitinfo
7462     set top .maketag
7463     set mktagtop $top
7464     catch {destroy $top}
7465     toplevel $top
7466     label $top.title -text [mc "Create tag"]
7467     grid $top.title - -pady 10
7468     label $top.id -text [mc "ID:"]
7469     entry $top.sha1 -width 40 -relief flat
7470     $top.sha1 insert 0 $rowmenuid
7471     $top.sha1 conf -state readonly
7472     grid $top.id $top.sha1 -sticky w
7473     entry $top.head -width 60 -relief flat
7474     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7475     $top.head conf -state readonly
7476     grid x $top.head -sticky w
7477     label $top.tlab -text [mc "Tag name:"]
7478     entry $top.tag -width 60
7479     grid $top.tlab $top.tag -sticky w
7480     frame $top.buts
7481     button $top.buts.gen -text [mc "Create"] -command mktaggo
7482     button $top.buts.can -text [mc "Cancel"] -command mktagcan
7483     grid $top.buts.gen $top.buts.can
7484     grid columnconfigure $top.buts 0 -weight 1 -uniform a
7485     grid columnconfigure $top.buts 1 -weight 1 -uniform a
7486     grid $top.buts - -pady 10 -sticky ew
7487     focus $top.tag
7490 proc domktag {} {
7491     global mktagtop env tagids idtags
7493     set id [$mktagtop.sha1 get]
7494     set tag [$mktagtop.tag get]
7495     if {$tag == {}} {
7496         error_popup [mc "No tag name specified"]
7497         return
7498     }
7499     if {[info exists tagids($tag)]} {
7500         error_popup [mc "Tag \"%s\" already exists" $tag]
7501         return
7502     }
7503     if {[catch {
7504         exec git tag $tag $id
7505     } err]} {
7506         error_popup "[mc "Error creating tag:"] $err"
7507         return
7508     }
7510     set tagids($tag) $id
7511     lappend idtags($id) $tag
7512     redrawtags $id
7513     addedtag $id
7514     dispneartags 0
7515     run refill_reflist
7518 proc redrawtags {id} {
7519     global canv linehtag idpos currentid curview cmitlisted
7520     global canvxmax iddrawn circleitem mainheadid circlecolors
7522     if {![commitinview $id $curview]} return
7523     if {![info exists iddrawn($id)]} return
7524     set row [rowofcommit $id]
7525     if {$id eq $mainheadid} {
7526         set ofill yellow
7527     } else {
7528         set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
7529     }
7530     $canv itemconf $circleitem($row) -fill $ofill
7531     $canv delete tag.$id
7532     set xt [eval drawtags $id $idpos($id)]
7533     $canv coords $linehtag($row) $xt [lindex $idpos($id) 2]
7534     set text [$canv itemcget $linehtag($row) -text]
7535     set font [$canv itemcget $linehtag($row) -font]
7536     set xr [expr {$xt + [font measure $font $text]}]
7537     if {$xr > $canvxmax} {
7538         set canvxmax $xr
7539         setcanvscroll
7540     }
7541     if {[info exists currentid] && $currentid == $id} {
7542         make_secsel $row
7543     }
7546 proc mktagcan {} {
7547     global mktagtop
7549     catch {destroy $mktagtop}
7550     unset mktagtop
7553 proc mktaggo {} {
7554     domktag
7555     mktagcan
7558 proc writecommit {} {
7559     global rowmenuid wrcomtop commitinfo wrcomcmd
7561     set top .writecommit
7562     set wrcomtop $top
7563     catch {destroy $top}
7564     toplevel $top
7565     label $top.title -text [mc "Write commit to file"]
7566     grid $top.title - -pady 10
7567     label $top.id -text [mc "ID:"]
7568     entry $top.sha1 -width 40 -relief flat
7569     $top.sha1 insert 0 $rowmenuid
7570     $top.sha1 conf -state readonly
7571     grid $top.id $top.sha1 -sticky w
7572     entry $top.head -width 60 -relief flat
7573     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
7574     $top.head conf -state readonly
7575     grid x $top.head -sticky w
7576     label $top.clab -text [mc "Command:"]
7577     entry $top.cmd -width 60 -textvariable wrcomcmd
7578     grid $top.clab $top.cmd -sticky w -pady 10
7579     label $top.flab -text [mc "Output file:"]
7580     entry $top.fname -width 60
7581     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
7582     grid $top.flab $top.fname -sticky w
7583     frame $top.buts
7584     button $top.buts.gen -text [mc "Write"] -command wrcomgo
7585     button $top.buts.can -text [mc "Cancel"] -command wrcomcan
7586     grid $top.buts.gen $top.buts.can
7587     grid columnconfigure $top.buts 0 -weight 1 -uniform a
7588     grid columnconfigure $top.buts 1 -weight 1 -uniform a
7589     grid $top.buts - -pady 10 -sticky ew
7590     focus $top.fname
7593 proc wrcomgo {} {
7594     global wrcomtop
7596     set id [$wrcomtop.sha1 get]
7597     set cmd "echo $id | [$wrcomtop.cmd get]"
7598     set fname [$wrcomtop.fname get]
7599     if {[catch {exec sh -c $cmd >$fname &} err]} {
7600         error_popup "[mc "Error writing commit:"] $err"
7601     }
7602     catch {destroy $wrcomtop}
7603     unset wrcomtop
7606 proc wrcomcan {} {
7607     global wrcomtop
7609     catch {destroy $wrcomtop}
7610     unset wrcomtop
7613 proc mkbranch {} {
7614     global rowmenuid mkbrtop
7616     set top .makebranch
7617     catch {destroy $top}
7618     toplevel $top
7619     label $top.title -text [mc "Create new branch"]
7620     grid $top.title - -pady 10
7621     label $top.id -text [mc "ID:"]
7622     entry $top.sha1 -width 40 -relief flat
7623     $top.sha1 insert 0 $rowmenuid
7624     $top.sha1 conf -state readonly
7625     grid $top.id $top.sha1 -sticky w
7626     label $top.nlab -text [mc "Name:"]
7627     entry $top.name -width 40
7628     grid $top.nlab $top.name -sticky w
7629     frame $top.buts
7630     button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
7631     button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
7632     grid $top.buts.go $top.buts.can
7633     grid columnconfigure $top.buts 0 -weight 1 -uniform a
7634     grid columnconfigure $top.buts 1 -weight 1 -uniform a
7635     grid $top.buts - -pady 10 -sticky ew
7636     focus $top.name
7639 proc mkbrgo {top} {
7640     global headids idheads
7642     set name [$top.name get]
7643     set id [$top.sha1 get]
7644     if {$name eq {}} {
7645         error_popup [mc "Please specify a name for the new branch"]
7646         return
7647     }
7648     catch {destroy $top}
7649     nowbusy newbranch
7650     update
7651     if {[catch {
7652         exec git branch $name $id
7653     } err]} {
7654         notbusy newbranch
7655         error_popup $err
7656     } else {
7657         set headids($name) $id
7658         lappend idheads($id) $name
7659         addedhead $id $name
7660         notbusy newbranch
7661         redrawtags $id
7662         dispneartags 0
7663         run refill_reflist
7664     }
7667 proc cherrypick {} {
7668     global rowmenuid curview
7669     global mainhead mainheadid
7671     set oldhead [exec git rev-parse HEAD]
7672     set dheads [descheads $rowmenuid]
7673     if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
7674         set ok [confirm_popup [mc "Commit %s is already\
7675                 included in branch %s -- really re-apply it?" \
7676                                    [string range $rowmenuid 0 7] $mainhead]]
7677         if {!$ok} return
7678     }
7679     nowbusy cherrypick [mc "Cherry-picking"]
7680     update
7681     # Unfortunately git-cherry-pick writes stuff to stderr even when
7682     # no error occurs, and exec takes that as an indication of error...
7683     if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
7684         notbusy cherrypick
7685         error_popup $err
7686         return
7687     }
7688     set newhead [exec git rev-parse HEAD]
7689     if {$newhead eq $oldhead} {
7690         notbusy cherrypick
7691         error_popup [mc "No changes committed"]
7692         return
7693     }
7694     addnewchild $newhead $oldhead
7695     if {[commitinview $oldhead $curview]} {
7696         insertrow $newhead $oldhead $curview
7697         if {$mainhead ne {}} {
7698             movehead $newhead $mainhead
7699             movedhead $newhead $mainhead
7700         }
7701         set mainheadid $newhead
7702         redrawtags $oldhead
7703         redrawtags $newhead
7704         selbyid $newhead
7705     }
7706     notbusy cherrypick
7709 proc resethead {} {
7710     global mainhead rowmenuid confirm_ok resettype
7712     set confirm_ok 0
7713     set w ".confirmreset"
7714     toplevel $w
7715     wm transient $w .
7716     wm title $w [mc "Confirm reset"]
7717     message $w.m -text \
7718         [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
7719         -justify center -aspect 1000
7720     pack $w.m -side top -fill x -padx 20 -pady 20
7721     frame $w.f -relief sunken -border 2
7722     message $w.f.rt -text [mc "Reset type:"] -aspect 1000
7723     grid $w.f.rt -sticky w
7724     set resettype mixed
7725     radiobutton $w.f.soft -value soft -variable resettype -justify left \
7726         -text [mc "Soft: Leave working tree and index untouched"]
7727     grid $w.f.soft -sticky w
7728     radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
7729         -text [mc "Mixed: Leave working tree untouched, reset index"]
7730     grid $w.f.mixed -sticky w
7731     radiobutton $w.f.hard -value hard -variable resettype -justify left \
7732         -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
7733     grid $w.f.hard -sticky w
7734     pack $w.f -side top -fill x
7735     button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
7736     pack $w.ok -side left -fill x -padx 20 -pady 20
7737     button $w.cancel -text [mc Cancel] -command "destroy $w"
7738     pack $w.cancel -side right -fill x -padx 20 -pady 20
7739     bind $w <Visibility> "grab $w; focus $w"
7740     tkwait window $w
7741     if {!$confirm_ok} return
7742     if {[catch {set fd [open \
7743             [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
7744         error_popup $err
7745     } else {
7746         dohidelocalchanges
7747         filerun $fd [list readresetstat $fd]
7748         nowbusy reset [mc "Resetting"]
7749         selbyid $rowmenuid
7750     }
7753 proc readresetstat {fd} {
7754     global mainhead mainheadid showlocalchanges rprogcoord
7756     if {[gets $fd line] >= 0} {
7757         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7758             set rprogcoord [expr {1.0 * $m / $n}]
7759             adjustprogress
7760         }
7761         return 1
7762     }
7763     set rprogcoord 0
7764     adjustprogress
7765     notbusy reset
7766     if {[catch {close $fd} err]} {
7767         error_popup $err
7768     }
7769     set oldhead $mainheadid
7770     set newhead [exec git rev-parse HEAD]
7771     if {$newhead ne $oldhead} {
7772         movehead $newhead $mainhead
7773         movedhead $newhead $mainhead
7774         set mainheadid $newhead
7775         redrawtags $oldhead
7776         redrawtags $newhead
7777     }
7778     if {$showlocalchanges} {
7779         doshowlocalchanges
7780     }
7781     return 0
7784 # context menu for a head
7785 proc headmenu {x y id head} {
7786     global headmenuid headmenuhead headctxmenu mainhead
7788     stopfinding
7789     set headmenuid $id
7790     set headmenuhead $head
7791     set state normal
7792     if {$head eq $mainhead} {
7793         set state disabled
7794     }
7795     $headctxmenu entryconfigure 0 -state $state
7796     $headctxmenu entryconfigure 1 -state $state
7797     tk_popup $headctxmenu $x $y
7800 proc cobranch {} {
7801     global headmenuid headmenuhead headids
7802     global showlocalchanges mainheadid
7804     # check the tree is clean first??
7805     nowbusy checkout [mc "Checking out"]
7806     update
7807     dohidelocalchanges
7808     if {[catch {
7809         set fd [open [list | git checkout $headmenuhead 2>@1] r]
7810     } err]} {
7811         notbusy checkout
7812         error_popup $err
7813         if {$showlocalchanges} {
7814             dodiffindex
7815         }
7816     } else {
7817         filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
7818     }
7821 proc readcheckoutstat {fd newhead newheadid} {
7822     global mainhead mainheadid headids showlocalchanges progresscoords
7824     if {[gets $fd line] >= 0} {
7825         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
7826             set progresscoords [list 0 [expr {1.0 * $m / $n}]]
7827             adjustprogress
7828         }
7829         return 1
7830     }
7831     set progresscoords {0 0}
7832     adjustprogress
7833     notbusy checkout
7834     if {[catch {close $fd} err]} {
7835         error_popup $err
7836     }
7837     set oldmainid $mainheadid
7838     set mainhead $newhead
7839     set mainheadid $newheadid
7840     redrawtags $oldmainid
7841     redrawtags $newheadid
7842     selbyid $newheadid
7843     if {$showlocalchanges} {
7844         dodiffindex
7845     }
7848 proc rmbranch {} {
7849     global headmenuid headmenuhead mainhead
7850     global idheads
7852     set head $headmenuhead
7853     set id $headmenuid
7854     # this check shouldn't be needed any more...
7855     if {$head eq $mainhead} {
7856         error_popup [mc "Cannot delete the currently checked-out branch"]
7857         return
7858     }
7859     set dheads [descheads $id]
7860     if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7861         # the stuff on this branch isn't on any other branch
7862         if {![confirm_popup [mc "The commits on branch %s aren't on any other\
7863                         branch.\nReally delete branch %s?" $head $head]]} return
7864     }
7865     nowbusy rmbranch
7866     update
7867     if {[catch {exec git branch -D $head} err]} {
7868         notbusy rmbranch
7869         error_popup $err
7870         return
7871     }
7872     removehead $id $head
7873     removedhead $id $head
7874     redrawtags $id
7875     notbusy rmbranch
7876     dispneartags 0
7877     run refill_reflist
7880 # Display a list of tags and heads
7881 proc showrefs {} {
7882     global showrefstop bgcolor fgcolor selectbgcolor
7883     global bglist fglist reflistfilter reflist maincursor
7885     set top .showrefs
7886     set showrefstop $top
7887     if {[winfo exists $top]} {
7888         raise $top
7889         refill_reflist
7890         return
7891     }
7892     toplevel $top
7893     wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
7894     text $top.list -background $bgcolor -foreground $fgcolor \
7895         -selectbackground $selectbgcolor -font mainfont \
7896         -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7897         -width 30 -height 20 -cursor $maincursor \
7898         -spacing1 1 -spacing3 1 -state disabled
7899     $top.list tag configure highlight -background $selectbgcolor
7900     lappend bglist $top.list
7901     lappend fglist $top.list
7902     scrollbar $top.ysb -command "$top.list yview" -orient vertical
7903     scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7904     grid $top.list $top.ysb -sticky nsew
7905     grid $top.xsb x -sticky ew
7906     frame $top.f
7907     label $top.f.l -text "[mc "Filter"]: "
7908     entry $top.f.e -width 20 -textvariable reflistfilter
7909     set reflistfilter "*"
7910     trace add variable reflistfilter write reflistfilter_change
7911     pack $top.f.e -side right -fill x -expand 1
7912     pack $top.f.l -side left
7913     grid $top.f - -sticky ew -pady 2
7914     button $top.close -command [list destroy $top] -text [mc "Close"]
7915     grid $top.close -
7916     grid columnconfigure $top 0 -weight 1
7917     grid rowconfigure $top 0 -weight 1
7918     bind $top.list <1> {break}
7919     bind $top.list <B1-Motion> {break}
7920     bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7921     set reflist {}
7922     refill_reflist
7925 proc sel_reflist {w x y} {
7926     global showrefstop reflist headids tagids otherrefids
7928     if {![winfo exists $showrefstop]} return
7929     set l [lindex [split [$w index "@$x,$y"] "."] 0]
7930     set ref [lindex $reflist [expr {$l-1}]]
7931     set n [lindex $ref 0]
7932     switch -- [lindex $ref 1] {
7933         "H" {selbyid $headids($n)}
7934         "T" {selbyid $tagids($n)}
7935         "o" {selbyid $otherrefids($n)}
7936     }
7937     $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7940 proc unsel_reflist {} {
7941     global showrefstop
7943     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7944     $showrefstop.list tag remove highlight 0.0 end
7947 proc reflistfilter_change {n1 n2 op} {
7948     global reflistfilter
7950     after cancel refill_reflist
7951     after 200 refill_reflist
7954 proc refill_reflist {} {
7955     global reflist reflistfilter showrefstop headids tagids otherrefids
7956     global curview commitinterest
7958     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7959     set refs {}
7960     foreach n [array names headids] {
7961         if {[string match $reflistfilter $n]} {
7962             if {[commitinview $headids($n) $curview]} {
7963                 lappend refs [list $n H]
7964             } else {
7965                 set commitinterest($headids($n)) {run refill_reflist}
7966             }
7967         }
7968     }
7969     foreach n [array names tagids] {
7970         if {[string match $reflistfilter $n]} {
7971             if {[commitinview $tagids($n) $curview]} {
7972                 lappend refs [list $n T]
7973             } else {
7974                 set commitinterest($tagids($n)) {run refill_reflist}
7975             }
7976         }
7977     }
7978     foreach n [array names otherrefids] {
7979         if {[string match $reflistfilter $n]} {
7980             if {[commitinview $otherrefids($n) $curview]} {
7981                 lappend refs [list $n o]
7982             } else {
7983                 set commitinterest($otherrefids($n)) {run refill_reflist}
7984             }
7985         }
7986     }
7987     set refs [lsort -index 0 $refs]
7988     if {$refs eq $reflist} return
7990     # Update the contents of $showrefstop.list according to the
7991     # differences between $reflist (old) and $refs (new)
7992     $showrefstop.list conf -state normal
7993     $showrefstop.list insert end "\n"
7994     set i 0
7995     set j 0
7996     while {$i < [llength $reflist] || $j < [llength $refs]} {
7997         if {$i < [llength $reflist]} {
7998             if {$j < [llength $refs]} {
7999                 set cmp [string compare [lindex $reflist $i 0] \
8000                              [lindex $refs $j 0]]
8001                 if {$cmp == 0} {
8002                     set cmp [string compare [lindex $reflist $i 1] \
8003                                  [lindex $refs $j 1]]
8004                 }
8005             } else {
8006                 set cmp -1
8007             }
8008         } else {
8009             set cmp 1
8010         }
8011         switch -- $cmp {
8012             -1 {
8013                 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8014                 incr i
8015             }
8016             0 {
8017                 incr i
8018                 incr j
8019             }
8020             1 {
8021                 set l [expr {$j + 1}]
8022                 $showrefstop.list image create $l.0 -align baseline \
8023                     -image reficon-[lindex $refs $j 1] -padx 2
8024                 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8025                 incr j
8026             }
8027         }
8028     }
8029     set reflist $refs
8030     # delete last newline
8031     $showrefstop.list delete end-2c end-1c
8032     $showrefstop.list conf -state disabled
8035 # Stuff for finding nearby tags
8036 proc getallcommits {} {
8037     global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8038     global idheads idtags idotherrefs allparents tagobjid
8040     if {![info exists allcommits]} {
8041         set nextarc 0
8042         set allcommits 0
8043         set seeds {}
8044         set allcwait 0
8045         set cachedarcs 0
8046         set allccache [file join [gitdir] "gitk.cache"]
8047         if {![catch {
8048             set f [open $allccache r]
8049             set allcwait 1
8050             getcache $f
8051         }]} return
8052     }
8054     if {$allcwait} {
8055         return
8056     }
8057     set cmd [list | git rev-list --parents]
8058     set allcupdate [expr {$seeds ne {}}]
8059     if {!$allcupdate} {
8060         set ids "--all"
8061     } else {
8062         set refs [concat [array names idheads] [array names idtags] \
8063                       [array names idotherrefs]]
8064         set ids {}
8065         set tagobjs {}
8066         foreach name [array names tagobjid] {
8067             lappend tagobjs $tagobjid($name)
8068         }
8069         foreach id [lsort -unique $refs] {
8070             if {![info exists allparents($id)] &&
8071                 [lsearch -exact $tagobjs $id] < 0} {
8072                 lappend ids $id
8073             }
8074         }
8075         if {$ids ne {}} {
8076             foreach id $seeds {
8077                 lappend ids "^$id"
8078             }
8079         }
8080     }
8081     if {$ids ne {}} {
8082         set fd [open [concat $cmd $ids] r]
8083         fconfigure $fd -blocking 0
8084         incr allcommits
8085         nowbusy allcommits
8086         filerun $fd [list getallclines $fd]
8087     } else {
8088         dispneartags 0
8089     }
8092 # Since most commits have 1 parent and 1 child, we group strings of
8093 # such commits into "arcs" joining branch/merge points (BMPs), which
8094 # are commits that either don't have 1 parent or don't have 1 child.
8096 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8097 # arcout(id) - outgoing arcs for BMP
8098 # arcids(a) - list of IDs on arc including end but not start
8099 # arcstart(a) - BMP ID at start of arc
8100 # arcend(a) - BMP ID at end of arc
8101 # growing(a) - arc a is still growing
8102 # arctags(a) - IDs out of arcids (excluding end) that have tags
8103 # archeads(a) - IDs out of arcids (excluding end) that have heads
8104 # The start of an arc is at the descendent end, so "incoming" means
8105 # coming from descendents, and "outgoing" means going towards ancestors.
8107 proc getallclines {fd} {
8108     global allparents allchildren idtags idheads nextarc
8109     global arcnos arcids arctags arcout arcend arcstart archeads growing
8110     global seeds allcommits cachedarcs allcupdate
8111     
8112     set nid 0
8113     while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8114         set id [lindex $line 0]
8115         if {[info exists allparents($id)]} {
8116             # seen it already
8117             continue
8118         }
8119         set cachedarcs 0
8120         set olds [lrange $line 1 end]
8121         set allparents($id) $olds
8122         if {![info exists allchildren($id)]} {
8123             set allchildren($id) {}
8124             set arcnos($id) {}
8125             lappend seeds $id
8126         } else {
8127             set a $arcnos($id)
8128             if {[llength $olds] == 1 && [llength $a] == 1} {
8129                 lappend arcids($a) $id
8130                 if {[info exists idtags($id)]} {
8131                     lappend arctags($a) $id
8132                 }
8133                 if {[info exists idheads($id)]} {
8134                     lappend archeads($a) $id
8135                 }
8136                 if {[info exists allparents($olds)]} {
8137                     # seen parent already
8138                     if {![info exists arcout($olds)]} {
8139                         splitarc $olds
8140                     }
8141                     lappend arcids($a) $olds
8142                     set arcend($a) $olds
8143                     unset growing($a)
8144                 }
8145                 lappend allchildren($olds) $id
8146                 lappend arcnos($olds) $a
8147                 continue
8148             }
8149         }
8150         foreach a $arcnos($id) {
8151             lappend arcids($a) $id
8152             set arcend($a) $id
8153             unset growing($a)
8154         }
8156         set ao {}
8157         foreach p $olds {
8158             lappend allchildren($p) $id
8159             set a [incr nextarc]
8160             set arcstart($a) $id
8161             set archeads($a) {}
8162             set arctags($a) {}
8163             set archeads($a) {}
8164             set arcids($a) {}
8165             lappend ao $a
8166             set growing($a) 1
8167             if {[info exists allparents($p)]} {
8168                 # seen it already, may need to make a new branch
8169                 if {![info exists arcout($p)]} {
8170                     splitarc $p
8171                 }
8172                 lappend arcids($a) $p
8173                 set arcend($a) $p
8174                 unset growing($a)
8175             }
8176             lappend arcnos($p) $a
8177         }
8178         set arcout($id) $ao
8179     }
8180     if {$nid > 0} {
8181         global cached_dheads cached_dtags cached_atags
8182         catch {unset cached_dheads}
8183         catch {unset cached_dtags}
8184         catch {unset cached_atags}
8185     }
8186     if {![eof $fd]} {
8187         return [expr {$nid >= 1000? 2: 1}]
8188     }
8189     set cacheok 1
8190     if {[catch {
8191         fconfigure $fd -blocking 1
8192         close $fd
8193     } err]} {
8194         # got an error reading the list of commits
8195         # if we were updating, try rereading the whole thing again
8196         if {$allcupdate} {
8197             incr allcommits -1
8198             dropcache $err
8199             return
8200         }
8201         error_popup "[mc "Error reading commit topology information;\
8202                 branch and preceding/following tag information\
8203                 will be incomplete."]\n($err)"
8204         set cacheok 0
8205     }
8206     if {[incr allcommits -1] == 0} {
8207         notbusy allcommits
8208         if {$cacheok} {
8209             run savecache
8210         }
8211     }
8212     dispneartags 0
8213     return 0
8216 proc recalcarc {a} {
8217     global arctags archeads arcids idtags idheads
8219     set at {}
8220     set ah {}
8221     foreach id [lrange $arcids($a) 0 end-1] {
8222         if {[info exists idtags($id)]} {
8223             lappend at $id
8224         }
8225         if {[info exists idheads($id)]} {
8226             lappend ah $id
8227         }
8228     }
8229     set arctags($a) $at
8230     set archeads($a) $ah
8233 proc splitarc {p} {
8234     global arcnos arcids nextarc arctags archeads idtags idheads
8235     global arcstart arcend arcout allparents growing
8237     set a $arcnos($p)
8238     if {[llength $a] != 1} {
8239         puts "oops splitarc called but [llength $a] arcs already"
8240         return
8241     }
8242     set a [lindex $a 0]
8243     set i [lsearch -exact $arcids($a) $p]
8244     if {$i < 0} {
8245         puts "oops splitarc $p not in arc $a"
8246         return
8247     }
8248     set na [incr nextarc]
8249     if {[info exists arcend($a)]} {
8250         set arcend($na) $arcend($a)
8251     } else {
8252         set l [lindex $allparents([lindex $arcids($a) end]) 0]
8253         set j [lsearch -exact $arcnos($l) $a]
8254         set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8255     }
8256     set tail [lrange $arcids($a) [expr {$i+1}] end]
8257     set arcids($a) [lrange $arcids($a) 0 $i]
8258     set arcend($a) $p
8259     set arcstart($na) $p
8260     set arcout($p) $na
8261     set arcids($na) $tail
8262     if {[info exists growing($a)]} {
8263         set growing($na) 1
8264         unset growing($a)
8265     }
8267     foreach id $tail {
8268         if {[llength $arcnos($id)] == 1} {
8269             set arcnos($id) $na
8270         } else {
8271             set j [lsearch -exact $arcnos($id) $a]
8272             set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8273         }
8274     }
8276     # reconstruct tags and heads lists
8277     if {$arctags($a) ne {} || $archeads($a) ne {}} {
8278         recalcarc $a
8279         recalcarc $na
8280     } else {
8281         set arctags($na) {}
8282         set archeads($na) {}
8283     }
8286 # Update things for a new commit added that is a child of one
8287 # existing commit.  Used when cherry-picking.
8288 proc addnewchild {id p} {
8289     global allparents allchildren idtags nextarc
8290     global arcnos arcids arctags arcout arcend arcstart archeads growing
8291     global seeds allcommits
8293     if {![info exists allcommits] || ![info exists arcnos($p)]} return
8294     set allparents($id) [list $p]
8295     set allchildren($id) {}
8296     set arcnos($id) {}
8297     lappend seeds $id
8298     lappend allchildren($p) $id
8299     set a [incr nextarc]
8300     set arcstart($a) $id
8301     set archeads($a) {}
8302     set arctags($a) {}
8303     set arcids($a) [list $p]
8304     set arcend($a) $p
8305     if {![info exists arcout($p)]} {
8306         splitarc $p
8307     }
8308     lappend arcnos($p) $a
8309     set arcout($id) [list $a]
8312 # This implements a cache for the topology information.
8313 # The cache saves, for each arc, the start and end of the arc,
8314 # the ids on the arc, and the outgoing arcs from the end.
8315 proc readcache {f} {
8316     global arcnos arcids arcout arcstart arcend arctags archeads nextarc
8317     global idtags idheads allparents cachedarcs possible_seeds seeds growing
8318     global allcwait
8320     set a $nextarc
8321     set lim $cachedarcs
8322     if {$lim - $a > 500} {
8323         set lim [expr {$a + 500}]
8324     }
8325     if {[catch {
8326         if {$a == $lim} {
8327             # finish reading the cache and setting up arctags, etc.
8328             set line [gets $f]
8329             if {$line ne "1"} {error "bad final version"}
8330             close $f
8331             foreach id [array names idtags] {
8332                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8333                     [llength $allparents($id)] == 1} {
8334                     set a [lindex $arcnos($id) 0]
8335                     if {$arctags($a) eq {}} {
8336                         recalcarc $a
8337                     }
8338                 }
8339             }
8340             foreach id [array names idheads] {
8341                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
8342                     [llength $allparents($id)] == 1} {
8343                     set a [lindex $arcnos($id) 0]
8344                     if {$archeads($a) eq {}} {
8345                         recalcarc $a
8346                     }
8347                 }
8348             }
8349             foreach id [lsort -unique $possible_seeds] {
8350                 if {$arcnos($id) eq {}} {
8351                     lappend seeds $id
8352                 }
8353             }
8354             set allcwait 0
8355         } else {
8356             while {[incr a] <= $lim} {
8357                 set line [gets $f]
8358                 if {[llength $line] != 3} {error "bad line"}
8359                 set s [lindex $line 0]
8360                 set arcstart($a) $s
8361                 lappend arcout($s) $a
8362                 if {![info exists arcnos($s)]} {
8363                     lappend possible_seeds $s
8364                     set arcnos($s) {}
8365                 }
8366                 set e [lindex $line 1]
8367                 if {$e eq {}} {
8368                     set growing($a) 1
8369                 } else {
8370                     set arcend($a) $e
8371                     if {![info exists arcout($e)]} {
8372                         set arcout($e) {}
8373                     }
8374                 }
8375                 set arcids($a) [lindex $line 2]
8376                 foreach id $arcids($a) {
8377                     lappend allparents($s) $id
8378                     set s $id
8379                     lappend arcnos($id) $a
8380                 }
8381                 if {![info exists allparents($s)]} {
8382                     set allparents($s) {}
8383                 }
8384                 set arctags($a) {}
8385                 set archeads($a) {}
8386             }
8387             set nextarc [expr {$a - 1}]
8388         }
8389     } err]} {
8390         dropcache $err
8391         return 0
8392     }
8393     if {!$allcwait} {
8394         getallcommits
8395     }
8396     return $allcwait
8399 proc getcache {f} {
8400     global nextarc cachedarcs possible_seeds
8402     if {[catch {
8403         set line [gets $f]
8404         if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
8405         # make sure it's an integer
8406         set cachedarcs [expr {int([lindex $line 1])}]
8407         if {$cachedarcs < 0} {error "bad number of arcs"}
8408         set nextarc 0
8409         set possible_seeds {}
8410         run readcache $f
8411     } err]} {
8412         dropcache $err
8413     }
8414     return 0
8417 proc dropcache {err} {
8418     global allcwait nextarc cachedarcs seeds
8420     #puts "dropping cache ($err)"
8421     foreach v {arcnos arcout arcids arcstart arcend growing \
8422                    arctags archeads allparents allchildren} {
8423         global $v
8424         catch {unset $v}
8425     }
8426     set allcwait 0
8427     set nextarc 0
8428     set cachedarcs 0
8429     set seeds {}
8430     getallcommits
8433 proc writecache {f} {
8434     global cachearc cachedarcs allccache
8435     global arcstart arcend arcnos arcids arcout
8437     set a $cachearc
8438     set lim $cachedarcs
8439     if {$lim - $a > 1000} {
8440         set lim [expr {$a + 1000}]
8441     }
8442     if {[catch {
8443         while {[incr a] <= $lim} {
8444             if {[info exists arcend($a)]} {
8445                 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
8446             } else {
8447                 puts $f [list $arcstart($a) {} $arcids($a)]
8448             }
8449         }
8450     } err]} {
8451         catch {close $f}
8452         catch {file delete $allccache}
8453         #puts "writing cache failed ($err)"
8454         return 0
8455     }
8456     set cachearc [expr {$a - 1}]
8457     if {$a > $cachedarcs} {
8458         puts $f "1"
8459         close $f
8460         return 0
8461     }
8462     return 1
8465 proc savecache {} {
8466     global nextarc cachedarcs cachearc allccache
8468     if {$nextarc == $cachedarcs} return
8469     set cachearc 0
8470     set cachedarcs $nextarc
8471     catch {
8472         set f [open $allccache w]
8473         puts $f [list 1 $cachedarcs]
8474         run writecache $f
8475     }
8478 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
8479 # or 0 if neither is true.
8480 proc anc_or_desc {a b} {
8481     global arcout arcstart arcend arcnos cached_isanc
8483     if {$arcnos($a) eq $arcnos($b)} {
8484         # Both are on the same arc(s); either both are the same BMP,
8485         # or if one is not a BMP, the other is also not a BMP or is
8486         # the BMP at end of the arc (and it only has 1 incoming arc).
8487         # Or both can be BMPs with no incoming arcs.
8488         if {$a eq $b || $arcnos($a) eq {}} {
8489             return 0
8490         }
8491         # assert {[llength $arcnos($a)] == 1}
8492         set arc [lindex $arcnos($a) 0]
8493         set i [lsearch -exact $arcids($arc) $a]
8494         set j [lsearch -exact $arcids($arc) $b]
8495         if {$i < 0 || $i > $j} {
8496             return 1
8497         } else {
8498             return -1
8499         }
8500     }
8502     if {![info exists arcout($a)]} {
8503         set arc [lindex $arcnos($a) 0]
8504         if {[info exists arcend($arc)]} {
8505             set aend $arcend($arc)
8506         } else {
8507             set aend {}
8508         }
8509         set a $arcstart($arc)
8510     } else {
8511         set aend $a
8512     }
8513     if {![info exists arcout($b)]} {
8514         set arc [lindex $arcnos($b) 0]
8515         if {[info exists arcend($arc)]} {
8516             set bend $arcend($arc)
8517         } else {
8518             set bend {}
8519         }
8520         set b $arcstart($arc)
8521     } else {
8522         set bend $b
8523     }
8524     if {$a eq $bend} {
8525         return 1
8526     }
8527     if {$b eq $aend} {
8528         return -1
8529     }
8530     if {[info exists cached_isanc($a,$bend)]} {
8531         if {$cached_isanc($a,$bend)} {
8532             return 1
8533         }
8534     }
8535     if {[info exists cached_isanc($b,$aend)]} {
8536         if {$cached_isanc($b,$aend)} {
8537             return -1
8538         }
8539         if {[info exists cached_isanc($a,$bend)]} {
8540             return 0
8541         }
8542     }
8544     set todo [list $a $b]
8545     set anc($a) a
8546     set anc($b) b
8547     for {set i 0} {$i < [llength $todo]} {incr i} {
8548         set x [lindex $todo $i]
8549         if {$anc($x) eq {}} {
8550             continue
8551         }
8552         foreach arc $arcnos($x) {
8553             set xd $arcstart($arc)
8554             if {$xd eq $bend} {
8555                 set cached_isanc($a,$bend) 1
8556                 set cached_isanc($b,$aend) 0
8557                 return 1
8558             } elseif {$xd eq $aend} {
8559                 set cached_isanc($b,$aend) 1
8560                 set cached_isanc($a,$bend) 0
8561                 return -1
8562             }
8563             if {![info exists anc($xd)]} {
8564                 set anc($xd) $anc($x)
8565                 lappend todo $xd
8566             } elseif {$anc($xd) ne $anc($x)} {
8567                 set anc($xd) {}
8568             }
8569         }
8570     }
8571     set cached_isanc($a,$bend) 0
8572     set cached_isanc($b,$aend) 0
8573     return 0
8576 # This identifies whether $desc has an ancestor that is
8577 # a growing tip of the graph and which is not an ancestor of $anc
8578 # and returns 0 if so and 1 if not.
8579 # If we subsequently discover a tag on such a growing tip, and that
8580 # turns out to be a descendent of $anc (which it could, since we
8581 # don't necessarily see children before parents), then $desc
8582 # isn't a good choice to display as a descendent tag of
8583 # $anc (since it is the descendent of another tag which is
8584 # a descendent of $anc).  Similarly, $anc isn't a good choice to
8585 # display as a ancestor tag of $desc.
8587 proc is_certain {desc anc} {
8588     global arcnos arcout arcstart arcend growing problems
8590     set certain {}
8591     if {[llength $arcnos($anc)] == 1} {
8592         # tags on the same arc are certain
8593         if {$arcnos($desc) eq $arcnos($anc)} {
8594             return 1
8595         }
8596         if {![info exists arcout($anc)]} {
8597             # if $anc is partway along an arc, use the start of the arc instead
8598             set a [lindex $arcnos($anc) 0]
8599             set anc $arcstart($a)
8600         }
8601     }
8602     if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
8603         set x $desc
8604     } else {
8605         set a [lindex $arcnos($desc) 0]
8606         set x $arcend($a)
8607     }
8608     if {$x == $anc} {
8609         return 1
8610     }
8611     set anclist [list $x]
8612     set dl($x) 1
8613     set nnh 1
8614     set ngrowanc 0
8615     for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
8616         set x [lindex $anclist $i]
8617         if {$dl($x)} {
8618             incr nnh -1
8619         }
8620         set done($x) 1
8621         foreach a $arcout($x) {
8622             if {[info exists growing($a)]} {
8623                 if {![info exists growanc($x)] && $dl($x)} {
8624                     set growanc($x) 1
8625                     incr ngrowanc
8626                 }
8627             } else {
8628                 set y $arcend($a)
8629                 if {[info exists dl($y)]} {
8630                     if {$dl($y)} {
8631                         if {!$dl($x)} {
8632                             set dl($y) 0
8633                             if {![info exists done($y)]} {
8634                                 incr nnh -1
8635                             }
8636                             if {[info exists growanc($x)]} {
8637                                 incr ngrowanc -1
8638                             }
8639                             set xl [list $y]
8640                             for {set k 0} {$k < [llength $xl]} {incr k} {
8641                                 set z [lindex $xl $k]
8642                                 foreach c $arcout($z) {
8643                                     if {[info exists arcend($c)]} {
8644                                         set v $arcend($c)
8645                                         if {[info exists dl($v)] && $dl($v)} {
8646                                             set dl($v) 0
8647                                             if {![info exists done($v)]} {
8648                                                 incr nnh -1
8649                                             }
8650                                             if {[info exists growanc($v)]} {
8651                                                 incr ngrowanc -1
8652                                             }
8653                                             lappend xl $v
8654                                         }
8655                                     }
8656                                 }
8657                             }
8658                         }
8659                     }
8660                 } elseif {$y eq $anc || !$dl($x)} {
8661                     set dl($y) 0
8662                     lappend anclist $y
8663                 } else {
8664                     set dl($y) 1
8665                     lappend anclist $y
8666                     incr nnh
8667                 }
8668             }
8669         }
8670     }
8671     foreach x [array names growanc] {
8672         if {$dl($x)} {
8673             return 0
8674         }
8675         return 0
8676     }
8677     return 1
8680 proc validate_arctags {a} {
8681     global arctags idtags
8683     set i -1
8684     set na $arctags($a)
8685     foreach id $arctags($a) {
8686         incr i
8687         if {![info exists idtags($id)]} {
8688             set na [lreplace $na $i $i]
8689             incr i -1
8690         }
8691     }
8692     set arctags($a) $na
8695 proc validate_archeads {a} {
8696     global archeads idheads
8698     set i -1
8699     set na $archeads($a)
8700     foreach id $archeads($a) {
8701         incr i
8702         if {![info exists idheads($id)]} {
8703             set na [lreplace $na $i $i]
8704             incr i -1
8705         }
8706     }
8707     set archeads($a) $na
8710 # Return the list of IDs that have tags that are descendents of id,
8711 # ignoring IDs that are descendents of IDs already reported.
8712 proc desctags {id} {
8713     global arcnos arcstart arcids arctags idtags allparents
8714     global growing cached_dtags
8716     if {![info exists allparents($id)]} {
8717         return {}
8718     }
8719     set t1 [clock clicks -milliseconds]
8720     set argid $id
8721     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8722         # part-way along an arc; check that arc first
8723         set a [lindex $arcnos($id) 0]
8724         if {$arctags($a) ne {}} {
8725             validate_arctags $a
8726             set i [lsearch -exact $arcids($a) $id]
8727             set tid {}
8728             foreach t $arctags($a) {
8729                 set j [lsearch -exact $arcids($a) $t]
8730                 if {$j >= $i} break
8731                 set tid $t
8732             }
8733             if {$tid ne {}} {
8734                 return $tid
8735             }
8736         }
8737         set id $arcstart($a)
8738         if {[info exists idtags($id)]} {
8739             return $id
8740         }
8741     }
8742     if {[info exists cached_dtags($id)]} {
8743         return $cached_dtags($id)
8744     }
8746     set origid $id
8747     set todo [list $id]
8748     set queued($id) 1
8749     set nc 1
8750     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8751         set id [lindex $todo $i]
8752         set done($id) 1
8753         set ta [info exists hastaggedancestor($id)]
8754         if {!$ta} {
8755             incr nc -1
8756         }
8757         # ignore tags on starting node
8758         if {!$ta && $i > 0} {
8759             if {[info exists idtags($id)]} {
8760                 set tagloc($id) $id
8761                 set ta 1
8762             } elseif {[info exists cached_dtags($id)]} {
8763                 set tagloc($id) $cached_dtags($id)
8764                 set ta 1
8765             }
8766         }
8767         foreach a $arcnos($id) {
8768             set d $arcstart($a)
8769             if {!$ta && $arctags($a) ne {}} {
8770                 validate_arctags $a
8771                 if {$arctags($a) ne {}} {
8772                     lappend tagloc($id) [lindex $arctags($a) end]
8773                 }
8774             }
8775             if {$ta || $arctags($a) ne {}} {
8776                 set tomark [list $d]
8777                 for {set j 0} {$j < [llength $tomark]} {incr j} {
8778                     set dd [lindex $tomark $j]
8779                     if {![info exists hastaggedancestor($dd)]} {
8780                         if {[info exists done($dd)]} {
8781                             foreach b $arcnos($dd) {
8782                                 lappend tomark $arcstart($b)
8783                             }
8784                             if {[info exists tagloc($dd)]} {
8785                                 unset tagloc($dd)
8786                             }
8787                         } elseif {[info exists queued($dd)]} {
8788                             incr nc -1
8789                         }
8790                         set hastaggedancestor($dd) 1
8791                     }
8792                 }
8793             }
8794             if {![info exists queued($d)]} {
8795                 lappend todo $d
8796                 set queued($d) 1
8797                 if {![info exists hastaggedancestor($d)]} {
8798                     incr nc
8799                 }
8800             }
8801         }
8802     }
8803     set tags {}
8804     foreach id [array names tagloc] {
8805         if {![info exists hastaggedancestor($id)]} {
8806             foreach t $tagloc($id) {
8807                 if {[lsearch -exact $tags $t] < 0} {
8808                     lappend tags $t
8809                 }
8810             }
8811         }
8812     }
8813     set t2 [clock clicks -milliseconds]
8814     set loopix $i
8816     # remove tags that are descendents of other tags
8817     for {set i 0} {$i < [llength $tags]} {incr i} {
8818         set a [lindex $tags $i]
8819         for {set j 0} {$j < $i} {incr j} {
8820             set b [lindex $tags $j]
8821             set r [anc_or_desc $a $b]
8822             if {$r == 1} {
8823                 set tags [lreplace $tags $j $j]
8824                 incr j -1
8825                 incr i -1
8826             } elseif {$r == -1} {
8827                 set tags [lreplace $tags $i $i]
8828                 incr i -1
8829                 break
8830             }
8831         }
8832     }
8834     if {[array names growing] ne {}} {
8835         # graph isn't finished, need to check if any tag could get
8836         # eclipsed by another tag coming later.  Simply ignore any
8837         # tags that could later get eclipsed.
8838         set ctags {}
8839         foreach t $tags {
8840             if {[is_certain $t $origid]} {
8841                 lappend ctags $t
8842             }
8843         }
8844         if {$tags eq $ctags} {
8845             set cached_dtags($origid) $tags
8846         } else {
8847             set tags $ctags
8848         }
8849     } else {
8850         set cached_dtags($origid) $tags
8851     }
8852     set t3 [clock clicks -milliseconds]
8853     if {0 && $t3 - $t1 >= 100} {
8854         puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8855             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8856     }
8857     return $tags
8860 proc anctags {id} {
8861     global arcnos arcids arcout arcend arctags idtags allparents
8862     global growing cached_atags
8864     if {![info exists allparents($id)]} {
8865         return {}
8866     }
8867     set t1 [clock clicks -milliseconds]
8868     set argid $id
8869     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8870         # part-way along an arc; check that arc first
8871         set a [lindex $arcnos($id) 0]
8872         if {$arctags($a) ne {}} {
8873             validate_arctags $a
8874             set i [lsearch -exact $arcids($a) $id]
8875             foreach t $arctags($a) {
8876                 set j [lsearch -exact $arcids($a) $t]
8877                 if {$j > $i} {
8878                     return $t
8879                 }
8880             }
8881         }
8882         if {![info exists arcend($a)]} {
8883             return {}
8884         }
8885         set id $arcend($a)
8886         if {[info exists idtags($id)]} {
8887             return $id
8888         }
8889     }
8890     if {[info exists cached_atags($id)]} {
8891         return $cached_atags($id)
8892     }
8894     set origid $id
8895     set todo [list $id]
8896     set queued($id) 1
8897     set taglist {}
8898     set nc 1
8899     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8900         set id [lindex $todo $i]
8901         set done($id) 1
8902         set td [info exists hastaggeddescendent($id)]
8903         if {!$td} {
8904             incr nc -1
8905         }
8906         # ignore tags on starting node
8907         if {!$td && $i > 0} {
8908             if {[info exists idtags($id)]} {
8909                 set tagloc($id) $id
8910                 set td 1
8911             } elseif {[info exists cached_atags($id)]} {
8912                 set tagloc($id) $cached_atags($id)
8913                 set td 1
8914             }
8915         }
8916         foreach a $arcout($id) {
8917             if {!$td && $arctags($a) ne {}} {
8918                 validate_arctags $a
8919                 if {$arctags($a) ne {}} {
8920                     lappend tagloc($id) [lindex $arctags($a) 0]
8921                 }
8922             }
8923             if {![info exists arcend($a)]} continue
8924             set d $arcend($a)
8925             if {$td || $arctags($a) ne {}} {
8926                 set tomark [list $d]
8927                 for {set j 0} {$j < [llength $tomark]} {incr j} {
8928                     set dd [lindex $tomark $j]
8929                     if {![info exists hastaggeddescendent($dd)]} {
8930                         if {[info exists done($dd)]} {
8931                             foreach b $arcout($dd) {
8932                                 if {[info exists arcend($b)]} {
8933                                     lappend tomark $arcend($b)
8934                                 }
8935                             }
8936                             if {[info exists tagloc($dd)]} {
8937                                 unset tagloc($dd)
8938                             }
8939                         } elseif {[info exists queued($dd)]} {
8940                             incr nc -1
8941                         }
8942                         set hastaggeddescendent($dd) 1
8943                     }
8944                 }
8945             }
8946             if {![info exists queued($d)]} {
8947                 lappend todo $d
8948                 set queued($d) 1
8949                 if {![info exists hastaggeddescendent($d)]} {
8950                     incr nc
8951                 }
8952             }
8953         }
8954     }
8955     set t2 [clock clicks -milliseconds]
8956     set loopix $i
8957     set tags {}
8958     foreach id [array names tagloc] {
8959         if {![info exists hastaggeddescendent($id)]} {
8960             foreach t $tagloc($id) {
8961                 if {[lsearch -exact $tags $t] < 0} {
8962                     lappend tags $t
8963                 }
8964             }
8965         }
8966     }
8968     # remove tags that are ancestors of other tags
8969     for {set i 0} {$i < [llength $tags]} {incr i} {
8970         set a [lindex $tags $i]
8971         for {set j 0} {$j < $i} {incr j} {
8972             set b [lindex $tags $j]
8973             set r [anc_or_desc $a $b]
8974             if {$r == -1} {
8975                 set tags [lreplace $tags $j $j]
8976                 incr j -1
8977                 incr i -1
8978             } elseif {$r == 1} {
8979                 set tags [lreplace $tags $i $i]
8980                 incr i -1
8981                 break
8982             }
8983         }
8984     }
8986     if {[array names growing] ne {}} {
8987         # graph isn't finished, need to check if any tag could get
8988         # eclipsed by another tag coming later.  Simply ignore any
8989         # tags that could later get eclipsed.
8990         set ctags {}
8991         foreach t $tags {
8992             if {[is_certain $origid $t]} {
8993                 lappend ctags $t
8994             }
8995         }
8996         if {$tags eq $ctags} {
8997             set cached_atags($origid) $tags
8998         } else {
8999             set tags $ctags
9000         }
9001     } else {
9002         set cached_atags($origid) $tags
9003     }
9004     set t3 [clock clicks -milliseconds]
9005     if {0 && $t3 - $t1 >= 100} {
9006         puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9007             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9008     }
9009     return $tags
9012 # Return the list of IDs that have heads that are descendents of id,
9013 # including id itself if it has a head.
9014 proc descheads {id} {
9015     global arcnos arcstart arcids archeads idheads cached_dheads
9016     global allparents
9018     if {![info exists allparents($id)]} {
9019         return {}
9020     }
9021     set aret {}
9022     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9023         # part-way along an arc; check it first
9024         set a [lindex $arcnos($id) 0]
9025         if {$archeads($a) ne {}} {
9026             validate_archeads $a
9027             set i [lsearch -exact $arcids($a) $id]
9028             foreach t $archeads($a) {
9029                 set j [lsearch -exact $arcids($a) $t]
9030                 if {$j > $i} break
9031                 lappend aret $t
9032             }
9033         }
9034         set id $arcstart($a)
9035     }
9036     set origid $id
9037     set todo [list $id]
9038     set seen($id) 1
9039     set ret {}
9040     for {set i 0} {$i < [llength $todo]} {incr i} {
9041         set id [lindex $todo $i]
9042         if {[info exists cached_dheads($id)]} {
9043             set ret [concat $ret $cached_dheads($id)]
9044         } else {
9045             if {[info exists idheads($id)]} {
9046                 lappend ret $id
9047             }
9048             foreach a $arcnos($id) {
9049                 if {$archeads($a) ne {}} {
9050                     validate_archeads $a
9051                     if {$archeads($a) ne {}} {
9052                         set ret [concat $ret $archeads($a)]
9053                     }
9054                 }
9055                 set d $arcstart($a)
9056                 if {![info exists seen($d)]} {
9057                     lappend todo $d
9058                     set seen($d) 1
9059                 }
9060             }
9061         }
9062     }
9063     set ret [lsort -unique $ret]
9064     set cached_dheads($origid) $ret
9065     return [concat $ret $aret]
9068 proc addedtag {id} {
9069     global arcnos arcout cached_dtags cached_atags
9071     if {![info exists arcnos($id)]} return
9072     if {![info exists arcout($id)]} {
9073         recalcarc [lindex $arcnos($id) 0]
9074     }
9075     catch {unset cached_dtags}
9076     catch {unset cached_atags}
9079 proc addedhead {hid head} {
9080     global arcnos arcout cached_dheads
9082     if {![info exists arcnos($hid)]} return
9083     if {![info exists arcout($hid)]} {
9084         recalcarc [lindex $arcnos($hid) 0]
9085     }
9086     catch {unset cached_dheads}
9089 proc removedhead {hid head} {
9090     global cached_dheads
9092     catch {unset cached_dheads}
9095 proc movedhead {hid head} {
9096     global arcnos arcout cached_dheads
9098     if {![info exists arcnos($hid)]} return
9099     if {![info exists arcout($hid)]} {
9100         recalcarc [lindex $arcnos($hid) 0]
9101     }
9102     catch {unset cached_dheads}
9105 proc changedrefs {} {
9106     global cached_dheads cached_dtags cached_atags
9107     global arctags archeads arcnos arcout idheads idtags
9109     foreach id [concat [array names idheads] [array names idtags]] {
9110         if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9111             set a [lindex $arcnos($id) 0]
9112             if {![info exists donearc($a)]} {
9113                 recalcarc $a
9114                 set donearc($a) 1
9115             }
9116         }
9117     }
9118     catch {unset cached_dtags}
9119     catch {unset cached_atags}
9120     catch {unset cached_dheads}
9123 proc rereadrefs {} {
9124     global idtags idheads idotherrefs mainheadid
9126     set refids [concat [array names idtags] \
9127                     [array names idheads] [array names idotherrefs]]
9128     foreach id $refids {
9129         if {![info exists ref($id)]} {
9130             set ref($id) [listrefs $id]
9131         }
9132     }
9133     set oldmainhead $mainheadid
9134     readrefs
9135     changedrefs
9136     set refids [lsort -unique [concat $refids [array names idtags] \
9137                         [array names idheads] [array names idotherrefs]]]
9138     foreach id $refids {
9139         set v [listrefs $id]
9140         if {![info exists ref($id)] || $ref($id) != $v} {
9141             redrawtags $id
9142         }
9143     }
9144     if {$oldmainhead ne $mainheadid} {
9145         redrawtags $oldmainhead
9146         redrawtags $mainheadid
9147     }
9148     run refill_reflist
9151 proc listrefs {id} {
9152     global idtags idheads idotherrefs
9154     set x {}
9155     if {[info exists idtags($id)]} {
9156         set x $idtags($id)
9157     }
9158     set y {}
9159     if {[info exists idheads($id)]} {
9160         set y $idheads($id)
9161     }
9162     set z {}
9163     if {[info exists idotherrefs($id)]} {
9164         set z $idotherrefs($id)
9165     }
9166     return [list $x $y $z]
9169 proc showtag {tag isnew} {
9170     global ctext tagcontents tagids linknum tagobjid
9172     if {$isnew} {
9173         addtohistory [list showtag $tag 0]
9174     }
9175     $ctext conf -state normal
9176     clear_ctext
9177     settabs 0
9178     set linknum 0
9179     if {![info exists tagcontents($tag)]} {
9180         catch {
9181             set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9182         }
9183     }
9184     if {[info exists tagcontents($tag)]} {
9185         set text $tagcontents($tag)
9186     } else {
9187         set text "[mc "Tag"]: $tag\n[mc "Id"]:  $tagids($tag)"
9188     }
9189     appendwithlinks $text {}
9190     $ctext conf -state disabled
9191     init_flist {}
9194 proc doquit {} {
9195     global stopped
9196     global gitktmpdir
9198     set stopped 100
9199     savestuff .
9200     destroy .
9202     if {[info exists gitktmpdir]} {
9203         catch {file delete -force $gitktmpdir}
9204     }
9207 proc mkfontdisp {font top which} {
9208     global fontattr fontpref $font
9210     set fontpref($font) [set $font]
9211     button $top.${font}but -text $which -font optionfont \
9212         -command [list choosefont $font $which]
9213     label $top.$font -relief flat -font $font \
9214         -text $fontattr($font,family) -justify left
9215     grid x $top.${font}but $top.$font -sticky w
9218 proc choosefont {font which} {
9219     global fontparam fontlist fonttop fontattr
9221     set fontparam(which) $which
9222     set fontparam(font) $font
9223     set fontparam(family) [font actual $font -family]
9224     set fontparam(size) $fontattr($font,size)
9225     set fontparam(weight) $fontattr($font,weight)
9226     set fontparam(slant) $fontattr($font,slant)
9227     set top .gitkfont
9228     set fonttop $top
9229     if {![winfo exists $top]} {
9230         font create sample
9231         eval font config sample [font actual $font]
9232         toplevel $top
9233         wm title $top [mc "Gitk font chooser"]
9234         label $top.l -textvariable fontparam(which)
9235         pack $top.l -side top
9236         set fontlist [lsort [font families]]
9237         frame $top.f
9238         listbox $top.f.fam -listvariable fontlist \
9239             -yscrollcommand [list $top.f.sb set]
9240         bind $top.f.fam <<ListboxSelect>> selfontfam
9241         scrollbar $top.f.sb -command [list $top.f.fam yview]
9242         pack $top.f.sb -side right -fill y
9243         pack $top.f.fam -side left -fill both -expand 1
9244         pack $top.f -side top -fill both -expand 1
9245         frame $top.g
9246         spinbox $top.g.size -from 4 -to 40 -width 4 \
9247             -textvariable fontparam(size) \
9248             -validatecommand {string is integer -strict %s}
9249         checkbutton $top.g.bold -padx 5 \
9250             -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9251             -variable fontparam(weight) -onvalue bold -offvalue normal
9252         checkbutton $top.g.ital -padx 5 \
9253             -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0  \
9254             -variable fontparam(slant) -onvalue italic -offvalue roman
9255         pack $top.g.size $top.g.bold $top.g.ital -side left
9256         pack $top.g -side top
9257         canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9258             -background white
9259         $top.c create text 100 25 -anchor center -text $which -font sample \
9260             -fill black -tags text
9261         bind $top.c <Configure> [list centertext $top.c]
9262         pack $top.c -side top -fill x
9263         frame $top.buts
9264         button $top.buts.ok -text [mc "OK"] -command fontok -default active
9265         button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9266         grid $top.buts.ok $top.buts.can
9267         grid columnconfigure $top.buts 0 -weight 1 -uniform a
9268         grid columnconfigure $top.buts 1 -weight 1 -uniform a
9269         pack $top.buts -side bottom -fill x
9270         trace add variable fontparam write chg_fontparam
9271     } else {
9272         raise $top
9273         $top.c itemconf text -text $which
9274     }
9275     set i [lsearch -exact $fontlist $fontparam(family)]
9276     if {$i >= 0} {
9277         $top.f.fam selection set $i
9278         $top.f.fam see $i
9279     }
9282 proc centertext {w} {
9283     $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
9286 proc fontok {} {
9287     global fontparam fontpref prefstop
9289     set f $fontparam(font)
9290     set fontpref($f) [list $fontparam(family) $fontparam(size)]
9291     if {$fontparam(weight) eq "bold"} {
9292         lappend fontpref($f) "bold"
9293     }
9294     if {$fontparam(slant) eq "italic"} {
9295         lappend fontpref($f) "italic"
9296     }
9297     set w $prefstop.$f
9298     $w conf -text $fontparam(family) -font $fontpref($f)
9299         
9300     fontcan
9303 proc fontcan {} {
9304     global fonttop fontparam
9306     if {[info exists fonttop]} {
9307         catch {destroy $fonttop}
9308         catch {font delete sample}
9309         unset fonttop
9310         unset fontparam
9311     }
9314 proc selfontfam {} {
9315     global fonttop fontparam
9317     set i [$fonttop.f.fam curselection]
9318     if {$i ne {}} {
9319         set fontparam(family) [$fonttop.f.fam get $i]
9320     }
9323 proc chg_fontparam {v sub op} {
9324     global fontparam
9326     font config sample -$sub $fontparam($sub)
9329 proc doprefs {} {
9330     global maxwidth maxgraphpct
9331     global oldprefs prefstop showneartags showlocalchanges
9332     global bgcolor fgcolor ctext diffcolors selectbgcolor
9333     global tabstop limitdiffs autoselect extdifftool perfile_attrs
9335     set top .gitkprefs
9336     set prefstop $top
9337     if {[winfo exists $top]} {
9338         raise $top
9339         return
9340     }
9341     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9342                    limitdiffs tabstop perfile_attrs} {
9343         set oldprefs($v) [set $v]
9344     }
9345     toplevel $top
9346     wm title $top [mc "Gitk preferences"]
9347     label $top.ldisp -text [mc "Commit list display options"]
9348     grid $top.ldisp - -sticky w -pady 10
9349     label $top.spacer -text " "
9350     label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
9351         -font optionfont
9352     spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
9353     grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
9354     label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
9355         -font optionfont
9356     spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
9357     grid x $top.maxpctl $top.maxpct -sticky w
9358     frame $top.showlocal
9359     label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
9360     checkbutton $top.showlocal.b -variable showlocalchanges
9361     pack $top.showlocal.b $top.showlocal.l -side left
9362     grid x $top.showlocal -sticky w
9363     frame $top.autoselect
9364     label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
9365     checkbutton $top.autoselect.b -variable autoselect
9366     pack $top.autoselect.b $top.autoselect.l -side left
9367     grid x $top.autoselect -sticky w
9369     label $top.ddisp -text [mc "Diff display options"]
9370     grid $top.ddisp - -sticky w -pady 10
9371     label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
9372     spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
9373     grid x $top.tabstopl $top.tabstop -sticky w
9374     frame $top.ntag
9375     label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
9376     checkbutton $top.ntag.b -variable showneartags
9377     pack $top.ntag.b $top.ntag.l -side left
9378     grid x $top.ntag -sticky w
9379     frame $top.ldiff
9380     label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
9381     checkbutton $top.ldiff.b -variable limitdiffs
9382     pack $top.ldiff.b $top.ldiff.l -side left
9383     grid x $top.ldiff -sticky w
9384     frame $top.lattr
9385     label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
9386     checkbutton $top.lattr.b -variable perfile_attrs
9387     pack $top.lattr.b $top.lattr.l -side left
9388     grid x $top.lattr -sticky w
9390     entry $top.extdifft -textvariable extdifftool
9391     frame $top.extdifff
9392     label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
9393         -padx 10
9394     button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
9395         -command choose_extdiff
9396     pack $top.extdifff.l $top.extdifff.b -side left
9397     grid x $top.extdifff $top.extdifft -sticky w
9399     label $top.cdisp -text [mc "Colors: press to choose"]
9400     grid $top.cdisp - -sticky w -pady 10
9401     label $top.bg -padx 40 -relief sunk -background $bgcolor
9402     button $top.bgbut -text [mc "Background"] -font optionfont \
9403         -command [list choosecolor bgcolor {} $top.bg background setbg]
9404     grid x $top.bgbut $top.bg -sticky w
9405     label $top.fg -padx 40 -relief sunk -background $fgcolor
9406     button $top.fgbut -text [mc "Foreground"] -font optionfont \
9407         -command [list choosecolor fgcolor {} $top.fg foreground setfg]
9408     grid x $top.fgbut $top.fg -sticky w
9409     label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
9410     button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
9411         -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
9412                       [list $ctext tag conf d0 -foreground]]
9413     grid x $top.diffoldbut $top.diffold -sticky w
9414     label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
9415     button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
9416         -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
9417                       [list $ctext tag conf d1 -foreground]]
9418     grid x $top.diffnewbut $top.diffnew -sticky w
9419     label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
9420     button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
9421         -command [list choosecolor diffcolors 2 $top.hunksep \
9422                       "diff hunk header" \
9423                       [list $ctext tag conf hunksep -foreground]]
9424     grid x $top.hunksepbut $top.hunksep -sticky w
9425     label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
9426     button $top.selbgbut -text [mc "Select bg"] -font optionfont \
9427         -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
9428     grid x $top.selbgbut $top.selbgsep -sticky w
9430     label $top.cfont -text [mc "Fonts: press to choose"]
9431     grid $top.cfont - -sticky w -pady 10
9432     mkfontdisp mainfont $top [mc "Main font"]
9433     mkfontdisp textfont $top [mc "Diff display font"]
9434     mkfontdisp uifont $top [mc "User interface font"]
9436     frame $top.buts
9437     button $top.buts.ok -text [mc "OK"] -command prefsok -default active
9438     button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
9439     grid $top.buts.ok $top.buts.can
9440     grid columnconfigure $top.buts 0 -weight 1 -uniform a
9441     grid columnconfigure $top.buts 1 -weight 1 -uniform a
9442     grid $top.buts - - -pady 10 -sticky ew
9443     bind $top <Visibility> "focus $top.buts.ok"
9446 proc choose_extdiff {} {
9447     global extdifftool
9449     set prog [tk_getOpenFile -title "External diff tool" -multiple false]
9450     if {$prog ne {}} {
9451         set extdifftool $prog
9452     }
9455 proc choosecolor {v vi w x cmd} {
9456     global $v
9458     set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
9459                -title [mc "Gitk: choose color for %s" $x]]
9460     if {$c eq {}} return
9461     $w conf -background $c
9462     lset $v $vi $c
9463     eval $cmd $c
9466 proc setselbg {c} {
9467     global bglist cflist
9468     foreach w $bglist {
9469         $w configure -selectbackground $c
9470     }
9471     $cflist tag configure highlight \
9472         -background [$cflist cget -selectbackground]
9473     allcanvs itemconf secsel -fill $c
9476 proc setbg {c} {
9477     global bglist
9479     foreach w $bglist {
9480         $w conf -background $c
9481     }
9484 proc setfg {c} {
9485     global fglist canv
9487     foreach w $fglist {
9488         $w conf -foreground $c
9489     }
9490     allcanvs itemconf text -fill $c
9491     $canv itemconf circle -outline $c
9494 proc prefscan {} {
9495     global oldprefs prefstop
9497     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
9498                    limitdiffs tabstop perfile_attrs} {
9499         global $v
9500         set $v $oldprefs($v)
9501     }
9502     catch {destroy $prefstop}
9503     unset prefstop
9504     fontcan
9507 proc prefsok {} {
9508     global maxwidth maxgraphpct
9509     global oldprefs prefstop showneartags showlocalchanges
9510     global fontpref mainfont textfont uifont
9511     global limitdiffs treediffs perfile_attrs
9513     catch {destroy $prefstop}
9514     unset prefstop
9515     fontcan
9516     set fontchanged 0
9517     if {$mainfont ne $fontpref(mainfont)} {
9518         set mainfont $fontpref(mainfont)
9519         parsefont mainfont $mainfont
9520         eval font configure mainfont [fontflags mainfont]
9521         eval font configure mainfontbold [fontflags mainfont 1]
9522         setcoords
9523         set fontchanged 1
9524     }
9525     if {$textfont ne $fontpref(textfont)} {
9526         set textfont $fontpref(textfont)
9527         parsefont textfont $textfont
9528         eval font configure textfont [fontflags textfont]
9529         eval font configure textfontbold [fontflags textfont 1]
9530     }
9531     if {$uifont ne $fontpref(uifont)} {
9532         set uifont $fontpref(uifont)
9533         parsefont uifont $uifont
9534         eval font configure uifont [fontflags uifont]
9535     }
9536     settabs
9537     if {$showlocalchanges != $oldprefs(showlocalchanges)} {
9538         if {$showlocalchanges} {
9539             doshowlocalchanges
9540         } else {
9541             dohidelocalchanges
9542         }
9543     }
9544     if {$limitdiffs != $oldprefs(limitdiffs) ||
9545         ($perfile_attrs && !$oldprefs(perfile_attrs))} {
9546         # treediffs elements are limited by path;
9547         # won't have encodings cached if perfile_attrs was just turned on
9548         catch {unset treediffs}
9549     }
9550     if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
9551         || $maxgraphpct != $oldprefs(maxgraphpct)} {
9552         redisplay
9553     } elseif {$showneartags != $oldprefs(showneartags) ||
9554           $limitdiffs != $oldprefs(limitdiffs)} {
9555         reselectline
9556     }
9559 proc formatdate {d} {
9560     global datetimeformat
9561     if {$d ne {}} {
9562         set d [clock format $d -format $datetimeformat]
9563     }
9564     return $d
9567 # This list of encoding names and aliases is distilled from
9568 # http://www.iana.org/assignments/character-sets.
9569 # Not all of them are supported by Tcl.
9570 set encoding_aliases {
9571     { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
9572       ISO646-US US-ASCII us IBM367 cp367 csASCII }
9573     { ISO-10646-UTF-1 csISO10646UTF1 }
9574     { ISO_646.basic:1983 ref csISO646basic1983 }
9575     { INVARIANT csINVARIANT }
9576     { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
9577     { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
9578     { NATS-SEFI iso-ir-8-1 csNATSSEFI }
9579     { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
9580     { NATS-DANO iso-ir-9-1 csNATSDANO }
9581     { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
9582     { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
9583     { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
9584     { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
9585     { ISO-2022-KR csISO2022KR }
9586     { EUC-KR csEUCKR }
9587     { ISO-2022-JP csISO2022JP }
9588     { ISO-2022-JP-2 csISO2022JP2 }
9589     { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
9590       csISO13JISC6220jp }
9591     { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
9592     { IT iso-ir-15 ISO646-IT csISO15Italian }
9593     { PT iso-ir-16 ISO646-PT csISO16Portuguese }
9594     { ES iso-ir-17 ISO646-ES csISO17Spanish }
9595     { greek7-old iso-ir-18 csISO18Greek7Old }
9596     { latin-greek iso-ir-19 csISO19LatinGreek }
9597     { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
9598     { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
9599     { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
9600     { ISO_5427 iso-ir-37 csISO5427Cyrillic }
9601     { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
9602     { BS_viewdata iso-ir-47 csISO47BSViewdata }
9603     { INIS iso-ir-49 csISO49INIS }
9604     { INIS-8 iso-ir-50 csISO50INIS8 }
9605     { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
9606     { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
9607     { ISO_5428:1980 iso-ir-55 csISO5428Greek }
9608     { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
9609     { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
9610     { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
9611       csISO60Norwegian1 }
9612     { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
9613     { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
9614     { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
9615     { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
9616     { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
9617     { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
9618     { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
9619     { greek7 iso-ir-88 csISO88Greek7 }
9620     { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
9621     { iso-ir-90 csISO90 }
9622     { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
9623     { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
9624       csISO92JISC62991984b }
9625     { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
9626     { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
9627     { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
9628       csISO95JIS62291984handadd }
9629     { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
9630     { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
9631     { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
9632     { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
9633       CP819 csISOLatin1 }
9634     { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
9635     { T.61-7bit iso-ir-102 csISO102T617bit }
9636     { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
9637     { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
9638     { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
9639     { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
9640     { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
9641     { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
9642     { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
9643     { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
9644       arabic csISOLatinArabic }
9645     { ISO_8859-6-E csISO88596E ISO-8859-6-E }
9646     { ISO_8859-6-I csISO88596I ISO-8859-6-I }
9647     { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
9648       greek greek8 csISOLatinGreek }
9649     { T.101-G2 iso-ir-128 csISO128T101G2 }
9650     { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
9651       csISOLatinHebrew }
9652     { ISO_8859-8-E csISO88598E ISO-8859-8-E }
9653     { ISO_8859-8-I csISO88598I ISO-8859-8-I }
9654     { CSN_369103 iso-ir-139 csISO139CSN369103 }
9655     { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
9656     { ISO_6937-2-add iso-ir-142 csISOTextComm }
9657     { IEC_P27-1 iso-ir-143 csISO143IECP271 }
9658     { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
9659       csISOLatinCyrillic }
9660     { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
9661     { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
9662     { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
9663     { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
9664     { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
9665     { ISO_6937-2-25 iso-ir-152 csISO6937Add }
9666     { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
9667     { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
9668     { ISO_10367-box iso-ir-155 csISO10367Box }
9669     { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
9670     { latin-lap lap iso-ir-158 csISO158Lap }
9671     { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
9672     { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
9673     { us-dk csUSDK }
9674     { dk-us csDKUS }
9675     { JIS_X0201 X0201 csHalfWidthKatakana }
9676     { KSC5636 ISO646-KR csKSC5636 }
9677     { ISO-10646-UCS-2 csUnicode }
9678     { ISO-10646-UCS-4 csUCS4 }
9679     { DEC-MCS dec csDECMCS }
9680     { hp-roman8 roman8 r8 csHPRoman8 }
9681     { macintosh mac csMacintosh }
9682     { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
9683       csIBM037 }
9684     { IBM038 EBCDIC-INT cp038 csIBM038 }
9685     { IBM273 CP273 csIBM273 }
9686     { IBM274 EBCDIC-BE CP274 csIBM274 }
9687     { IBM275 EBCDIC-BR cp275 csIBM275 }
9688     { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
9689     { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
9690     { IBM280 CP280 ebcdic-cp-it csIBM280 }
9691     { IBM281 EBCDIC-JP-E cp281 csIBM281 }
9692     { IBM284 CP284 ebcdic-cp-es csIBM284 }
9693     { IBM285 CP285 ebcdic-cp-gb csIBM285 }
9694     { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
9695     { IBM297 cp297 ebcdic-cp-fr csIBM297 }
9696     { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
9697     { IBM423 cp423 ebcdic-cp-gr csIBM423 }
9698     { IBM424 cp424 ebcdic-cp-he csIBM424 }
9699     { IBM437 cp437 437 csPC8CodePage437 }
9700     { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
9701     { IBM775 cp775 csPC775Baltic }
9702     { IBM850 cp850 850 csPC850Multilingual }
9703     { IBM851 cp851 851 csIBM851 }
9704     { IBM852 cp852 852 csPCp852 }
9705     { IBM855 cp855 855 csIBM855 }
9706     { IBM857 cp857 857 csIBM857 }
9707     { IBM860 cp860 860 csIBM860 }
9708     { IBM861 cp861 861 cp-is csIBM861 }
9709     { IBM862 cp862 862 csPC862LatinHebrew }
9710     { IBM863 cp863 863 csIBM863 }
9711     { IBM864 cp864 csIBM864 }
9712     { IBM865 cp865 865 csIBM865 }
9713     { IBM866 cp866 866 csIBM866 }
9714     { IBM868 CP868 cp-ar csIBM868 }
9715     { IBM869 cp869 869 cp-gr csIBM869 }
9716     { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
9717     { IBM871 CP871 ebcdic-cp-is csIBM871 }
9718     { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
9719     { IBM891 cp891 csIBM891 }
9720     { IBM903 cp903 csIBM903 }
9721     { IBM904 cp904 904 csIBBM904 }
9722     { IBM905 CP905 ebcdic-cp-tr csIBM905 }
9723     { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
9724     { IBM1026 CP1026 csIBM1026 }
9725     { EBCDIC-AT-DE csIBMEBCDICATDE }
9726     { EBCDIC-AT-DE-A csEBCDICATDEA }
9727     { EBCDIC-CA-FR csEBCDICCAFR }
9728     { EBCDIC-DK-NO csEBCDICDKNO }
9729     { EBCDIC-DK-NO-A csEBCDICDKNOA }
9730     { EBCDIC-FI-SE csEBCDICFISE }
9731     { EBCDIC-FI-SE-A csEBCDICFISEA }
9732     { EBCDIC-FR csEBCDICFR }
9733     { EBCDIC-IT csEBCDICIT }
9734     { EBCDIC-PT csEBCDICPT }
9735     { EBCDIC-ES csEBCDICES }
9736     { EBCDIC-ES-A csEBCDICESA }
9737     { EBCDIC-ES-S csEBCDICESS }
9738     { EBCDIC-UK csEBCDICUK }
9739     { EBCDIC-US csEBCDICUS }
9740     { UNKNOWN-8BIT csUnknown8BiT }
9741     { MNEMONIC csMnemonic }
9742     { MNEM csMnem }
9743     { VISCII csVISCII }
9744     { VIQR csVIQR }
9745     { KOI8-R csKOI8R }
9746     { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
9747     { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
9748     { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
9749     { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
9750     { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
9751     { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
9752     { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
9753     { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
9754     { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
9755     { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
9756     { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
9757     { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
9758     { IBM1047 IBM-1047 }
9759     { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
9760     { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
9761     { UNICODE-1-1 csUnicode11 }
9762     { CESU-8 csCESU-8 }
9763     { BOCU-1 csBOCU-1 }
9764     { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
9765     { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
9766       l8 }
9767     { ISO-8859-15 ISO_8859-15 Latin-9 }
9768     { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
9769     { GBK CP936 MS936 windows-936 }
9770     { JIS_Encoding csJISEncoding }
9771     { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
9772     { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
9773       EUC-JP }
9774     { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
9775     { ISO-10646-UCS-Basic csUnicodeASCII }
9776     { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
9777     { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
9778     { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
9779     { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
9780     { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
9781     { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
9782     { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
9783     { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
9784     { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
9785     { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
9786     { Adobe-Standard-Encoding csAdobeStandardEncoding }
9787     { Ventura-US csVenturaUS }
9788     { Ventura-International csVenturaInternational }
9789     { PC8-Danish-Norwegian csPC8DanishNorwegian }
9790     { PC8-Turkish csPC8Turkish }
9791     { IBM-Symbols csIBMSymbols }
9792     { IBM-Thai csIBMThai }
9793     { HP-Legal csHPLegal }
9794     { HP-Pi-font csHPPiFont }
9795     { HP-Math8 csHPMath8 }
9796     { Adobe-Symbol-Encoding csHPPSMath }
9797     { HP-DeskTop csHPDesktop }
9798     { Ventura-Math csVenturaMath }
9799     { Microsoft-Publishing csMicrosoftPublishing }
9800     { Windows-31J csWindows31J }
9801     { GB2312 csGB2312 }
9802     { Big5 csBig5 }
9805 proc tcl_encoding {enc} {
9806     global encoding_aliases tcl_encoding_cache
9807     if {[info exists tcl_encoding_cache($enc)]} {
9808         return $tcl_encoding_cache($enc)
9809     }
9810     set names [encoding names]
9811     set lcnames [string tolower $names]
9812     set enc [string tolower $enc]
9813     set i [lsearch -exact $lcnames $enc]
9814     if {$i < 0} {
9815         # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
9816         if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
9817             set i [lsearch -exact $lcnames $encx]
9818         }
9819     }
9820     if {$i < 0} {
9821         foreach l $encoding_aliases {
9822             set ll [string tolower $l]
9823             if {[lsearch -exact $ll $enc] < 0} continue
9824             # look through the aliases for one that tcl knows about
9825             foreach e $ll {
9826                 set i [lsearch -exact $lcnames $e]
9827                 if {$i < 0} {
9828                     if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
9829                         set i [lsearch -exact $lcnames $ex]
9830                     }
9831                 }
9832                 if {$i >= 0} break
9833             }
9834             break
9835         }
9836     }
9837     set tclenc {}
9838     if {$i >= 0} {
9839         set tclenc [lindex $names $i]
9840     }
9841     set tcl_encoding_cache($enc) $tclenc
9842     return $tclenc
9845 proc gitattr {path attr default} {
9846     global path_attr_cache
9847     if {[info exists path_attr_cache($attr,$path)]} {
9848         set r $path_attr_cache($attr,$path)
9849     } else {
9850         set r "unspecified"
9851         if {![catch {set line [exec git check-attr $attr -- $path]}]} {
9852             regexp "(.*): encoding: (.*)" $line m f r
9853         }
9854         set path_attr_cache($attr,$path) $r
9855     }
9856     if {$r eq "unspecified"} {
9857         return $default
9858     }
9859     return $r
9862 proc cache_gitattr {attr pathlist} {
9863     global path_attr_cache
9864     set newlist {}
9865     foreach path $pathlist {
9866         if {![info exists path_attr_cache($attr,$path)]} {
9867             lappend newlist $path
9868         }
9869     }
9870     set lim 1000
9871     if {[tk windowingsystem] == "win32"} {
9872         # windows has a 32k limit on the arguments to a command...
9873         set lim 30
9874     }
9875     while {$newlist ne {}} {
9876         set head [lrange $newlist 0 [expr {$lim - 1}]]
9877         set newlist [lrange $newlist $lim end]
9878         if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
9879             foreach row [split $rlist "\n"] {
9880                 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
9881                     if {[string index $path 0] eq "\""} {
9882                         set path [encoding convertfrom [lindex $path 0]]
9883                     }
9884                     set path_attr_cache($attr,$path) $value
9885                 }
9886             }
9887         }
9888     }
9891 proc get_path_encoding {path} {
9892     global gui_encoding perfile_attrs
9893     set tcl_enc $gui_encoding
9894     if {$path ne {} && $perfile_attrs} {
9895         set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
9896         if {$enc2 ne {}} {
9897             set tcl_enc $enc2
9898         }
9899     }
9900     return $tcl_enc
9903 # First check that Tcl/Tk is recent enough
9904 if {[catch {package require Tk 8.4} err]} {
9905     show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9906                      Gitk requires at least Tcl/Tk 8.4."]
9907     exit 1
9910 # defaults...
9911 set wrcomcmd "git diff-tree --stdin -p --pretty"
9913 set gitencoding {}
9914 catch {
9915     set gitencoding [exec git config --get i18n.commitencoding]
9917 if {$gitencoding == ""} {
9918     set gitencoding "utf-8"
9920 set tclencoding [tcl_encoding $gitencoding]
9921 if {$tclencoding == {}} {
9922     puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9925 set gui_encoding [encoding system]
9926 catch {
9927     set enc [exec git config --get gui.encoding]
9928     if {$enc ne {}} {
9929         set tclenc [tcl_encoding $enc]
9930         if {$tclenc ne {}} {
9931             set gui_encoding $tclenc
9932         } else {
9933             puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
9934         }
9935     }
9938 set mainfont {Helvetica 9}
9939 set textfont {Courier 9}
9940 set uifont {Helvetica 9 bold}
9941 set tabstop 8
9942 set findmergefiles 0
9943 set maxgraphpct 50
9944 set maxwidth 16
9945 set revlistorder 0
9946 set fastdate 0
9947 set uparrowlen 5
9948 set downarrowlen 5
9949 set mingaplen 100
9950 set cmitmode "patch"
9951 set wrapcomment "none"
9952 set showneartags 1
9953 set maxrefs 20
9954 set maxlinelen 200
9955 set showlocalchanges 1
9956 set limitdiffs 1
9957 set datetimeformat "%Y-%m-%d %H:%M:%S"
9958 set autoselect 1
9959 set perfile_attrs 0
9961 set extdifftool "meld"
9963 set colors {green red blue magenta darkgrey brown orange}
9964 set bgcolor white
9965 set fgcolor black
9966 set diffcolors {red "#00a000" blue}
9967 set diffcontext 3
9968 set ignorespace 0
9969 set selectbgcolor gray85
9971 set circlecolors {white blue gray blue blue}
9973 # button for popping up context menus
9974 if {[tk windowingsystem] eq "aqua"} {
9975     set ctxbut <Button-2>
9976 } else {
9977     set ctxbut <Button-3>
9980 ## For msgcat loading, first locate the installation location.
9981 if { [info exists ::env(GITK_MSGSDIR)] } {
9982     ## Msgsdir was manually set in the environment.
9983     set gitk_msgsdir $::env(GITK_MSGSDIR)
9984 } else {
9985     ## Let's guess the prefix from argv0.
9986     set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
9987     set gitk_libdir [file join $gitk_prefix share gitk lib]
9988     set gitk_msgsdir [file join $gitk_libdir msgs]
9989     unset gitk_prefix
9992 ## Internationalization (i18n) through msgcat and gettext. See
9993 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
9994 package require msgcat
9995 namespace import ::msgcat::mc
9996 ## And eventually load the actual message catalog
9997 ::msgcat::mcload $gitk_msgsdir
9999 catch {source ~/.gitk}
10001 font create optionfont -family sans-serif -size -12
10003 parsefont mainfont $mainfont
10004 eval font create mainfont [fontflags mainfont]
10005 eval font create mainfontbold [fontflags mainfont 1]
10007 parsefont textfont $textfont
10008 eval font create textfont [fontflags textfont]
10009 eval font create textfontbold [fontflags textfont 1]
10011 parsefont uifont $uifont
10012 eval font create uifont [fontflags uifont]
10014 setoptions
10016 # check that we can find a .git directory somewhere...
10017 if {[catch {set gitdir [gitdir]}]} {
10018     show_error {} . [mc "Cannot find a git repository here."]
10019     exit 1
10021 if {![file isdirectory $gitdir]} {
10022     show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10023     exit 1
10026 set selecthead {}
10027 set selectheadid {}
10029 set revtreeargs {}
10030 set cmdline_files {}
10031 set i 0
10032 set revtreeargscmd {}
10033 foreach arg $argv {
10034     switch -glob -- $arg {
10035         "" { }
10036         "--" {
10037             set cmdline_files [lrange $argv [expr {$i + 1}] end]
10038             break
10039         }
10040         "--select-commit=*" {
10041             set selecthead [string range $arg 16 end]
10042         }
10043         "--argscmd=*" {
10044             set revtreeargscmd [string range $arg 10 end]
10045         }
10046         default {
10047             lappend revtreeargs $arg
10048         }
10049     }
10050     incr i
10053 if {$selecthead eq "HEAD"} {
10054     set selecthead {}
10057 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10058     # no -- on command line, but some arguments (other than --argscmd)
10059     if {[catch {
10060         set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10061         set cmdline_files [split $f "\n"]
10062         set n [llength $cmdline_files]
10063         set revtreeargs [lrange $revtreeargs 0 end-$n]
10064         # Unfortunately git rev-parse doesn't produce an error when
10065         # something is both a revision and a filename.  To be consistent
10066         # with git log and git rev-list, check revtreeargs for filenames.
10067         foreach arg $revtreeargs {
10068             if {[file exists $arg]} {
10069                 show_error {} . [mc "Ambiguous argument '%s': both revision\
10070                                  and filename" $arg]
10071                 exit 1
10072             }
10073         }
10074     } err]} {
10075         # unfortunately we get both stdout and stderr in $err,
10076         # so look for "fatal:".
10077         set i [string first "fatal:" $err]
10078         if {$i > 0} {
10079             set err [string range $err [expr {$i + 6}] end]
10080         }
10081         show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10082         exit 1
10083     }
10086 set nullid "0000000000000000000000000000000000000000"
10087 set nullid2 "0000000000000000000000000000000000000001"
10088 set nullfile "/dev/null"
10090 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10092 set runq {}
10093 set history {}
10094 set historyindex 0
10095 set fh_serial 0
10096 set nhl_names {}
10097 set highlight_paths {}
10098 set findpattern {}
10099 set searchdirn -forwards
10100 set boldrows {}
10101 set boldnamerows {}
10102 set diffelide {0 0}
10103 set markingmatches 0
10104 set linkentercount 0
10105 set need_redisplay 0
10106 set nrows_drawn 0
10107 set firsttabstop 0
10109 set nextviewnum 1
10110 set curview 0
10111 set selectedview 0
10112 set selectedhlview [mc "None"]
10113 set highlight_related [mc "None"]
10114 set highlight_files {}
10115 set viewfiles(0) {}
10116 set viewperm(0) 0
10117 set viewargs(0) {}
10118 set viewargscmd(0) {}
10120 set selectedline {}
10121 set numcommits 0
10122 set loginstance 0
10123 set cmdlineok 0
10124 set stopped 0
10125 set stuffsaved 0
10126 set patchnum 0
10127 set lserial 0
10128 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10129 setcoords
10130 makewindow
10131 # wait for the window to become visible
10132 tkwait visibility .
10133 wm title . "[file tail $argv0]: [file tail [pwd]]"
10134 readrefs
10136 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10137     # create a view for the files/dirs specified on the command line
10138     set curview 1
10139     set selectedview 1
10140     set nextviewnum 2
10141     set viewname(1) [mc "Command line"]
10142     set viewfiles(1) $cmdline_files
10143     set viewargs(1) $revtreeargs
10144     set viewargscmd(1) $revtreeargscmd
10145     set viewperm(1) 0
10146     set vdatemode(1) 0
10147     addviewmenu 1
10148     .bar.view entryconf [mc "Edit view..."] -state normal
10149     .bar.view entryconf [mc "Delete view"] -state normal
10152 if {[info exists permviews]} {
10153     foreach v $permviews {
10154         set n $nextviewnum
10155         incr nextviewnum
10156         set viewname($n) [lindex $v 0]
10157         set viewfiles($n) [lindex $v 1]
10158         set viewargs($n) [lindex $v 2]
10159         set viewargscmd($n) [lindex $v 3]
10160         set viewperm($n) 1
10161         addviewmenu $n
10162     }
10164 getcommits {}