Code

gitk: Fix bug in accessing undefined "notflag" variable
[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             "-[puabwcrRBMC]" -
159             "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
160             "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
161             "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
162             "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
163             "--ignore-space-change" - "-U*" - "--unified=*" {
164                 # These request or affect diff output, which we don't want.
165                 # Some could be used to set our defaults for diff display.
166                 lappend diffargs $arg
167             }
168             "--raw" - "--patch-with-raw" - "--patch-with-stat" -
169             "--name-only" - "--name-status" - "--color" - "--color-words" -
170             "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
171             "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
172             "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
173             "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
174             "--objects" - "--objects-edge" - "--reverse" {
175                 # These cause our parsing of git log's output to fail, or else
176                 # they're options we want to set ourselves, so ignore them.
177             }
178             "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
179             "--check" - "--exit-code" - "--quiet" - "--topo-order" -
180             "--full-history" - "--dense" - "--sparse" -
181             "--follow" - "--left-right" - "--encoding=*" {
182                 # These are harmless, and some are even useful
183                 lappend glflags $arg
184             }
185             "--diff-filter=*" - "--no-merges" - "--unpacked" -
186             "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
187             "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
188             "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
189             "--remove-empty" - "--first-parent" - "--cherry-pick" -
190             "-S*" - "--pickaxe-all" - "--pickaxe-regex" {
191                 # These mean that we get a subset of the commits
192                 set filtered 1
193                 lappend glflags $arg
194             }
195             "-n" {
196                 # This appears to be the only one that has a value as a
197                 # separate word following it
198                 set filtered 1
199                 set nextisval 1
200                 lappend glflags $arg
201             }
202             "--not" - "--all" {
203                 lappend revargs $arg
204             }
205             "--merge" {
206                 set vmergeonly($n) 1
207                 # git rev-parse doesn't understand --merge
208                 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
209             }
210             "-*" {
211                 # Other flag arguments including -<n>
212                 if {[string is digit -strict [string range $arg 1 end]]} {
213                     set filtered 1
214                 } else {
215                     # a flag argument that we don't recognize;
216                     # that means we can't optimize
217                     set allknown 0
218                 }
219                 lappend glflags $arg
220             }
221             default {
222                 # Non-flag arguments specify commits or ranges of commits
223                 if {[string match "*...*" $arg]} {
224                     lappend revargs --gitk-symmetric-diff-marker
225                 }
226                 lappend revargs $arg
227             }
228         }
229     }
230     set vdflags($n) $diffargs
231     set vflags($n) $glflags
232     set vrevs($n) $revargs
233     set vfiltered($n) $filtered
234     set vorigargs($n) $origargs
235     return $allknown
238 proc parseviewrevs {view revs} {
239     global vposids vnegids
241     if {$revs eq {}} {
242         set revs HEAD
243     }
244     if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
245         # we get stdout followed by stderr in $err
246         # for an unknown rev, git rev-parse echoes it and then errors out
247         set errlines [split $err "\n"]
248         set badrev {}
249         for {set l 0} {$l < [llength $errlines]} {incr l} {
250             set line [lindex $errlines $l]
251             if {!([string length $line] == 40 && [string is xdigit $line])} {
252                 if {[string match "fatal:*" $line]} {
253                     if {[string match "fatal: ambiguous argument*" $line]
254                         && $badrev ne {}} {
255                         if {[llength $badrev] == 1} {
256                             set err "unknown revision $badrev"
257                         } else {
258                             set err "unknown revisions: [join $badrev ", "]"
259                         }
260                     } else {
261                         set err [join [lrange $errlines $l end] "\n"]
262                     }
263                     break
264                 }
265                 lappend badrev $line
266             }
267         }                   
268         error_popup "[mc "Error parsing revisions:"] $err"
269         return {}
270     }
271     set ret {}
272     set pos {}
273     set neg {}
274     set sdm 0
275     foreach id [split $ids "\n"] {
276         if {$id eq "--gitk-symmetric-diff-marker"} {
277             set sdm 4
278         } elseif {[string match "^*" $id]} {
279             if {$sdm != 1} {
280                 lappend ret $id
281                 if {$sdm == 3} {
282                     set sdm 0
283                 }
284             }
285             lappend neg [string range $id 1 end]
286         } else {
287             if {$sdm != 2} {
288                 lappend ret $id
289             } else {
290                 lset ret end [lindex $ret end]...$id
291             }
292             lappend pos $id
293         }
294         incr sdm -1
295     }
296     set vposids($view) $pos
297     set vnegids($view) $neg
298     return $ret
301 # Start off a git log process and arrange to read its output
302 proc start_rev_list {view} {
303     global startmsecs commitidx viewcomplete curview
304     global tclencoding
305     global viewargs viewargscmd viewfiles vfilelimit
306     global showlocalchanges
307     global viewactive viewinstances vmergeonly
308     global mainheadid viewmainheadid viewmainheadid_orig
309     global vcanopt vflags vrevs vorigargs
311     set startmsecs [clock clicks -milliseconds]
312     set commitidx($view) 0
313     # these are set this way for the error exits
314     set viewcomplete($view) 1
315     set viewactive($view) 0
316     varcinit $view
318     set args $viewargs($view)
319     if {$viewargscmd($view) ne {}} {
320         if {[catch {
321             set str [exec sh -c $viewargscmd($view)]
322         } err]} {
323             error_popup "[mc "Error executing --argscmd command:"] $err"
324             return 0
325         }
326         set args [concat $args [split $str "\n"]]
327     }
328     set vcanopt($view) [parseviewargs $view $args]
330     set files $viewfiles($view)
331     if {$vmergeonly($view)} {
332         set files [unmerged_files $files]
333         if {$files eq {}} {
334             global nr_unmerged
335             if {$nr_unmerged == 0} {
336                 error_popup [mc "No files selected: --merge specified but\
337                              no files are unmerged."]
338             } else {
339                 error_popup [mc "No files selected: --merge specified but\
340                              no unmerged files are within file limit."]
341             }
342             return 0
343         }
344     }
345     set vfilelimit($view) $files
347     if {$vcanopt($view)} {
348         set revs [parseviewrevs $view $vrevs($view)]
349         if {$revs eq {}} {
350             return 0
351         }
352         set args [concat $vflags($view) $revs]
353     } else {
354         set args $vorigargs($view)
355     }
357     if {[catch {
358         set fd [open [concat | git log --no-color -z --pretty=raw --parents \
359                          --boundary $args "--" $files] r]
360     } err]} {
361         error_popup "[mc "Error executing git log:"] $err"
362         return 0
363     }
364     set i [reg_instance $fd]
365     set viewinstances($view) [list $i]
366     set viewmainheadid($view) $mainheadid
367     set viewmainheadid_orig($view) $mainheadid
368     if {$files ne {} && $mainheadid ne {}} {
369         get_viewmainhead $view
370     }
371     if {$showlocalchanges && $viewmainheadid($view) ne {}} {
372         interestedin $viewmainheadid($view) dodiffindex
373     }
374     fconfigure $fd -blocking 0 -translation lf -eofchar {}
375     if {$tclencoding != {}} {
376         fconfigure $fd -encoding $tclencoding
377     }
378     filerun $fd [list getcommitlines $fd $i $view 0]
379     nowbusy $view [mc "Reading"]
380     set viewcomplete($view) 0
381     set viewactive($view) 1
382     return 1
385 proc stop_instance {inst} {
386     global commfd leftover
388     set fd $commfd($inst)
389     catch {
390         set pid [pid $fd]
392         if {$::tcl_platform(platform) eq {windows}} {
393             exec kill -f $pid
394         } else {
395             exec kill $pid
396         }
397     }
398     catch {close $fd}
399     nukefile $fd
400     unset commfd($inst)
401     unset leftover($inst)
404 proc stop_backends {} {
405     global commfd
407     foreach inst [array names commfd] {
408         stop_instance $inst
409     }
412 proc stop_rev_list {view} {
413     global viewinstances
415     foreach inst $viewinstances($view) {
416         stop_instance $inst
417     }
418     set viewinstances($view) {}
421 proc reset_pending_select {selid} {
422     global pending_select mainheadid selectheadid
424     if {$selid ne {}} {
425         set pending_select $selid
426     } elseif {$selectheadid ne {}} {
427         set pending_select $selectheadid
428     } else {
429         set pending_select $mainheadid
430     }
433 proc getcommits {selid} {
434     global canv curview need_redisplay viewactive
436     initlayout
437     if {[start_rev_list $curview]} {
438         reset_pending_select $selid
439         show_status [mc "Reading commits..."]
440         set need_redisplay 1
441     } else {
442         show_status [mc "No commits selected"]
443     }
446 proc updatecommits {} {
447     global curview vcanopt vorigargs vfilelimit viewinstances
448     global viewactive viewcomplete tclencoding
449     global startmsecs showneartags showlocalchanges
450     global mainheadid viewmainheadid viewmainheadid_orig pending_select
451     global isworktree
452     global varcid vposids vnegids vflags vrevs
454     set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
455     rereadrefs
456     set view $curview
457     if {$mainheadid ne $viewmainheadid_orig($view)} {
458         if {$showlocalchanges} {
459             dohidelocalchanges
460         }
461         set viewmainheadid($view) $mainheadid
462         set viewmainheadid_orig($view) $mainheadid
463         if {$vfilelimit($view) ne {}} {
464             get_viewmainhead $view
465         }
466     }
467     if {$showlocalchanges} {
468         doshowlocalchanges
469     }
470     if {$vcanopt($view)} {
471         set oldpos $vposids($view)
472         set oldneg $vnegids($view)
473         set revs [parseviewrevs $view $vrevs($view)]
474         if {$revs eq {}} {
475             return
476         }
477         # note: getting the delta when negative refs change is hard,
478         # and could require multiple git log invocations, so in that
479         # case we ask git log for all the commits (not just the delta)
480         if {$oldneg eq $vnegids($view)} {
481             set newrevs {}
482             set npos 0
483             # take out positive refs that we asked for before or
484             # that we have already seen
485             foreach rev $revs {
486                 if {[string length $rev] == 40} {
487                     if {[lsearch -exact $oldpos $rev] < 0
488                         && ![info exists varcid($view,$rev)]} {
489                         lappend newrevs $rev
490                         incr npos
491                     }
492                 } else {
493                     lappend $newrevs $rev
494                 }
495             }
496             if {$npos == 0} return
497             set revs $newrevs
498             set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
499         }
500         set args [concat $vflags($view) $revs --not $oldpos]
501     } else {
502         set args $vorigargs($view)
503     }
504     if {[catch {
505         set fd [open [concat | git log --no-color -z --pretty=raw --parents \
506                           --boundary $args "--" $vfilelimit($view)] r]
507     } err]} {
508         error_popup "[mc "Error executing git log:"] $err"
509         return
510     }
511     if {$viewactive($view) == 0} {
512         set startmsecs [clock clicks -milliseconds]
513     }
514     set i [reg_instance $fd]
515     lappend viewinstances($view) $i
516     fconfigure $fd -blocking 0 -translation lf -eofchar {}
517     if {$tclencoding != {}} {
518         fconfigure $fd -encoding $tclencoding
519     }
520     filerun $fd [list getcommitlines $fd $i $view 1]
521     incr viewactive($view)
522     set viewcomplete($view) 0
523     reset_pending_select {}
524     nowbusy $view "Reading"
525     if {$showneartags} {
526         getallcommits
527     }
530 proc reloadcommits {} {
531     global curview viewcomplete selectedline currentid thickerline
532     global showneartags treediffs commitinterest cached_commitrow
533     global targetid
535     set selid {}
536     if {$selectedline ne {}} {
537         set selid $currentid
538     }
540     if {!$viewcomplete($curview)} {
541         stop_rev_list $curview
542     }
543     resetvarcs $curview
544     set selectedline {}
545     catch {unset currentid}
546     catch {unset thickerline}
547     catch {unset treediffs}
548     readrefs
549     changedrefs
550     if {$showneartags} {
551         getallcommits
552     }
553     clear_display
554     catch {unset commitinterest}
555     catch {unset cached_commitrow}
556     catch {unset targetid}
557     setcanvscroll
558     getcommits $selid
559     return 0
562 # This makes a string representation of a positive integer which
563 # sorts as a string in numerical order
564 proc strrep {n} {
565     if {$n < 16} {
566         return [format "%x" $n]
567     } elseif {$n < 256} {
568         return [format "x%.2x" $n]
569     } elseif {$n < 65536} {
570         return [format "y%.4x" $n]
571     }
572     return [format "z%.8x" $n]
575 # Procedures used in reordering commits from git log (without
576 # --topo-order) into the order for display.
578 proc varcinit {view} {
579     global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
580     global vtokmod varcmod vrowmod varcix vlastins
582     set varcstart($view) {{}}
583     set vupptr($view) {0}
584     set vdownptr($view) {0}
585     set vleftptr($view) {0}
586     set vbackptr($view) {0}
587     set varctok($view) {{}}
588     set varcrow($view) {{}}
589     set vtokmod($view) {}
590     set varcmod($view) 0
591     set vrowmod($view) 0
592     set varcix($view) {{}}
593     set vlastins($view) {0}
596 proc resetvarcs {view} {
597     global varcid varccommits parents children vseedcount ordertok
599     foreach vid [array names varcid $view,*] {
600         unset varcid($vid)
601         unset children($vid)
602         unset parents($vid)
603     }
604     # some commits might have children but haven't been seen yet
605     foreach vid [array names children $view,*] {
606         unset children($vid)
607     }
608     foreach va [array names varccommits $view,*] {
609         unset varccommits($va)
610     }
611     foreach vd [array names vseedcount $view,*] {
612         unset vseedcount($vd)
613     }
614     catch {unset ordertok}
617 # returns a list of the commits with no children
618 proc seeds {v} {
619     global vdownptr vleftptr varcstart
621     set ret {}
622     set a [lindex $vdownptr($v) 0]
623     while {$a != 0} {
624         lappend ret [lindex $varcstart($v) $a]
625         set a [lindex $vleftptr($v) $a]
626     }
627     return $ret
630 proc newvarc {view id} {
631     global varcid varctok parents children vdatemode
632     global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
633     global commitdata commitinfo vseedcount varccommits vlastins
635     set a [llength $varctok($view)]
636     set vid $view,$id
637     if {[llength $children($vid)] == 0 || $vdatemode($view)} {
638         if {![info exists commitinfo($id)]} {
639             parsecommit $id $commitdata($id) 1
640         }
641         set cdate [lindex $commitinfo($id) 4]
642         if {![string is integer -strict $cdate]} {
643             set cdate 0
644         }
645         if {![info exists vseedcount($view,$cdate)]} {
646             set vseedcount($view,$cdate) -1
647         }
648         set c [incr vseedcount($view,$cdate)]
649         set cdate [expr {$cdate ^ 0xffffffff}]
650         set tok "s[strrep $cdate][strrep $c]"
651     } else {
652         set tok {}
653     }
654     set ka 0
655     if {[llength $children($vid)] > 0} {
656         set kid [lindex $children($vid) end]
657         set k $varcid($view,$kid)
658         if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
659             set ki $kid
660             set ka $k
661             set tok [lindex $varctok($view) $k]
662         }
663     }
664     if {$ka != 0} {
665         set i [lsearch -exact $parents($view,$ki) $id]
666         set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
667         append tok [strrep $j]
668     }
669     set c [lindex $vlastins($view) $ka]
670     if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
671         set c $ka
672         set b [lindex $vdownptr($view) $ka]
673     } else {
674         set b [lindex $vleftptr($view) $c]
675     }
676     while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
677         set c $b
678         set b [lindex $vleftptr($view) $c]
679     }
680     if {$c == $ka} {
681         lset vdownptr($view) $ka $a
682         lappend vbackptr($view) 0
683     } else {
684         lset vleftptr($view) $c $a
685         lappend vbackptr($view) $c
686     }
687     lset vlastins($view) $ka $a
688     lappend vupptr($view) $ka
689     lappend vleftptr($view) $b
690     if {$b != 0} {
691         lset vbackptr($view) $b $a
692     }
693     lappend varctok($view) $tok
694     lappend varcstart($view) $id
695     lappend vdownptr($view) 0
696     lappend varcrow($view) {}
697     lappend varcix($view) {}
698     set varccommits($view,$a) {}
699     lappend vlastins($view) 0
700     return $a
703 proc splitvarc {p v} {
704     global varcid varcstart varccommits varctok
705     global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
707     set oa $varcid($v,$p)
708     set ac $varccommits($v,$oa)
709     set i [lsearch -exact $varccommits($v,$oa) $p]
710     if {$i <= 0} return
711     set na [llength $varctok($v)]
712     # "%" sorts before "0"...
713     set tok "[lindex $varctok($v) $oa]%[strrep $i]"
714     lappend varctok($v) $tok
715     lappend varcrow($v) {}
716     lappend varcix($v) {}
717     set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
718     set varccommits($v,$na) [lrange $ac $i end]
719     lappend varcstart($v) $p
720     foreach id $varccommits($v,$na) {
721         set varcid($v,$id) $na
722     }
723     lappend vdownptr($v) [lindex $vdownptr($v) $oa]
724     lappend vlastins($v) [lindex $vlastins($v) $oa]
725     lset vdownptr($v) $oa $na
726     lset vlastins($v) $oa 0
727     lappend vupptr($v) $oa
728     lappend vleftptr($v) 0
729     lappend vbackptr($v) 0
730     for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
731         lset vupptr($v) $b $na
732     }
735 proc renumbervarc {a v} {
736     global parents children varctok varcstart varccommits
737     global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
739     set t1 [clock clicks -milliseconds]
740     set todo {}
741     set isrelated($a) 1
742     set kidchanged($a) 1
743     set ntot 0
744     while {$a != 0} {
745         if {[info exists isrelated($a)]} {
746             lappend todo $a
747             set id [lindex $varccommits($v,$a) end]
748             foreach p $parents($v,$id) {
749                 if {[info exists varcid($v,$p)]} {
750                     set isrelated($varcid($v,$p)) 1
751                 }
752             }
753         }
754         incr ntot
755         set b [lindex $vdownptr($v) $a]
756         if {$b == 0} {
757             while {$a != 0} {
758                 set b [lindex $vleftptr($v) $a]
759                 if {$b != 0} break
760                 set a [lindex $vupptr($v) $a]
761             }
762         }
763         set a $b
764     }
765     foreach a $todo {
766         if {![info exists kidchanged($a)]} continue
767         set id [lindex $varcstart($v) $a]
768         if {[llength $children($v,$id)] > 1} {
769             set children($v,$id) [lsort -command [list vtokcmp $v] \
770                                       $children($v,$id)]
771         }
772         set oldtok [lindex $varctok($v) $a]
773         if {!$vdatemode($v)} {
774             set tok {}
775         } else {
776             set tok $oldtok
777         }
778         set ka 0
779         set kid [last_real_child $v,$id]
780         if {$kid ne {}} {
781             set k $varcid($v,$kid)
782             if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
783                 set ki $kid
784                 set ka $k
785                 set tok [lindex $varctok($v) $k]
786             }
787         }
788         if {$ka != 0} {
789             set i [lsearch -exact $parents($v,$ki) $id]
790             set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
791             append tok [strrep $j]
792         }
793         if {$tok eq $oldtok} {
794             continue
795         }
796         set id [lindex $varccommits($v,$a) end]
797         foreach p $parents($v,$id) {
798             if {[info exists varcid($v,$p)]} {
799                 set kidchanged($varcid($v,$p)) 1
800             } else {
801                 set sortkids($p) 1
802             }
803         }
804         lset varctok($v) $a $tok
805         set b [lindex $vupptr($v) $a]
806         if {$b != $ka} {
807             if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
808                 modify_arc $v $ka
809             }
810             if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
811                 modify_arc $v $b
812             }
813             set c [lindex $vbackptr($v) $a]
814             set d [lindex $vleftptr($v) $a]
815             if {$c == 0} {
816                 lset vdownptr($v) $b $d
817             } else {
818                 lset vleftptr($v) $c $d
819             }
820             if {$d != 0} {
821                 lset vbackptr($v) $d $c
822             }
823             if {[lindex $vlastins($v) $b] == $a} {
824                 lset vlastins($v) $b $c
825             }
826             lset vupptr($v) $a $ka
827             set c [lindex $vlastins($v) $ka]
828             if {$c == 0 || \
829                     [string compare $tok [lindex $varctok($v) $c]] < 0} {
830                 set c $ka
831                 set b [lindex $vdownptr($v) $ka]
832             } else {
833                 set b [lindex $vleftptr($v) $c]
834             }
835             while {$b != 0 && \
836                       [string compare $tok [lindex $varctok($v) $b]] >= 0} {
837                 set c $b
838                 set b [lindex $vleftptr($v) $c]
839             }
840             if {$c == $ka} {
841                 lset vdownptr($v) $ka $a
842                 lset vbackptr($v) $a 0
843             } else {
844                 lset vleftptr($v) $c $a
845                 lset vbackptr($v) $a $c
846             }
847             lset vleftptr($v) $a $b
848             if {$b != 0} {
849                 lset vbackptr($v) $b $a
850             }
851             lset vlastins($v) $ka $a
852         }
853     }
854     foreach id [array names sortkids] {
855         if {[llength $children($v,$id)] > 1} {
856             set children($v,$id) [lsort -command [list vtokcmp $v] \
857                                       $children($v,$id)]
858         }
859     }
860     set t2 [clock clicks -milliseconds]
861     #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
864 # Fix up the graph after we have found out that in view $v,
865 # $p (a commit that we have already seen) is actually the parent
866 # of the last commit in arc $a.
867 proc fix_reversal {p a v} {
868     global varcid varcstart varctok vupptr
870     set pa $varcid($v,$p)
871     if {$p ne [lindex $varcstart($v) $pa]} {
872         splitvarc $p $v
873         set pa $varcid($v,$p)
874     }
875     # seeds always need to be renumbered
876     if {[lindex $vupptr($v) $pa] == 0 ||
877         [string compare [lindex $varctok($v) $a] \
878              [lindex $varctok($v) $pa]] > 0} {
879         renumbervarc $pa $v
880     }
883 proc insertrow {id p v} {
884     global cmitlisted children parents varcid varctok vtokmod
885     global varccommits ordertok commitidx numcommits curview
886     global targetid targetrow
888     readcommit $id
889     set vid $v,$id
890     set cmitlisted($vid) 1
891     set children($vid) {}
892     set parents($vid) [list $p]
893     set a [newvarc $v $id]
894     set varcid($vid) $a
895     if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
896         modify_arc $v $a
897     }
898     lappend varccommits($v,$a) $id
899     set vp $v,$p
900     if {[llength [lappend children($vp) $id]] > 1} {
901         set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
902         catch {unset ordertok}
903     }
904     fix_reversal $p $a $v
905     incr commitidx($v)
906     if {$v == $curview} {
907         set numcommits $commitidx($v)
908         setcanvscroll
909         if {[info exists targetid]} {
910             if {![comes_before $targetid $p]} {
911                 incr targetrow
912             }
913         }
914     }
917 proc insertfakerow {id p} {
918     global varcid varccommits parents children cmitlisted
919     global commitidx varctok vtokmod targetid targetrow curview numcommits
921     set v $curview
922     set a $varcid($v,$p)
923     set i [lsearch -exact $varccommits($v,$a) $p]
924     if {$i < 0} {
925         puts "oops: insertfakerow can't find [shortids $p] on arc $a"
926         return
927     }
928     set children($v,$id) {}
929     set parents($v,$id) [list $p]
930     set varcid($v,$id) $a
931     lappend children($v,$p) $id
932     set cmitlisted($v,$id) 1
933     set numcommits [incr commitidx($v)]
934     # note we deliberately don't update varcstart($v) even if $i == 0
935     set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
936     modify_arc $v $a $i
937     if {[info exists targetid]} {
938         if {![comes_before $targetid $p]} {
939             incr targetrow
940         }
941     }
942     setcanvscroll
943     drawvisible
946 proc removefakerow {id} {
947     global varcid varccommits parents children commitidx
948     global varctok vtokmod cmitlisted currentid selectedline
949     global targetid curview numcommits
951     set v $curview
952     if {[llength $parents($v,$id)] != 1} {
953         puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
954         return
955     }
956     set p [lindex $parents($v,$id) 0]
957     set a $varcid($v,$id)
958     set i [lsearch -exact $varccommits($v,$a) $id]
959     if {$i < 0} {
960         puts "oops: removefakerow can't find [shortids $id] on arc $a"
961         return
962     }
963     unset varcid($v,$id)
964     set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
965     unset parents($v,$id)
966     unset children($v,$id)
967     unset cmitlisted($v,$id)
968     set numcommits [incr commitidx($v) -1]
969     set j [lsearch -exact $children($v,$p) $id]
970     if {$j >= 0} {
971         set children($v,$p) [lreplace $children($v,$p) $j $j]
972     }
973     modify_arc $v $a $i
974     if {[info exist currentid] && $id eq $currentid} {
975         unset currentid
976         set selectedline {}
977     }
978     if {[info exists targetid] && $targetid eq $id} {
979         set targetid $p
980     }
981     setcanvscroll
982     drawvisible
985 proc first_real_child {vp} {
986     global children nullid nullid2
988     foreach id $children($vp) {
989         if {$id ne $nullid && $id ne $nullid2} {
990             return $id
991         }
992     }
993     return {}
996 proc last_real_child {vp} {
997     global children nullid nullid2
999     set kids $children($vp)
1000     for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1001         set id [lindex $kids $i]
1002         if {$id ne $nullid && $id ne $nullid2} {
1003             return $id
1004         }
1005     }
1006     return {}
1009 proc vtokcmp {v a b} {
1010     global varctok varcid
1012     return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1013                 [lindex $varctok($v) $varcid($v,$b)]]
1016 # This assumes that if lim is not given, the caller has checked that
1017 # arc a's token is less than $vtokmod($v)
1018 proc modify_arc {v a {lim {}}} {
1019     global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1021     if {$lim ne {}} {
1022         set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1023         if {$c > 0} return
1024         if {$c == 0} {
1025             set r [lindex $varcrow($v) $a]
1026             if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1027         }
1028     }
1029     set vtokmod($v) [lindex $varctok($v) $a]
1030     set varcmod($v) $a
1031     if {$v == $curview} {
1032         while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1033             set a [lindex $vupptr($v) $a]
1034             set lim {}
1035         }
1036         set r 0
1037         if {$a != 0} {
1038             if {$lim eq {}} {
1039                 set lim [llength $varccommits($v,$a)]
1040             }
1041             set r [expr {[lindex $varcrow($v) $a] + $lim}]
1042         }
1043         set vrowmod($v) $r
1044         undolayout $r
1045     }
1048 proc update_arcrows {v} {
1049     global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1050     global varcid vrownum varcorder varcix varccommits
1051     global vupptr vdownptr vleftptr varctok
1052     global displayorder parentlist curview cached_commitrow
1054     if {$vrowmod($v) == $commitidx($v)} return
1055     if {$v == $curview} {
1056         if {[llength $displayorder] > $vrowmod($v)} {
1057             set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1058             set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1059         }
1060         catch {unset cached_commitrow}
1061     }
1062     set narctot [expr {[llength $varctok($v)] - 1}]
1063     set a $varcmod($v)
1064     while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1065         # go up the tree until we find something that has a row number,
1066         # or we get to a seed
1067         set a [lindex $vupptr($v) $a]
1068     }
1069     if {$a == 0} {
1070         set a [lindex $vdownptr($v) 0]
1071         if {$a == 0} return
1072         set vrownum($v) {0}
1073         set varcorder($v) [list $a]
1074         lset varcix($v) $a 0
1075         lset varcrow($v) $a 0
1076         set arcn 0
1077         set row 0
1078     } else {
1079         set arcn [lindex $varcix($v) $a]
1080         if {[llength $vrownum($v)] > $arcn + 1} {
1081             set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1082             set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1083         }
1084         set row [lindex $varcrow($v) $a]
1085     }
1086     while {1} {
1087         set p $a
1088         incr row [llength $varccommits($v,$a)]
1089         # go down if possible
1090         set b [lindex $vdownptr($v) $a]
1091         if {$b == 0} {
1092             # if not, go left, or go up until we can go left
1093             while {$a != 0} {
1094                 set b [lindex $vleftptr($v) $a]
1095                 if {$b != 0} break
1096                 set a [lindex $vupptr($v) $a]
1097             }
1098             if {$a == 0} break
1099         }
1100         set a $b
1101         incr arcn
1102         lappend vrownum($v) $row
1103         lappend varcorder($v) $a
1104         lset varcix($v) $a $arcn
1105         lset varcrow($v) $a $row
1106     }
1107     set vtokmod($v) [lindex $varctok($v) $p]
1108     set varcmod($v) $p
1109     set vrowmod($v) $row
1110     if {[info exists currentid]} {
1111         set selectedline [rowofcommit $currentid]
1112     }
1115 # Test whether view $v contains commit $id
1116 proc commitinview {id v} {
1117     global varcid
1119     return [info exists varcid($v,$id)]
1122 # Return the row number for commit $id in the current view
1123 proc rowofcommit {id} {
1124     global varcid varccommits varcrow curview cached_commitrow
1125     global varctok vtokmod
1127     set v $curview
1128     if {![info exists varcid($v,$id)]} {
1129         puts "oops rowofcommit no arc for [shortids $id]"
1130         return {}
1131     }
1132     set a $varcid($v,$id)
1133     if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1134         update_arcrows $v
1135     }
1136     if {[info exists cached_commitrow($id)]} {
1137         return $cached_commitrow($id)
1138     }
1139     set i [lsearch -exact $varccommits($v,$a) $id]
1140     if {$i < 0} {
1141         puts "oops didn't find commit [shortids $id] in arc $a"
1142         return {}
1143     }
1144     incr i [lindex $varcrow($v) $a]
1145     set cached_commitrow($id) $i
1146     return $i
1149 # Returns 1 if a is on an earlier row than b, otherwise 0
1150 proc comes_before {a b} {
1151     global varcid varctok curview
1153     set v $curview
1154     if {$a eq $b || ![info exists varcid($v,$a)] || \
1155             ![info exists varcid($v,$b)]} {
1156         return 0
1157     }
1158     if {$varcid($v,$a) != $varcid($v,$b)} {
1159         return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1160                            [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1161     }
1162     return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1165 proc bsearch {l elt} {
1166     if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1167         return 0
1168     }
1169     set lo 0
1170     set hi [llength $l]
1171     while {$hi - $lo > 1} {
1172         set mid [expr {int(($lo + $hi) / 2)}]
1173         set t [lindex $l $mid]
1174         if {$elt < $t} {
1175             set hi $mid
1176         } elseif {$elt > $t} {
1177             set lo $mid
1178         } else {
1179             return $mid
1180         }
1181     }
1182     return $lo
1185 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1186 proc make_disporder {start end} {
1187     global vrownum curview commitidx displayorder parentlist
1188     global varccommits varcorder parents vrowmod varcrow
1189     global d_valid_start d_valid_end
1191     if {$end > $vrowmod($curview)} {
1192         update_arcrows $curview
1193     }
1194     set ai [bsearch $vrownum($curview) $start]
1195     set start [lindex $vrownum($curview) $ai]
1196     set narc [llength $vrownum($curview)]
1197     for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1198         set a [lindex $varcorder($curview) $ai]
1199         set l [llength $displayorder]
1200         set al [llength $varccommits($curview,$a)]
1201         if {$l < $r + $al} {
1202             if {$l < $r} {
1203                 set pad [ntimes [expr {$r - $l}] {}]
1204                 set displayorder [concat $displayorder $pad]
1205                 set parentlist [concat $parentlist $pad]
1206             } elseif {$l > $r} {
1207                 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1208                 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1209             }
1210             foreach id $varccommits($curview,$a) {
1211                 lappend displayorder $id
1212                 lappend parentlist $parents($curview,$id)
1213             }
1214         } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1215             set i $r
1216             foreach id $varccommits($curview,$a) {
1217                 lset displayorder $i $id
1218                 lset parentlist $i $parents($curview,$id)
1219                 incr i
1220             }
1221         }
1222         incr r $al
1223     }
1226 proc commitonrow {row} {
1227     global displayorder
1229     set id [lindex $displayorder $row]
1230     if {$id eq {}} {
1231         make_disporder $row [expr {$row + 1}]
1232         set id [lindex $displayorder $row]
1233     }
1234     return $id
1237 proc closevarcs {v} {
1238     global varctok varccommits varcid parents children
1239     global cmitlisted commitidx vtokmod
1241     set missing_parents 0
1242     set scripts {}
1243     set narcs [llength $varctok($v)]
1244     for {set a 1} {$a < $narcs} {incr a} {
1245         set id [lindex $varccommits($v,$a) end]
1246         foreach p $parents($v,$id) {
1247             if {[info exists varcid($v,$p)]} continue
1248             # add p as a new commit
1249             incr missing_parents
1250             set cmitlisted($v,$p) 0
1251             set parents($v,$p) {}
1252             if {[llength $children($v,$p)] == 1 &&
1253                 [llength $parents($v,$id)] == 1} {
1254                 set b $a
1255             } else {
1256                 set b [newvarc $v $p]
1257             }
1258             set varcid($v,$p) $b
1259             if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1260                 modify_arc $v $b
1261             }
1262             lappend varccommits($v,$b) $p
1263             incr commitidx($v)
1264             set scripts [check_interest $p $scripts]
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 # Mechanism for registering a command to be executed when we come
1301 # across a particular commit.  To handle the case when only the
1302 # prefix of the commit is known, the commitinterest array is now
1303 # indexed by the first 4 characters of the ID.  Each element is a
1304 # list of id, cmd pairs.
1305 proc interestedin {id cmd} {
1306     global commitinterest
1308     lappend commitinterest([string range $id 0 3]) $id $cmd
1311 proc check_interest {id scripts} {
1312     global commitinterest
1314     set prefix [string range $id 0 3]
1315     if {[info exists commitinterest($prefix)]} {
1316         set newlist {}
1317         foreach {i script} $commitinterest($prefix) {
1318             if {[string match "$i*" $id]} {
1319                 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1320             } else {
1321                 lappend newlist $i $script
1322             }
1323         }
1324         if {$newlist ne {}} {
1325             set commitinterest($prefix) $newlist
1326         } else {
1327             unset commitinterest($prefix)
1328         }
1329     }
1330     return $scripts
1333 proc getcommitlines {fd inst view updating}  {
1334     global cmitlisted leftover
1335     global commitidx commitdata vdatemode
1336     global parents children curview hlview
1337     global idpending ordertok
1338     global varccommits varcid varctok vtokmod vfilelimit
1340     set stuff [read $fd 500000]
1341     # git log doesn't terminate the last commit with a null...
1342     if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1343         set stuff "\0"
1344     }
1345     if {$stuff == {}} {
1346         if {![eof $fd]} {
1347             return 1
1348         }
1349         global commfd viewcomplete viewactive viewname
1350         global viewinstances
1351         unset commfd($inst)
1352         set i [lsearch -exact $viewinstances($view) $inst]
1353         if {$i >= 0} {
1354             set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1355         }
1356         # set it blocking so we wait for the process to terminate
1357         fconfigure $fd -blocking 1
1358         if {[catch {close $fd} err]} {
1359             set fv {}
1360             if {$view != $curview} {
1361                 set fv " for the \"$viewname($view)\" view"
1362             }
1363             if {[string range $err 0 4] == "usage"} {
1364                 set err "Gitk: error reading commits$fv:\
1365                         bad arguments to git log."
1366                 if {$viewname($view) eq "Command line"} {
1367                     append err \
1368                         "  (Note: arguments to gitk are passed to git log\
1369                          to allow selection of commits to be displayed.)"
1370                 }
1371             } else {
1372                 set err "Error reading commits$fv: $err"
1373             }
1374             error_popup $err
1375         }
1376         if {[incr viewactive($view) -1] <= 0} {
1377             set viewcomplete($view) 1
1378             # Check if we have seen any ids listed as parents that haven't
1379             # appeared in the list
1380             closevarcs $view
1381             notbusy $view
1382         }
1383         if {$view == $curview} {
1384             run chewcommits
1385         }
1386         return 0
1387     }
1388     set start 0
1389     set gotsome 0
1390     set scripts {}
1391     while 1 {
1392         set i [string first "\0" $stuff $start]
1393         if {$i < 0} {
1394             append leftover($inst) [string range $stuff $start end]
1395             break
1396         }
1397         if {$start == 0} {
1398             set cmit $leftover($inst)
1399             append cmit [string range $stuff 0 [expr {$i - 1}]]
1400             set leftover($inst) {}
1401         } else {
1402             set cmit [string range $stuff $start [expr {$i - 1}]]
1403         }
1404         set start [expr {$i + 1}]
1405         set j [string first "\n" $cmit]
1406         set ok 0
1407         set listed 1
1408         if {$j >= 0 && [string match "commit *" $cmit]} {
1409             set ids [string range $cmit 7 [expr {$j - 1}]]
1410             if {[string match {[-^<>]*} $ids]} {
1411                 switch -- [string index $ids 0] {
1412                     "-" {set listed 0}
1413                     "^" {set listed 2}
1414                     "<" {set listed 3}
1415                     ">" {set listed 4}
1416                 }
1417                 set ids [string range $ids 1 end]
1418             }
1419             set ok 1
1420             foreach id $ids {
1421                 if {[string length $id] != 40} {
1422                     set ok 0
1423                     break
1424                 }
1425             }
1426         }
1427         if {!$ok} {
1428             set shortcmit $cmit
1429             if {[string length $shortcmit] > 80} {
1430                 set shortcmit "[string range $shortcmit 0 80]..."
1431             }
1432             error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1433             exit 1
1434         }
1435         set id [lindex $ids 0]
1436         set vid $view,$id
1438         if {!$listed && $updating && ![info exists varcid($vid)] &&
1439             $vfilelimit($view) ne {}} {
1440             # git log doesn't rewrite parents for unlisted commits
1441             # when doing path limiting, so work around that here
1442             # by working out the rewritten parent with git rev-list
1443             # and if we already know about it, using the rewritten
1444             # parent as a substitute parent for $id's children.
1445             if {![catch {
1446                 set rwid [exec git rev-list --first-parent --max-count=1 \
1447                               $id -- $vfilelimit($view)]
1448             }]} {
1449                 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1450                     # use $rwid in place of $id
1451                     rewrite_commit $view $id $rwid
1452                     continue
1453                 }
1454             }
1455         }
1457         set a 0
1458         if {[info exists varcid($vid)]} {
1459             if {$cmitlisted($vid) || !$listed} continue
1460             set a $varcid($vid)
1461         }
1462         if {$listed} {
1463             set olds [lrange $ids 1 end]
1464         } else {
1465             set olds {}
1466         }
1467         set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1468         set cmitlisted($vid) $listed
1469         set parents($vid) $olds
1470         if {![info exists children($vid)]} {
1471             set children($vid) {}
1472         } elseif {$a == 0 && [llength $children($vid)] == 1} {
1473             set k [lindex $children($vid) 0]
1474             if {[llength $parents($view,$k)] == 1 &&
1475                 (!$vdatemode($view) ||
1476                  $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1477                 set a $varcid($view,$k)
1478             }
1479         }
1480         if {$a == 0} {
1481             # new arc
1482             set a [newvarc $view $id]
1483         }
1484         if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1485             modify_arc $view $a
1486         }
1487         if {![info exists varcid($vid)]} {
1488             set varcid($vid) $a
1489             lappend varccommits($view,$a) $id
1490             incr commitidx($view)
1491         }
1493         set i 0
1494         foreach p $olds {
1495             if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1496                 set vp $view,$p
1497                 if {[llength [lappend children($vp) $id]] > 1 &&
1498                     [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1499                     set children($vp) [lsort -command [list vtokcmp $view] \
1500                                            $children($vp)]
1501                     catch {unset ordertok}
1502                 }
1503                 if {[info exists varcid($view,$p)]} {
1504                     fix_reversal $p $a $view
1505                 }
1506             }
1507             incr i
1508         }
1510         set scripts [check_interest $id $scripts]
1511         set gotsome 1
1512     }
1513     if {$gotsome} {
1514         global numcommits hlview
1516         if {$view == $curview} {
1517             set numcommits $commitidx($view)
1518             run chewcommits
1519         }
1520         if {[info exists hlview] && $view == $hlview} {
1521             # we never actually get here...
1522             run vhighlightmore
1523         }
1524         foreach s $scripts {
1525             eval $s
1526         }
1527     }
1528     return 2
1531 proc chewcommits {} {
1532     global curview hlview viewcomplete
1533     global pending_select
1535     layoutmore
1536     if {$viewcomplete($curview)} {
1537         global commitidx varctok
1538         global numcommits startmsecs
1540         if {[info exists pending_select]} {
1541             update
1542             reset_pending_select {}
1544             if {[commitinview $pending_select $curview]} {
1545                 selectline [rowofcommit $pending_select] 1
1546             } else {
1547                 set row [first_real_row]
1548                 selectline $row 1
1549             }
1550         }
1551         if {$commitidx($curview) > 0} {
1552             #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1553             #puts "overall $ms ms for $numcommits commits"
1554             #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1555         } else {
1556             show_status [mc "No commits selected"]
1557         }
1558         notbusy layout
1559     }
1560     return 0
1563 proc do_readcommit {id} {
1564     global tclencoding
1566     # Invoke git-log to handle automatic encoding conversion
1567     set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1568     # Read the results using i18n.logoutputencoding
1569     fconfigure $fd -translation lf -eofchar {}
1570     if {$tclencoding != {}} {
1571         fconfigure $fd -encoding $tclencoding
1572     }
1573     set contents [read $fd]
1574     close $fd
1575     # Remove the heading line
1576     regsub {^commit [0-9a-f]+\n} $contents {} contents
1578     return $contents
1581 proc readcommit {id} {
1582     if {[catch {set contents [do_readcommit $id]}]} return
1583     parsecommit $id $contents 1
1586 proc parsecommit {id contents listed} {
1587     global commitinfo cdate
1589     set inhdr 1
1590     set comment {}
1591     set headline {}
1592     set auname {}
1593     set audate {}
1594     set comname {}
1595     set comdate {}
1596     set hdrend [string first "\n\n" $contents]
1597     if {$hdrend < 0} {
1598         # should never happen...
1599         set hdrend [string length $contents]
1600     }
1601     set header [string range $contents 0 [expr {$hdrend - 1}]]
1602     set comment [string range $contents [expr {$hdrend + 2}] end]
1603     foreach line [split $header "\n"] {
1604         set tag [lindex $line 0]
1605         if {$tag == "author"} {
1606             set audate [lindex $line end-1]
1607             set auname [lrange $line 1 end-2]
1608         } elseif {$tag == "committer"} {
1609             set comdate [lindex $line end-1]
1610             set comname [lrange $line 1 end-2]
1611         }
1612     }
1613     set headline {}
1614     # take the first non-blank line of the comment as the headline
1615     set headline [string trimleft $comment]
1616     set i [string first "\n" $headline]
1617     if {$i >= 0} {
1618         set headline [string range $headline 0 $i]
1619     }
1620     set headline [string trimright $headline]
1621     set i [string first "\r" $headline]
1622     if {$i >= 0} {
1623         set headline [string trimright [string range $headline 0 $i]]
1624     }
1625     if {!$listed} {
1626         # git log indents the comment by 4 spaces;
1627         # if we got this via git cat-file, add the indentation
1628         set newcomment {}
1629         foreach line [split $comment "\n"] {
1630             append newcomment "    "
1631             append newcomment $line
1632             append newcomment "\n"
1633         }
1634         set comment $newcomment
1635     }
1636     if {$comdate != {}} {
1637         set cdate($id) $comdate
1638     }
1639     set commitinfo($id) [list $headline $auname $audate \
1640                              $comname $comdate $comment]
1643 proc getcommit {id} {
1644     global commitdata commitinfo
1646     if {[info exists commitdata($id)]} {
1647         parsecommit $id $commitdata($id) 1
1648     } else {
1649         readcommit $id
1650         if {![info exists commitinfo($id)]} {
1651             set commitinfo($id) [list [mc "No commit information available"]]
1652         }
1653     }
1654     return 1
1657 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1658 # and are present in the current view.
1659 # This is fairly slow...
1660 proc longid {prefix} {
1661     global varcid curview
1663     set ids {}
1664     foreach match [array names varcid "$curview,$prefix*"] {
1665         lappend ids [lindex [split $match ","] 1]
1666     }
1667     return $ids
1670 proc readrefs {} {
1671     global tagids idtags headids idheads tagobjid
1672     global otherrefids idotherrefs mainhead mainheadid
1673     global selecthead selectheadid
1675     foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1676         catch {unset $v}
1677     }
1678     set refd [open [list | git show-ref -d] r]
1679     while {[gets $refd line] >= 0} {
1680         if {[string index $line 40] ne " "} continue
1681         set id [string range $line 0 39]
1682         set ref [string range $line 41 end]
1683         if {![string match "refs/*" $ref]} continue
1684         set name [string range $ref 5 end]
1685         if {[string match "remotes/*" $name]} {
1686             if {![string match "*/HEAD" $name]} {
1687                 set headids($name) $id
1688                 lappend idheads($id) $name
1689             }
1690         } elseif {[string match "heads/*" $name]} {
1691             set name [string range $name 6 end]
1692             set headids($name) $id
1693             lappend idheads($id) $name
1694         } elseif {[string match "tags/*" $name]} {
1695             # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1696             # which is what we want since the former is the commit ID
1697             set name [string range $name 5 end]
1698             if {[string match "*^{}" $name]} {
1699                 set name [string range $name 0 end-3]
1700             } else {
1701                 set tagobjid($name) $id
1702             }
1703             set tagids($name) $id
1704             lappend idtags($id) $name
1705         } else {
1706             set otherrefids($name) $id
1707             lappend idotherrefs($id) $name
1708         }
1709     }
1710     catch {close $refd}
1711     set mainhead {}
1712     set mainheadid {}
1713     catch {
1714         set mainheadid [exec git rev-parse HEAD]
1715         set thehead [exec git symbolic-ref HEAD]
1716         if {[string match "refs/heads/*" $thehead]} {
1717             set mainhead [string range $thehead 11 end]
1718         }
1719     }
1720     set selectheadid {}
1721     if {$selecthead ne {}} {
1722         catch {
1723             set selectheadid [exec git rev-parse --verify $selecthead]
1724         }
1725     }
1728 # skip over fake commits
1729 proc first_real_row {} {
1730     global nullid nullid2 numcommits
1732     for {set row 0} {$row < $numcommits} {incr row} {
1733         set id [commitonrow $row]
1734         if {$id ne $nullid && $id ne $nullid2} {
1735             break
1736         }
1737     }
1738     return $row
1741 # update things for a head moved to a child of its previous location
1742 proc movehead {id name} {
1743     global headids idheads
1745     removehead $headids($name) $name
1746     set headids($name) $id
1747     lappend idheads($id) $name
1750 # update things when a head has been removed
1751 proc removehead {id name} {
1752     global headids idheads
1754     if {$idheads($id) eq $name} {
1755         unset idheads($id)
1756     } else {
1757         set i [lsearch -exact $idheads($id) $name]
1758         if {$i >= 0} {
1759             set idheads($id) [lreplace $idheads($id) $i $i]
1760         }
1761     }
1762     unset headids($name)
1765 proc make_transient {window origin} {
1766     global have_tk85
1768     # In MacOS Tk 8.4 transient appears to work by setting
1769     # overrideredirect, which is utterly useless, since the
1770     # windows get no border, and are not even kept above
1771     # the parent.
1772     if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1774     wm transient $window $origin
1776     # Windows fails to place transient windows normally, so
1777     # schedule a callback to center them on the parent.
1778     if {[tk windowingsystem] eq {win32}} {
1779         after idle [list tk::PlaceWindow $window widget $origin]
1780     }
1783 proc show_error {w top msg} {
1784     message $w.m -text $msg -justify center -aspect 400
1785     pack $w.m -side top -fill x -padx 20 -pady 20
1786     button $w.ok -text [mc OK] -command "destroy $top"
1787     pack $w.ok -side bottom -fill x
1788     bind $top <Visibility> "grab $top; focus $top"
1789     bind $top <Key-Return> "destroy $top"
1790     bind $top <Key-space>  "destroy $top"
1791     bind $top <Key-Escape> "destroy $top"
1792     tkwait window $top
1795 proc error_popup {msg {owner .}} {
1796     set w .error
1797     toplevel $w
1798     make_transient $w $owner
1799     show_error $w $w $msg
1802 proc confirm_popup {msg {owner .}} {
1803     global confirm_ok
1804     set confirm_ok 0
1805     set w .confirm
1806     toplevel $w
1807     make_transient $w $owner
1808     message $w.m -text $msg -justify center -aspect 400
1809     pack $w.m -side top -fill x -padx 20 -pady 20
1810     button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1811     pack $w.ok -side left -fill x
1812     button $w.cancel -text [mc Cancel] -command "destroy $w"
1813     pack $w.cancel -side right -fill x
1814     bind $w <Visibility> "grab $w; focus $w"
1815     bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1816     bind $w <Key-space>  "set confirm_ok 1; destroy $w"
1817     bind $w <Key-Escape> "destroy $w"
1818     tkwait window $w
1819     return $confirm_ok
1822 proc setoptions {} {
1823     option add *Panedwindow.showHandle 1 startupFile
1824     option add *Panedwindow.sashRelief raised startupFile
1825     option add *Button.font uifont startupFile
1826     option add *Checkbutton.font uifont startupFile
1827     option add *Radiobutton.font uifont startupFile
1828     option add *Menu.font uifont startupFile
1829     option add *Menubutton.font uifont startupFile
1830     option add *Label.font uifont startupFile
1831     option add *Message.font uifont startupFile
1832     option add *Entry.font uifont startupFile
1835 # Make a menu and submenus.
1836 # m is the window name for the menu, items is the list of menu items to add.
1837 # Each item is a list {mc label type description options...}
1838 # mc is ignored; it's so we can put mc there to alert xgettext
1839 # label is the string that appears in the menu
1840 # type is cascade, command or radiobutton (should add checkbutton)
1841 # description depends on type; it's the sublist for cascade, the
1842 # command to invoke for command, or {variable value} for radiobutton
1843 proc makemenu {m items} {
1844     menu $m
1845     if {[tk windowingsystem] eq {aqua}} {
1846         set Meta1 Cmd
1847     } else {
1848         set Meta1 Ctrl
1849     }
1850     foreach i $items {
1851         set name [mc [lindex $i 1]]
1852         set type [lindex $i 2]
1853         set thing [lindex $i 3]
1854         set params [list $type]
1855         if {$name ne {}} {
1856             set u [string first "&" [string map {&& x} $name]]
1857             lappend params -label [string map {&& & & {}} $name]
1858             if {$u >= 0} {
1859                 lappend params -underline $u
1860             }
1861         }
1862         switch -- $type {
1863             "cascade" {
1864                 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1865                 lappend params -menu $m.$submenu
1866             }
1867             "command" {
1868                 lappend params -command $thing
1869             }
1870             "radiobutton" {
1871                 lappend params -variable [lindex $thing 0] \
1872                     -value [lindex $thing 1]
1873             }
1874         }
1875         set tail [lrange $i 4 end]
1876         regsub -all {\yMeta1\y} $tail $Meta1 tail
1877         eval $m add $params $tail
1878         if {$type eq "cascade"} {
1879             makemenu $m.$submenu $thing
1880         }
1881     }
1884 # translate string and remove ampersands
1885 proc mca {str} {
1886     return [string map {&& & & {}} [mc $str]]
1889 proc makewindow {} {
1890     global canv canv2 canv3 linespc charspc ctext cflist cscroll
1891     global tabstop
1892     global findtype findtypemenu findloc findstring fstring geometry
1893     global entries sha1entry sha1string sha1but
1894     global diffcontextstring diffcontext
1895     global ignorespace
1896     global maincursor textcursor curtextcursor
1897     global rowctxmenu fakerowmenu mergemax wrapcomment
1898     global highlight_files gdttype
1899     global searchstring sstring
1900     global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1901     global headctxmenu progresscanv progressitem progresscoords statusw
1902     global fprogitem fprogcoord lastprogupdate progupdatepending
1903     global rprogitem rprogcoord rownumsel numcommits
1904     global have_tk85
1906     # The "mc" arguments here are purely so that xgettext
1907     # sees the following string as needing to be translated
1908     makemenu .bar {
1909         {mc "File" cascade {
1910             {mc "Update" command updatecommits -accelerator F5}
1911             {mc "Reload" command reloadcommits -accelerator Meta1-F5}
1912             {mc "Reread references" command rereadrefs}
1913             {mc "List references" command showrefs -accelerator F2}
1914             {mc "Quit" command doquit -accelerator Meta1-Q}
1915         }}
1916         {mc "Edit" cascade {
1917             {mc "Preferences" command doprefs}
1918         }}
1919         {mc "View" cascade {
1920             {mc "New view..." command {newview 0} -accelerator Shift-F4}
1921             {mc "Edit view..." command editview -state disabled -accelerator F4}
1922             {mc "Delete view" command delview -state disabled}
1923             {xx "" separator}
1924             {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1925         }}
1926         {mc "Help" cascade {
1927             {mc "About gitk" command about}
1928             {mc "Key bindings" command keys}
1929         }}
1930     }
1931     . configure -menu .bar
1933     # the gui has upper and lower half, parts of a paned window.
1934     panedwindow .ctop -orient vertical
1936     # possibly use assumed geometry
1937     if {![info exists geometry(pwsash0)]} {
1938         set geometry(topheight) [expr {15 * $linespc}]
1939         set geometry(topwidth) [expr {80 * $charspc}]
1940         set geometry(botheight) [expr {15 * $linespc}]
1941         set geometry(botwidth) [expr {50 * $charspc}]
1942         set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1943         set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1944     }
1946     # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1947     frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1948     frame .tf.histframe
1949     panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1951     # create three canvases
1952     set cscroll .tf.histframe.csb
1953     set canv .tf.histframe.pwclist.canv
1954     canvas $canv \
1955         -selectbackground $selectbgcolor \
1956         -background $bgcolor -bd 0 \
1957         -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1958     .tf.histframe.pwclist add $canv
1959     set canv2 .tf.histframe.pwclist.canv2
1960     canvas $canv2 \
1961         -selectbackground $selectbgcolor \
1962         -background $bgcolor -bd 0 -yscrollincr $linespc
1963     .tf.histframe.pwclist add $canv2
1964     set canv3 .tf.histframe.pwclist.canv3
1965     canvas $canv3 \
1966         -selectbackground $selectbgcolor \
1967         -background $bgcolor -bd 0 -yscrollincr $linespc
1968     .tf.histframe.pwclist add $canv3
1969     eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1970     eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1972     # a scroll bar to rule them
1973     scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1974     pack $cscroll -side right -fill y
1975     bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1976     lappend bglist $canv $canv2 $canv3
1977     pack .tf.histframe.pwclist -fill both -expand 1 -side left
1979     # we have two button bars at bottom of top frame. Bar 1
1980     frame .tf.bar
1981     frame .tf.lbar -height 15
1983     set sha1entry .tf.bar.sha1
1984     set entries $sha1entry
1985     set sha1but .tf.bar.sha1label
1986     button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1987         -command gotocommit -width 8
1988     $sha1but conf -disabledforeground [$sha1but cget -foreground]
1989     pack .tf.bar.sha1label -side left
1990     entry $sha1entry -width 40 -font textfont -textvariable sha1string
1991     trace add variable sha1string write sha1change
1992     pack $sha1entry -side left -pady 2
1994     image create bitmap bm-left -data {
1995         #define left_width 16
1996         #define left_height 16
1997         static unsigned char left_bits[] = {
1998         0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1999         0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2000         0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2001     }
2002     image create bitmap bm-right -data {
2003         #define right_width 16
2004         #define right_height 16
2005         static unsigned char right_bits[] = {
2006         0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2007         0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2008         0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2009     }
2010     button .tf.bar.leftbut -image bm-left -command goback \
2011         -state disabled -width 26
2012     pack .tf.bar.leftbut -side left -fill y
2013     button .tf.bar.rightbut -image bm-right -command goforw \
2014         -state disabled -width 26
2015     pack .tf.bar.rightbut -side left -fill y
2017     label .tf.bar.rowlabel -text [mc "Row"]
2018     set rownumsel {}
2019     label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2020         -relief sunken -anchor e
2021     label .tf.bar.rowlabel2 -text "/"
2022     label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2023         -relief sunken -anchor e
2024     pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2025         -side left
2026     global selectedline
2027     trace add variable selectedline write selectedline_change
2029     # Status label and progress bar
2030     set statusw .tf.bar.status
2031     label $statusw -width 15 -relief sunken
2032     pack $statusw -side left -padx 5
2033     set h [expr {[font metrics uifont -linespace] + 2}]
2034     set progresscanv .tf.bar.progress
2035     canvas $progresscanv -relief sunken -height $h -borderwidth 2
2036     set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2037     set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2038     set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2039     pack $progresscanv -side right -expand 1 -fill x
2040     set progresscoords {0 0}
2041     set fprogcoord 0
2042     set rprogcoord 0
2043     bind $progresscanv <Configure> adjustprogress
2044     set lastprogupdate [clock clicks -milliseconds]
2045     set progupdatepending 0
2047     # build up the bottom bar of upper window
2048     label .tf.lbar.flabel -text "[mc "Find"] "
2049     button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2050     button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2051     label .tf.lbar.flab2 -text " [mc "commit"] "
2052     pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2053         -side left -fill y
2054     set gdttype [mc "containing:"]
2055     set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2056                 [mc "containing:"] \
2057                 [mc "touching paths:"] \
2058                 [mc "adding/removing string:"]]
2059     trace add variable gdttype write gdttype_change
2060     pack .tf.lbar.gdttype -side left -fill y
2062     set findstring {}
2063     set fstring .tf.lbar.findstring
2064     lappend entries $fstring
2065     entry $fstring -width 30 -font textfont -textvariable findstring
2066     trace add variable findstring write find_change
2067     set findtype [mc "Exact"]
2068     set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2069                       findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2070     trace add variable findtype write findcom_change
2071     set findloc [mc "All fields"]
2072     tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2073         [mc "Comments"] [mc "Author"] [mc "Committer"]
2074     trace add variable findloc write find_change
2075     pack .tf.lbar.findloc -side right
2076     pack .tf.lbar.findtype -side right
2077     pack $fstring -side left -expand 1 -fill x
2079     # Finish putting the upper half of the viewer together
2080     pack .tf.lbar -in .tf -side bottom -fill x
2081     pack .tf.bar -in .tf -side bottom -fill x
2082     pack .tf.histframe -fill both -side top -expand 1
2083     .ctop add .tf
2084     .ctop paneconfigure .tf -height $geometry(topheight)
2085     .ctop paneconfigure .tf -width $geometry(topwidth)
2087     # now build up the bottom
2088     panedwindow .pwbottom -orient horizontal
2090     # lower left, a text box over search bar, scroll bar to the right
2091     # if we know window height, then that will set the lower text height, otherwise
2092     # we set lower text height which will drive window height
2093     if {[info exists geometry(main)]} {
2094         frame .bleft -width $geometry(botwidth)
2095     } else {
2096         frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2097     }
2098     frame .bleft.top
2099     frame .bleft.mid
2100     frame .bleft.bottom
2102     button .bleft.top.search -text [mc "Search"] -command dosearch
2103     pack .bleft.top.search -side left -padx 5
2104     set sstring .bleft.top.sstring
2105     entry $sstring -width 20 -font textfont -textvariable searchstring
2106     lappend entries $sstring
2107     trace add variable searchstring write incrsearch
2108     pack $sstring -side left -expand 1 -fill x
2109     radiobutton .bleft.mid.diff -text [mc "Diff"] \
2110         -command changediffdisp -variable diffelide -value {0 0}
2111     radiobutton .bleft.mid.old -text [mc "Old version"] \
2112         -command changediffdisp -variable diffelide -value {0 1}
2113     radiobutton .bleft.mid.new -text [mc "New version"] \
2114         -command changediffdisp -variable diffelide -value {1 0}
2115     label .bleft.mid.labeldiffcontext -text "      [mc "Lines of context"]: "
2116     pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2117     spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2118         -from 1 -increment 1 -to 10000000 \
2119         -validate all -validatecommand "diffcontextvalidate %P" \
2120         -textvariable diffcontextstring
2121     .bleft.mid.diffcontext set $diffcontext
2122     trace add variable diffcontextstring write diffcontextchange
2123     lappend entries .bleft.mid.diffcontext
2124     pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2125     checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2126         -command changeignorespace -variable ignorespace
2127     pack .bleft.mid.ignspace -side left -padx 5
2128     set ctext .bleft.bottom.ctext
2129     text $ctext -background $bgcolor -foreground $fgcolor \
2130         -state disabled -font textfont \
2131         -yscrollcommand scrolltext -wrap none \
2132         -xscrollcommand ".bleft.bottom.sbhorizontal set"
2133     if {$have_tk85} {
2134         $ctext conf -tabstyle wordprocessor
2135     }
2136     scrollbar .bleft.bottom.sb -command "$ctext yview"
2137     scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2138         -width 10
2139     pack .bleft.top -side top -fill x
2140     pack .bleft.mid -side top -fill x
2141     grid $ctext .bleft.bottom.sb -sticky nsew
2142     grid .bleft.bottom.sbhorizontal -sticky ew
2143     grid columnconfigure .bleft.bottom 0 -weight 1
2144     grid rowconfigure .bleft.bottom 0 -weight 1
2145     grid rowconfigure .bleft.bottom 1 -weight 0
2146     pack .bleft.bottom -side top -fill both -expand 1
2147     lappend bglist $ctext
2148     lappend fglist $ctext
2150     $ctext tag conf comment -wrap $wrapcomment
2151     $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2152     $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2153     $ctext tag conf d0 -fore [lindex $diffcolors 0]
2154     $ctext tag conf dresult -fore [lindex $diffcolors 1]
2155     $ctext tag conf m0 -fore red
2156     $ctext tag conf m1 -fore blue
2157     $ctext tag conf m2 -fore green
2158     $ctext tag conf m3 -fore purple
2159     $ctext tag conf m4 -fore brown
2160     $ctext tag conf m5 -fore "#009090"
2161     $ctext tag conf m6 -fore magenta
2162     $ctext tag conf m7 -fore "#808000"
2163     $ctext tag conf m8 -fore "#009000"
2164     $ctext tag conf m9 -fore "#ff0080"
2165     $ctext tag conf m10 -fore cyan
2166     $ctext tag conf m11 -fore "#b07070"
2167     $ctext tag conf m12 -fore "#70b0f0"
2168     $ctext tag conf m13 -fore "#70f0b0"
2169     $ctext tag conf m14 -fore "#f0b070"
2170     $ctext tag conf m15 -fore "#ff70b0"
2171     $ctext tag conf mmax -fore darkgrey
2172     set mergemax 16
2173     $ctext tag conf mresult -font textfontbold
2174     $ctext tag conf msep -font textfontbold
2175     $ctext tag conf found -back yellow
2177     .pwbottom add .bleft
2178     .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2180     # lower right
2181     frame .bright
2182     frame .bright.mode
2183     radiobutton .bright.mode.patch -text [mc "Patch"] \
2184         -command reselectline -variable cmitmode -value "patch"
2185     radiobutton .bright.mode.tree -text [mc "Tree"] \
2186         -command reselectline -variable cmitmode -value "tree"
2187     grid .bright.mode.patch .bright.mode.tree -sticky ew
2188     pack .bright.mode -side top -fill x
2189     set cflist .bright.cfiles
2190     set indent [font measure mainfont "nn"]
2191     text $cflist \
2192         -selectbackground $selectbgcolor \
2193         -background $bgcolor -foreground $fgcolor \
2194         -font mainfont \
2195         -tabs [list $indent [expr {2 * $indent}]] \
2196         -yscrollcommand ".bright.sb set" \
2197         -cursor [. cget -cursor] \
2198         -spacing1 1 -spacing3 1
2199     lappend bglist $cflist
2200     lappend fglist $cflist
2201     scrollbar .bright.sb -command "$cflist yview"
2202     pack .bright.sb -side right -fill y
2203     pack $cflist -side left -fill both -expand 1
2204     $cflist tag configure highlight \
2205         -background [$cflist cget -selectbackground]
2206     $cflist tag configure bold -font mainfontbold
2208     .pwbottom add .bright
2209     .ctop add .pwbottom
2211     # restore window width & height if known
2212     if {[info exists geometry(main)]} {
2213         if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2214             if {$w > [winfo screenwidth .]} {
2215                 set w [winfo screenwidth .]
2216             }
2217             if {$h > [winfo screenheight .]} {
2218                 set h [winfo screenheight .]
2219             }
2220             wm geometry . "${w}x$h"
2221         }
2222     }
2224     if {[tk windowingsystem] eq {aqua}} {
2225         set M1B M1
2226     } else {
2227         set M1B Control
2228     }
2230     bind .pwbottom <Configure> {resizecdetpanes %W %w}
2231     pack .ctop -fill both -expand 1
2232     bindall <1> {selcanvline %W %x %y}
2233     #bindall <B1-Motion> {selcanvline %W %x %y}
2234     if {[tk windowingsystem] == "win32"} {
2235         bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2236         bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2237     } else {
2238         bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2239         bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2240         if {[tk windowingsystem] eq "aqua"} {
2241             bindall <MouseWheel> {
2242                 set delta [expr {- (%D)}]
2243                 allcanvs yview scroll $delta units
2244             }
2245         }
2246     }
2247     bindall <2> "canvscan mark %W %x %y"
2248     bindall <B2-Motion> "canvscan dragto %W %x %y"
2249     bindkey <Home> selfirstline
2250     bindkey <End> sellastline
2251     bind . <Key-Up> "selnextline -1"
2252     bind . <Key-Down> "selnextline 1"
2253     bind . <Shift-Key-Up> "dofind -1 0"
2254     bind . <Shift-Key-Down> "dofind 1 0"
2255     bindkey <Key-Right> "goforw"
2256     bindkey <Key-Left> "goback"
2257     bind . <Key-Prior> "selnextpage -1"
2258     bind . <Key-Next> "selnextpage 1"
2259     bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2260     bind . <$M1B-End> "allcanvs yview moveto 1.0"
2261     bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2262     bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2263     bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2264     bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2265     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2266     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2267     bindkey <Key-space> "$ctext yview scroll 1 pages"
2268     bindkey p "selnextline -1"
2269     bindkey n "selnextline 1"
2270     bindkey z "goback"
2271     bindkey x "goforw"
2272     bindkey i "selnextline -1"
2273     bindkey k "selnextline 1"
2274     bindkey j "goback"
2275     bindkey l "goforw"
2276     bindkey b prevfile
2277     bindkey d "$ctext yview scroll 18 units"
2278     bindkey u "$ctext yview scroll -18 units"
2279     bindkey / {dofind 1 1}
2280     bindkey <Key-Return> {dofind 1 1}
2281     bindkey ? {dofind -1 1}
2282     bindkey f nextfile
2283     bind . <F5> updatecommits
2284     bind . <$M1B-F5> reloadcommits
2285     bind . <F2> showrefs
2286     bind . <Shift-F4> {newview 0}
2287     catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2288     bind . <F4> edit_or_newview
2289     bind . <$M1B-q> doquit
2290     bind . <$M1B-f> {dofind 1 1}
2291     bind . <$M1B-g> {dofind 1 0}
2292     bind . <$M1B-r> dosearchback
2293     bind . <$M1B-s> dosearch
2294     bind . <$M1B-equal> {incrfont 1}
2295     bind . <$M1B-plus> {incrfont 1}
2296     bind . <$M1B-KP_Add> {incrfont 1}
2297     bind . <$M1B-minus> {incrfont -1}
2298     bind . <$M1B-KP_Subtract> {incrfont -1}
2299     wm protocol . WM_DELETE_WINDOW doquit
2300     bind . <Destroy> {stop_backends}
2301     bind . <Button-1> "click %W"
2302     bind $fstring <Key-Return> {dofind 1 1}
2303     bind $sha1entry <Key-Return> {gotocommit; break}
2304     bind $sha1entry <<PasteSelection>> clearsha1
2305     bind $cflist <1> {sel_flist %W %x %y; break}
2306     bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2307     bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2308     global ctxbut
2309     bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2310     bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2312     set maincursor [. cget -cursor]
2313     set textcursor [$ctext cget -cursor]
2314     set curtextcursor $textcursor
2316     set rowctxmenu .rowctxmenu
2317     makemenu $rowctxmenu {
2318         {mc "Diff this -> selected" command {diffvssel 0}}
2319         {mc "Diff selected -> this" command {diffvssel 1}}
2320         {mc "Make patch" command mkpatch}
2321         {mc "Create tag" command mktag}
2322         {mc "Write commit to file" command writecommit}
2323         {mc "Create new branch" command mkbranch}
2324         {mc "Cherry-pick this commit" command cherrypick}
2325         {mc "Reset HEAD branch to here" command resethead}
2326     }
2327     $rowctxmenu configure -tearoff 0
2329     set fakerowmenu .fakerowmenu
2330     makemenu $fakerowmenu {
2331         {mc "Diff this -> selected" command {diffvssel 0}}
2332         {mc "Diff selected -> this" command {diffvssel 1}}
2333         {mc "Make patch" command mkpatch}
2334     }
2335     $fakerowmenu configure -tearoff 0
2337     set headctxmenu .headctxmenu
2338     makemenu $headctxmenu {
2339         {mc "Check out this branch" command cobranch}
2340         {mc "Remove this branch" command rmbranch}
2341     }
2342     $headctxmenu configure -tearoff 0
2344     global flist_menu
2345     set flist_menu .flistctxmenu
2346     makemenu $flist_menu {
2347         {mc "Highlight this too" command {flist_hl 0}}
2348         {mc "Highlight this only" command {flist_hl 1}}
2349         {mc "External diff" command {external_diff}}
2350         {mc "Blame parent commit" command {external_blame 1}}
2351     }
2352     $flist_menu configure -tearoff 0
2354     global diff_menu
2355     set diff_menu .diffctxmenu
2356     makemenu $diff_menu {
2357         {mc "Show origin of this line" command show_line_source}
2358         {mc "Run git gui blame on this line" command {external_blame_diff}}
2359     }
2360     $diff_menu configure -tearoff 0
2363 # Windows sends all mouse wheel events to the current focused window, not
2364 # the one where the mouse hovers, so bind those events here and redirect
2365 # to the correct window
2366 proc windows_mousewheel_redirector {W X Y D} {
2367     global canv canv2 canv3
2368     set w [winfo containing -displayof $W $X $Y]
2369     if {$w ne ""} {
2370         set u [expr {$D < 0 ? 5 : -5}]
2371         if {$w == $canv || $w == $canv2 || $w == $canv3} {
2372             allcanvs yview scroll $u units
2373         } else {
2374             catch {
2375                 $w yview scroll $u units
2376             }
2377         }
2378     }
2381 # Update row number label when selectedline changes
2382 proc selectedline_change {n1 n2 op} {
2383     global selectedline rownumsel
2385     if {$selectedline eq {}} {
2386         set rownumsel {}
2387     } else {
2388         set rownumsel [expr {$selectedline + 1}]
2389     }
2392 # mouse-2 makes all windows scan vertically, but only the one
2393 # the cursor is in scans horizontally
2394 proc canvscan {op w x y} {
2395     global canv canv2 canv3
2396     foreach c [list $canv $canv2 $canv3] {
2397         if {$c == $w} {
2398             $c scan $op $x $y
2399         } else {
2400             $c scan $op 0 $y
2401         }
2402     }
2405 proc scrollcanv {cscroll f0 f1} {
2406     $cscroll set $f0 $f1
2407     drawvisible
2408     flushhighlights
2411 # when we make a key binding for the toplevel, make sure
2412 # it doesn't get triggered when that key is pressed in the
2413 # find string entry widget.
2414 proc bindkey {ev script} {
2415     global entries
2416     bind . $ev $script
2417     set escript [bind Entry $ev]
2418     if {$escript == {}} {
2419         set escript [bind Entry <Key>]
2420     }
2421     foreach e $entries {
2422         bind $e $ev "$escript; break"
2423     }
2426 # set the focus back to the toplevel for any click outside
2427 # the entry widgets
2428 proc click {w} {
2429     global ctext entries
2430     foreach e [concat $entries $ctext] {
2431         if {$w == $e} return
2432     }
2433     focus .
2436 # Adjust the progress bar for a change in requested extent or canvas size
2437 proc adjustprogress {} {
2438     global progresscanv progressitem progresscoords
2439     global fprogitem fprogcoord lastprogupdate progupdatepending
2440     global rprogitem rprogcoord
2442     set w [expr {[winfo width $progresscanv] - 4}]
2443     set x0 [expr {$w * [lindex $progresscoords 0]}]
2444     set x1 [expr {$w * [lindex $progresscoords 1]}]
2445     set h [winfo height $progresscanv]
2446     $progresscanv coords $progressitem $x0 0 $x1 $h
2447     $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2448     $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2449     set now [clock clicks -milliseconds]
2450     if {$now >= $lastprogupdate + 100} {
2451         set progupdatepending 0
2452         update
2453     } elseif {!$progupdatepending} {
2454         set progupdatepending 1
2455         after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2456     }
2459 proc doprogupdate {} {
2460     global lastprogupdate progupdatepending
2462     if {$progupdatepending} {
2463         set progupdatepending 0
2464         set lastprogupdate [clock clicks -milliseconds]
2465         update
2466     }
2469 proc savestuff {w} {
2470     global canv canv2 canv3 mainfont textfont uifont tabstop
2471     global stuffsaved findmergefiles maxgraphpct
2472     global maxwidth showneartags showlocalchanges
2473     global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2474     global cmitmode wrapcomment datetimeformat limitdiffs
2475     global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2476     global autoselect extdifftool perfile_attrs markbgcolor
2478     if {$stuffsaved} return
2479     if {![winfo viewable .]} return
2480     catch {
2481         set f [open "~/.gitk-new" w]
2482         puts $f [list set mainfont $mainfont]
2483         puts $f [list set textfont $textfont]
2484         puts $f [list set uifont $uifont]
2485         puts $f [list set tabstop $tabstop]
2486         puts $f [list set findmergefiles $findmergefiles]
2487         puts $f [list set maxgraphpct $maxgraphpct]
2488         puts $f [list set maxwidth $maxwidth]
2489         puts $f [list set cmitmode $cmitmode]
2490         puts $f [list set wrapcomment $wrapcomment]
2491         puts $f [list set autoselect $autoselect]
2492         puts $f [list set showneartags $showneartags]
2493         puts $f [list set showlocalchanges $showlocalchanges]
2494         puts $f [list set datetimeformat $datetimeformat]
2495         puts $f [list set limitdiffs $limitdiffs]
2496         puts $f [list set bgcolor $bgcolor]
2497         puts $f [list set fgcolor $fgcolor]
2498         puts $f [list set colors $colors]
2499         puts $f [list set diffcolors $diffcolors]
2500         puts $f [list set markbgcolor $markbgcolor]
2501         puts $f [list set diffcontext $diffcontext]
2502         puts $f [list set selectbgcolor $selectbgcolor]
2503         puts $f [list set extdifftool $extdifftool]
2504         puts $f [list set perfile_attrs $perfile_attrs]
2506         puts $f "set geometry(main) [wm geometry .]"
2507         puts $f "set geometry(topwidth) [winfo width .tf]"
2508         puts $f "set geometry(topheight) [winfo height .tf]"
2509         puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2510         puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2511         puts $f "set geometry(botwidth) [winfo width .bleft]"
2512         puts $f "set geometry(botheight) [winfo height .bleft]"
2514         puts -nonewline $f "set permviews {"
2515         for {set v 0} {$v < $nextviewnum} {incr v} {
2516             if {$viewperm($v)} {
2517                 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2518             }
2519         }
2520         puts $f "}"
2521         close $f
2522         file rename -force "~/.gitk-new" "~/.gitk"
2523     }
2524     set stuffsaved 1
2527 proc resizeclistpanes {win w} {
2528     global oldwidth
2529     if {[info exists oldwidth($win)]} {
2530         set s0 [$win sash coord 0]
2531         set s1 [$win sash coord 1]
2532         if {$w < 60} {
2533             set sash0 [expr {int($w/2 - 2)}]
2534             set sash1 [expr {int($w*5/6 - 2)}]
2535         } else {
2536             set factor [expr {1.0 * $w / $oldwidth($win)}]
2537             set sash0 [expr {int($factor * [lindex $s0 0])}]
2538             set sash1 [expr {int($factor * [lindex $s1 0])}]
2539             if {$sash0 < 30} {
2540                 set sash0 30
2541             }
2542             if {$sash1 < $sash0 + 20} {
2543                 set sash1 [expr {$sash0 + 20}]
2544             }
2545             if {$sash1 > $w - 10} {
2546                 set sash1 [expr {$w - 10}]
2547                 if {$sash0 > $sash1 - 20} {
2548                     set sash0 [expr {$sash1 - 20}]
2549                 }
2550             }
2551         }
2552         $win sash place 0 $sash0 [lindex $s0 1]
2553         $win sash place 1 $sash1 [lindex $s1 1]
2554     }
2555     set oldwidth($win) $w
2558 proc resizecdetpanes {win w} {
2559     global oldwidth
2560     if {[info exists oldwidth($win)]} {
2561         set s0 [$win sash coord 0]
2562         if {$w < 60} {
2563             set sash0 [expr {int($w*3/4 - 2)}]
2564         } else {
2565             set factor [expr {1.0 * $w / $oldwidth($win)}]
2566             set sash0 [expr {int($factor * [lindex $s0 0])}]
2567             if {$sash0 < 45} {
2568                 set sash0 45
2569             }
2570             if {$sash0 > $w - 15} {
2571                 set sash0 [expr {$w - 15}]
2572             }
2573         }
2574         $win sash place 0 $sash0 [lindex $s0 1]
2575     }
2576     set oldwidth($win) $w
2579 proc allcanvs args {
2580     global canv canv2 canv3
2581     eval $canv $args
2582     eval $canv2 $args
2583     eval $canv3 $args
2586 proc bindall {event action} {
2587     global canv canv2 canv3
2588     bind $canv $event $action
2589     bind $canv2 $event $action
2590     bind $canv3 $event $action
2593 proc about {} {
2594     global uifont
2595     set w .about
2596     if {[winfo exists $w]} {
2597         raise $w
2598         return
2599     }
2600     toplevel $w
2601     wm title $w [mc "About gitk"]
2602     make_transient $w .
2603     message $w.m -text [mc "
2604 Gitk - a commit viewer for git
2606 Copyright © 2005-2008 Paul Mackerras
2608 Use and redistribute under the terms of the GNU General Public License"] \
2609             -justify center -aspect 400 -border 2 -bg white -relief groove
2610     pack $w.m -side top -fill x -padx 2 -pady 2
2611     button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2612     pack $w.ok -side bottom
2613     bind $w <Visibility> "focus $w.ok"
2614     bind $w <Key-Escape> "destroy $w"
2615     bind $w <Key-Return> "destroy $w"
2618 proc keys {} {
2619     set w .keys
2620     if {[winfo exists $w]} {
2621         raise $w
2622         return
2623     }
2624     if {[tk windowingsystem] eq {aqua}} {
2625         set M1T Cmd
2626     } else {
2627         set M1T Ctrl
2628     }
2629     toplevel $w
2630     wm title $w [mc "Gitk key bindings"]
2631     make_transient $w .
2632     message $w.m -text "
2633 [mc "Gitk key bindings:"]
2635 [mc "<%s-Q>             Quit" $M1T]
2636 [mc "<Home>             Move to first commit"]
2637 [mc "<End>              Move to last commit"]
2638 [mc "<Up>, p, i Move up one commit"]
2639 [mc "<Down>, n, k       Move down one commit"]
2640 [mc "<Left>, z, j       Go back in history list"]
2641 [mc "<Right>, x, l      Go forward in history list"]
2642 [mc "<PageUp>   Move up one page in commit list"]
2643 [mc "<PageDown> Move down one page in commit list"]
2644 [mc "<%s-Home>  Scroll to top of commit list" $M1T]
2645 [mc "<%s-End>   Scroll to bottom of commit list" $M1T]
2646 [mc "<%s-Up>    Scroll commit list up one line" $M1T]
2647 [mc "<%s-Down>  Scroll commit list down one line" $M1T]
2648 [mc "<%s-PageUp>        Scroll commit list up one page" $M1T]
2649 [mc "<%s-PageDown>      Scroll commit list down one page" $M1T]
2650 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2651 [mc "<Shift-Down>       Find forwards (downwards, earlier commits)"]
2652 [mc "<Delete>, b        Scroll diff view up one page"]
2653 [mc "<Backspace>        Scroll diff view up one page"]
2654 [mc "<Space>            Scroll diff view down one page"]
2655 [mc "u          Scroll diff view up 18 lines"]
2656 [mc "d          Scroll diff view down 18 lines"]
2657 [mc "<%s-F>             Find" $M1T]
2658 [mc "<%s-G>             Move to next find hit" $M1T]
2659 [mc "<Return>   Move to next find hit"]
2660 [mc "/          Move to next find hit, or redo find"]
2661 [mc "?          Move to previous find hit"]
2662 [mc "f          Scroll diff view to next file"]
2663 [mc "<%s-S>             Search for next hit in diff view" $M1T]
2664 [mc "<%s-R>             Search for previous hit in diff view" $M1T]
2665 [mc "<%s-KP+>   Increase font size" $M1T]
2666 [mc "<%s-plus>  Increase font size" $M1T]
2667 [mc "<%s-KP->   Decrease font size" $M1T]
2668 [mc "<%s-minus> Decrease font size" $M1T]
2669 [mc "<F5>               Update"]
2670 " \
2671             -justify left -bg white -border 2 -relief groove
2672     pack $w.m -side top -fill both -padx 2 -pady 2
2673     button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2674     bind $w <Key-Escape> [list destroy $w]
2675     pack $w.ok -side bottom
2676     bind $w <Visibility> "focus $w.ok"
2677     bind $w <Key-Escape> "destroy $w"
2678     bind $w <Key-Return> "destroy $w"
2681 # Procedures for manipulating the file list window at the
2682 # bottom right of the overall window.
2684 proc treeview {w l openlevs} {
2685     global treecontents treediropen treeheight treeparent treeindex
2687     set ix 0
2688     set treeindex() 0
2689     set lev 0
2690     set prefix {}
2691     set prefixend -1
2692     set prefendstack {}
2693     set htstack {}
2694     set ht 0
2695     set treecontents() {}
2696     $w conf -state normal
2697     foreach f $l {
2698         while {[string range $f 0 $prefixend] ne $prefix} {
2699             if {$lev <= $openlevs} {
2700                 $w mark set e:$treeindex($prefix) "end -1c"
2701                 $w mark gravity e:$treeindex($prefix) left
2702             }
2703             set treeheight($prefix) $ht
2704             incr ht [lindex $htstack end]
2705             set htstack [lreplace $htstack end end]
2706             set prefixend [lindex $prefendstack end]
2707             set prefendstack [lreplace $prefendstack end end]
2708             set prefix [string range $prefix 0 $prefixend]
2709             incr lev -1
2710         }
2711         set tail [string range $f [expr {$prefixend+1}] end]
2712         while {[set slash [string first "/" $tail]] >= 0} {
2713             lappend htstack $ht
2714             set ht 0
2715             lappend prefendstack $prefixend
2716             incr prefixend [expr {$slash + 1}]
2717             set d [string range $tail 0 $slash]
2718             lappend treecontents($prefix) $d
2719             set oldprefix $prefix
2720             append prefix $d
2721             set treecontents($prefix) {}
2722             set treeindex($prefix) [incr ix]
2723             set treeparent($prefix) $oldprefix
2724             set tail [string range $tail [expr {$slash+1}] end]
2725             if {$lev <= $openlevs} {
2726                 set ht 1
2727                 set treediropen($prefix) [expr {$lev < $openlevs}]
2728                 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2729                 $w mark set d:$ix "end -1c"
2730                 $w mark gravity d:$ix left
2731                 set str "\n"
2732                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2733                 $w insert end $str
2734                 $w image create end -align center -image $bm -padx 1 \
2735                     -name a:$ix
2736                 $w insert end $d [highlight_tag $prefix]
2737                 $w mark set s:$ix "end -1c"
2738                 $w mark gravity s:$ix left
2739             }
2740             incr lev
2741         }
2742         if {$tail ne {}} {
2743             if {$lev <= $openlevs} {
2744                 incr ht
2745                 set str "\n"
2746                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2747                 $w insert end $str
2748                 $w insert end $tail [highlight_tag $f]
2749             }
2750             lappend treecontents($prefix) $tail
2751         }
2752     }
2753     while {$htstack ne {}} {
2754         set treeheight($prefix) $ht
2755         incr ht [lindex $htstack end]
2756         set htstack [lreplace $htstack end end]
2757         set prefixend [lindex $prefendstack end]
2758         set prefendstack [lreplace $prefendstack end end]
2759         set prefix [string range $prefix 0 $prefixend]
2760     }
2761     $w conf -state disabled
2764 proc linetoelt {l} {
2765     global treeheight treecontents
2767     set y 2
2768     set prefix {}
2769     while {1} {
2770         foreach e $treecontents($prefix) {
2771             if {$y == $l} {
2772                 return "$prefix$e"
2773             }
2774             set n 1
2775             if {[string index $e end] eq "/"} {
2776                 set n $treeheight($prefix$e)
2777                 if {$y + $n > $l} {
2778                     append prefix $e
2779                     incr y
2780                     break
2781                 }
2782             }
2783             incr y $n
2784         }
2785     }
2788 proc highlight_tree {y prefix} {
2789     global treeheight treecontents cflist
2791     foreach e $treecontents($prefix) {
2792         set path $prefix$e
2793         if {[highlight_tag $path] ne {}} {
2794             $cflist tag add bold $y.0 "$y.0 lineend"
2795         }
2796         incr y
2797         if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2798             set y [highlight_tree $y $path]
2799         }
2800     }
2801     return $y
2804 proc treeclosedir {w dir} {
2805     global treediropen treeheight treeparent treeindex
2807     set ix $treeindex($dir)
2808     $w conf -state normal
2809     $w delete s:$ix e:$ix
2810     set treediropen($dir) 0
2811     $w image configure a:$ix -image tri-rt
2812     $w conf -state disabled
2813     set n [expr {1 - $treeheight($dir)}]
2814     while {$dir ne {}} {
2815         incr treeheight($dir) $n
2816         set dir $treeparent($dir)
2817     }
2820 proc treeopendir {w dir} {
2821     global treediropen treeheight treeparent treecontents treeindex
2823     set ix $treeindex($dir)
2824     $w conf -state normal
2825     $w image configure a:$ix -image tri-dn
2826     $w mark set e:$ix s:$ix
2827     $w mark gravity e:$ix right
2828     set lev 0
2829     set str "\n"
2830     set n [llength $treecontents($dir)]
2831     for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2832         incr lev
2833         append str "\t"
2834         incr treeheight($x) $n
2835     }
2836     foreach e $treecontents($dir) {
2837         set de $dir$e
2838         if {[string index $e end] eq "/"} {
2839             set iy $treeindex($de)
2840             $w mark set d:$iy e:$ix
2841             $w mark gravity d:$iy left
2842             $w insert e:$ix $str
2843             set treediropen($de) 0
2844             $w image create e:$ix -align center -image tri-rt -padx 1 \
2845                 -name a:$iy
2846             $w insert e:$ix $e [highlight_tag $de]
2847             $w mark set s:$iy e:$ix
2848             $w mark gravity s:$iy left
2849             set treeheight($de) 1
2850         } else {
2851             $w insert e:$ix $str
2852             $w insert e:$ix $e [highlight_tag $de]
2853         }
2854     }
2855     $w mark gravity e:$ix right
2856     $w conf -state disabled
2857     set treediropen($dir) 1
2858     set top [lindex [split [$w index @0,0] .] 0]
2859     set ht [$w cget -height]
2860     set l [lindex [split [$w index s:$ix] .] 0]
2861     if {$l < $top} {
2862         $w yview $l.0
2863     } elseif {$l + $n + 1 > $top + $ht} {
2864         set top [expr {$l + $n + 2 - $ht}]
2865         if {$l < $top} {
2866             set top $l
2867         }
2868         $w yview $top.0
2869     }
2872 proc treeclick {w x y} {
2873     global treediropen cmitmode ctext cflist cflist_top
2875     if {$cmitmode ne "tree"} return
2876     if {![info exists cflist_top]} return
2877     set l [lindex [split [$w index "@$x,$y"] "."] 0]
2878     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2879     $cflist tag add highlight $l.0 "$l.0 lineend"
2880     set cflist_top $l
2881     if {$l == 1} {
2882         $ctext yview 1.0
2883         return
2884     }
2885     set e [linetoelt $l]
2886     if {[string index $e end] ne "/"} {
2887         showfile $e
2888     } elseif {$treediropen($e)} {
2889         treeclosedir $w $e
2890     } else {
2891         treeopendir $w $e
2892     }
2895 proc setfilelist {id} {
2896     global treefilelist cflist jump_to_here
2898     treeview $cflist $treefilelist($id) 0
2899     if {$jump_to_here ne {}} {
2900         set f [lindex $jump_to_here 0]
2901         if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2902             showfile $f
2903         }
2904     }
2907 image create bitmap tri-rt -background black -foreground blue -data {
2908     #define tri-rt_width 13
2909     #define tri-rt_height 13
2910     static unsigned char tri-rt_bits[] = {
2911        0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2912        0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2913        0x00, 0x00};
2914 } -maskdata {
2915     #define tri-rt-mask_width 13
2916     #define tri-rt-mask_height 13
2917     static unsigned char tri-rt-mask_bits[] = {
2918        0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2919        0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2920        0x08, 0x00};
2922 image create bitmap tri-dn -background black -foreground blue -data {
2923     #define tri-dn_width 13
2924     #define tri-dn_height 13
2925     static unsigned char tri-dn_bits[] = {
2926        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2927        0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2928        0x00, 0x00};
2929 } -maskdata {
2930     #define tri-dn-mask_width 13
2931     #define tri-dn-mask_height 13
2932     static unsigned char tri-dn-mask_bits[] = {
2933        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2934        0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2935        0x00, 0x00};
2938 image create bitmap reficon-T -background black -foreground yellow -data {
2939     #define tagicon_width 13
2940     #define tagicon_height 9
2941     static unsigned char tagicon_bits[] = {
2942        0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2943        0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2944 } -maskdata {
2945     #define tagicon-mask_width 13
2946     #define tagicon-mask_height 9
2947     static unsigned char tagicon-mask_bits[] = {
2948        0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2949        0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2951 set rectdata {
2952     #define headicon_width 13
2953     #define headicon_height 9
2954     static unsigned char headicon_bits[] = {
2955        0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2956        0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2958 set rectmask {
2959     #define headicon-mask_width 13
2960     #define headicon-mask_height 9
2961     static unsigned char headicon-mask_bits[] = {
2962        0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2963        0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2965 image create bitmap reficon-H -background black -foreground green \
2966     -data $rectdata -maskdata $rectmask
2967 image create bitmap reficon-o -background black -foreground "#ddddff" \
2968     -data $rectdata -maskdata $rectmask
2970 proc init_flist {first} {
2971     global cflist cflist_top difffilestart
2973     $cflist conf -state normal
2974     $cflist delete 0.0 end
2975     if {$first ne {}} {
2976         $cflist insert end $first
2977         set cflist_top 1
2978         $cflist tag add highlight 1.0 "1.0 lineend"
2979     } else {
2980         catch {unset cflist_top}
2981     }
2982     $cflist conf -state disabled
2983     set difffilestart {}
2986 proc highlight_tag {f} {
2987     global highlight_paths
2989     foreach p $highlight_paths {
2990         if {[string match $p $f]} {
2991             return "bold"
2992         }
2993     }
2994     return {}
2997 proc highlight_filelist {} {
2998     global cmitmode cflist
3000     $cflist conf -state normal
3001     if {$cmitmode ne "tree"} {
3002         set end [lindex [split [$cflist index end] .] 0]
3003         for {set l 2} {$l < $end} {incr l} {
3004             set line [$cflist get $l.0 "$l.0 lineend"]
3005             if {[highlight_tag $line] ne {}} {
3006                 $cflist tag add bold $l.0 "$l.0 lineend"
3007             }
3008         }
3009     } else {
3010         highlight_tree 2 {}
3011     }
3012     $cflist conf -state disabled
3015 proc unhighlight_filelist {} {
3016     global cflist
3018     $cflist conf -state normal
3019     $cflist tag remove bold 1.0 end
3020     $cflist conf -state disabled
3023 proc add_flist {fl} {
3024     global cflist
3026     $cflist conf -state normal
3027     foreach f $fl {
3028         $cflist insert end "\n"
3029         $cflist insert end $f [highlight_tag $f]
3030     }
3031     $cflist conf -state disabled
3034 proc sel_flist {w x y} {
3035     global ctext difffilestart cflist cflist_top cmitmode
3037     if {$cmitmode eq "tree"} return
3038     if {![info exists cflist_top]} return
3039     set l [lindex [split [$w index "@$x,$y"] "."] 0]
3040     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3041     $cflist tag add highlight $l.0 "$l.0 lineend"
3042     set cflist_top $l
3043     if {$l == 1} {
3044         $ctext yview 1.0
3045     } else {
3046         catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3047     }
3050 proc pop_flist_menu {w X Y x y} {
3051     global ctext cflist cmitmode flist_menu flist_menu_file
3052     global treediffs diffids
3054     stopfinding
3055     set l [lindex [split [$w index "@$x,$y"] "."] 0]
3056     if {$l <= 1} return
3057     if {$cmitmode eq "tree"} {
3058         set e [linetoelt $l]
3059         if {[string index $e end] eq "/"} return
3060     } else {
3061         set e [lindex $treediffs($diffids) [expr {$l-2}]]
3062     }
3063     set flist_menu_file $e
3064     set xdiffstate "normal"
3065     if {$cmitmode eq "tree"} {
3066         set xdiffstate "disabled"
3067     }
3068     # Disable "External diff" item in tree mode
3069     $flist_menu entryconf 2 -state $xdiffstate
3070     tk_popup $flist_menu $X $Y
3073 proc find_ctext_fileinfo {line} {
3074     global ctext_file_names ctext_file_lines
3076     set ok [bsearch $ctext_file_lines $line]
3077     set tline [lindex $ctext_file_lines $ok]
3079     if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3080         return {}
3081     } else {
3082         return [list [lindex $ctext_file_names $ok] $tline]
3083     }
3086 proc pop_diff_menu {w X Y x y} {
3087     global ctext diff_menu flist_menu_file
3088     global diff_menu_txtpos diff_menu_line
3089     global diff_menu_filebase
3091     set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3092     set diff_menu_line [lindex $diff_menu_txtpos 0]
3093     # don't pop up the menu on hunk-separator or file-separator lines
3094     if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3095         return
3096     }
3097     stopfinding
3098     set f [find_ctext_fileinfo $diff_menu_line]
3099     if {$f eq {}} return
3100     set flist_menu_file [lindex $f 0]
3101     set diff_menu_filebase [lindex $f 1]
3102     tk_popup $diff_menu $X $Y
3105 proc flist_hl {only} {
3106     global flist_menu_file findstring gdttype
3108     set x [shellquote $flist_menu_file]
3109     if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3110         set findstring $x
3111     } else {
3112         append findstring " " $x
3113     }
3114     set gdttype [mc "touching paths:"]
3117 proc save_file_from_commit {filename output what} {
3118     global nullfile
3120     if {[catch {exec git show $filename -- > $output} err]} {
3121         if {[string match "fatal: bad revision *" $err]} {
3122             return $nullfile
3123         }
3124         error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3125         return {}
3126     }
3127     return $output
3130 proc external_diff_get_one_file {diffid filename diffdir} {
3131     global nullid nullid2 nullfile
3132     global gitdir
3134     if {$diffid == $nullid} {
3135         set difffile [file join [file dirname $gitdir] $filename]
3136         if {[file exists $difffile]} {
3137             return $difffile
3138         }
3139         return $nullfile
3140     }
3141     if {$diffid == $nullid2} {
3142         set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3143         return [save_file_from_commit :$filename $difffile index]
3144     }
3145     set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3146     return [save_file_from_commit $diffid:$filename $difffile \
3147                "revision $diffid"]
3150 proc external_diff {} {
3151     global gitktmpdir nullid nullid2
3152     global flist_menu_file
3153     global diffids
3154     global diffnum
3155     global gitdir extdifftool
3157     if {[llength $diffids] == 1} {
3158         # no reference commit given
3159         set diffidto [lindex $diffids 0]
3160         if {$diffidto eq $nullid} {
3161             # diffing working copy with index
3162             set diffidfrom $nullid2
3163         } elseif {$diffidto eq $nullid2} {
3164             # diffing index with HEAD
3165             set diffidfrom "HEAD"
3166         } else {
3167             # use first parent commit
3168             global parentlist selectedline
3169             set diffidfrom [lindex $parentlist $selectedline 0]
3170         }
3171     } else {
3172         set diffidfrom [lindex $diffids 0]
3173         set diffidto [lindex $diffids 1]
3174     }
3176     # make sure that several diffs wont collide
3177     if {![info exists gitktmpdir]} {
3178         set gitktmpdir [file join [file dirname $gitdir] \
3179                             [format ".gitk-tmp.%s" [pid]]]
3180         if {[catch {file mkdir $gitktmpdir} err]} {
3181             error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3182             unset gitktmpdir
3183             return
3184         }
3185         set diffnum 0
3186     }
3187     incr diffnum
3188     set diffdir [file join $gitktmpdir $diffnum]
3189     if {[catch {file mkdir $diffdir} err]} {
3190         error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3191         return
3192     }
3194     # gather files to diff
3195     set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3196     set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3198     if {$difffromfile ne {} && $difftofile ne {}} {
3199         set cmd [concat | [shellsplit $extdifftool] \
3200                      [list $difffromfile $difftofile]]
3201         if {[catch {set fl [open $cmd r]} err]} {
3202             file delete -force $diffdir
3203             error_popup "$extdifftool: [mc "command failed:"] $err"
3204         } else {
3205             fconfigure $fl -blocking 0
3206             filerun $fl [list delete_at_eof $fl $diffdir]
3207         }
3208     }
3211 proc find_hunk_blamespec {base line} {
3212     global ctext
3214     # Find and parse the hunk header
3215     set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3216     if {$s_lix eq {}} return
3218     set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3219     if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3220             s_line old_specs osz osz1 new_line nsz]} {
3221         return
3222     }
3224     # base lines for the parents
3225     set base_lines [list $new_line]
3226     foreach old_spec [lrange [split $old_specs " "] 1 end] {
3227         if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3228                 old_spec old_line osz]} {
3229             return
3230         }
3231         lappend base_lines $old_line
3232     }
3234     # Now scan the lines to determine offset within the hunk
3235     set max_parent [expr {[llength $base_lines]-2}]
3236     set dline 0
3237     set s_lno [lindex [split $s_lix "."] 0]
3239     # Determine if the line is removed
3240     set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3241     if {[string match {[-+ ]*} $chunk]} {
3242         set removed_idx [string first "-" $chunk]
3243         # Choose a parent index
3244         if {$removed_idx >= 0} {
3245             set parent $removed_idx
3246         } else {
3247             set unchanged_idx [string first " " $chunk]
3248             if {$unchanged_idx >= 0} {
3249                 set parent $unchanged_idx
3250             } else {
3251                 # blame the current commit
3252                 set parent -1
3253             }
3254         }
3255         # then count other lines that belong to it
3256         for {set i $line} {[incr i -1] > $s_lno} {} {
3257             set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3258             # Determine if the line is removed
3259             set removed_idx [string first "-" $chunk]
3260             if {$parent >= 0} {
3261                 set code [string index $chunk $parent]
3262                 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3263                     incr dline
3264                 }
3265             } else {
3266                 if {$removed_idx < 0} {
3267                     incr dline
3268                 }
3269             }
3270         }
3271         incr parent
3272     } else {
3273         set parent 0
3274     }
3276     incr dline [lindex $base_lines $parent]
3277     return [list $parent $dline]
3280 proc external_blame_diff {} {
3281     global currentid cmitmode
3282     global diff_menu_txtpos diff_menu_line
3283     global diff_menu_filebase flist_menu_file
3285     if {$cmitmode eq "tree"} {
3286         set parent_idx 0
3287         set line [expr {$diff_menu_line - $diff_menu_filebase}]
3288     } else {
3289         set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3290         if {$hinfo ne {}} {
3291             set parent_idx [lindex $hinfo 0]
3292             set line [lindex $hinfo 1]
3293         } else {
3294             set parent_idx 0
3295             set line 0
3296         }
3297     }
3299     external_blame $parent_idx $line
3302 # Find the SHA1 ID of the blob for file $fname in the index
3303 # at stage 0 or 2
3304 proc index_sha1 {fname} {
3305     set f [open [list | git ls-files -s $fname] r]
3306     while {[gets $f line] >= 0} {
3307         set info [lindex [split $line "\t"] 0]
3308         set stage [lindex $info 2]
3309         if {$stage eq "0" || $stage eq "2"} {
3310             close $f
3311             return [lindex $info 1]
3312         }
3313     }
3314     close $f
3315     return {}
3318 proc external_blame {parent_idx {line {}}} {
3319     global flist_menu_file
3320     global nullid nullid2
3321     global parentlist selectedline currentid
3323     if {$parent_idx > 0} {
3324         set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3325     } else {
3326         set base_commit $currentid
3327     }
3329     if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3330         error_popup [mc "No such commit"]
3331         return
3332     }
3334     set cmdline [list git gui blame]
3335     if {$line ne {} && $line > 1} {
3336         lappend cmdline "--line=$line"
3337     }
3338     lappend cmdline $base_commit $flist_menu_file
3339     if {[catch {eval exec $cmdline &} err]} {
3340         error_popup "[mc "git gui blame: command failed:"] $err"
3341     }
3344 proc show_line_source {} {
3345     global cmitmode currentid parents curview blamestuff blameinst
3346     global diff_menu_line diff_menu_filebase flist_menu_file
3347     global nullid nullid2 gitdir
3349     set from_index {}
3350     if {$cmitmode eq "tree"} {
3351         set id $currentid
3352         set line [expr {$diff_menu_line - $diff_menu_filebase}]
3353     } else {
3354         set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3355         if {$h eq {}} return
3356         set pi [lindex $h 0]
3357         if {$pi == 0} {
3358             mark_ctext_line $diff_menu_line
3359             return
3360         }
3361         incr pi -1
3362         if {$currentid eq $nullid} {
3363             if {$pi > 0} {
3364                 # must be a merge in progress...
3365                 if {[catch {
3366                     # get the last line from .git/MERGE_HEAD
3367                     set f [open [file join $gitdir MERGE_HEAD] r]
3368                     set id [lindex [split [read $f] "\n"] end-1]
3369                     close $f
3370                 } err]} {
3371                     error_popup [mc "Couldn't read merge head: %s" $err]
3372                     return
3373                 }
3374             } elseif {$parents($curview,$currentid) eq $nullid2} {
3375                 # need to do the blame from the index
3376                 if {[catch {
3377                     set from_index [index_sha1 $flist_menu_file]
3378                 } err]} {
3379                     error_popup [mc "Error reading index: %s" $err]
3380                     return
3381                 }
3382             }
3383         } else {
3384             set id [lindex $parents($curview,$currentid) $pi]
3385         }
3386         set line [lindex $h 1]
3387     }
3388     set blameargs {}
3389     if {$from_index ne {}} {
3390         lappend blameargs | git cat-file blob $from_index
3391     }
3392     lappend blameargs | git blame -p -L$line,+1
3393     if {$from_index ne {}} {
3394         lappend blameargs --contents -
3395     } else {
3396         lappend blameargs $id
3397     }
3398     lappend blameargs -- $flist_menu_file
3399     if {[catch {
3400         set f [open $blameargs r]
3401     } err]} {
3402         error_popup [mc "Couldn't start git blame: %s" $err]
3403         return
3404     }
3405     fconfigure $f -blocking 0
3406     set i [reg_instance $f]
3407     set blamestuff($i) {}
3408     set blameinst $i
3409     filerun $f [list read_line_source $f $i]
3412 proc stopblaming {} {
3413     global blameinst
3415     if {[info exists blameinst]} {
3416         stop_instance $blameinst
3417         unset blameinst
3418     }
3421 proc read_line_source {fd inst} {
3422     global blamestuff curview commfd blameinst nullid nullid2
3424     while {[gets $fd line] >= 0} {
3425         lappend blamestuff($inst) $line
3426     }
3427     if {![eof $fd]} {
3428         return 1
3429     }
3430     unset commfd($inst)
3431     unset blameinst
3432     fconfigure $fd -blocking 1
3433     if {[catch {close $fd} err]} {
3434         error_popup [mc "Error running git blame: %s" $err]
3435         return 0
3436     }
3438     set fname {}
3439     set line [split [lindex $blamestuff($inst) 0] " "]
3440     set id [lindex $line 0]
3441     set lnum [lindex $line 1]
3442     if {[string length $id] == 40 && [string is xdigit $id] &&
3443         [string is digit -strict $lnum]} {
3444         # look for "filename" line
3445         foreach l $blamestuff($inst) {
3446             if {[string match "filename *" $l]} {
3447                 set fname [string range $l 9 end]
3448                 break
3449             }
3450         }
3451     }
3452     if {$fname ne {}} {
3453         # all looks good, select it
3454         if {$id eq $nullid} {
3455             # blame uses all-zeroes to mean not committed,
3456             # which would mean a change in the index
3457             set id $nullid2
3458         }
3459         if {[commitinview $id $curview]} {
3460             selectline [rowofcommit $id] 1 [list $fname $lnum]
3461         } else {
3462             error_popup [mc "That line comes from commit %s, \
3463                              which is not in this view" [shortids $id]]
3464         }
3465     } else {
3466         puts "oops couldn't parse git blame output"
3467     }
3468     return 0
3471 # delete $dir when we see eof on $f (presumably because the child has exited)
3472 proc delete_at_eof {f dir} {
3473     while {[gets $f line] >= 0} {}
3474     if {[eof $f]} {
3475         if {[catch {close $f} err]} {
3476             error_popup "[mc "External diff viewer failed:"] $err"
3477         }
3478         file delete -force $dir
3479         return 0
3480     }
3481     return 1
3484 # Functions for adding and removing shell-type quoting
3486 proc shellquote {str} {
3487     if {![string match "*\['\"\\ \t]*" $str]} {
3488         return $str
3489     }
3490     if {![string match "*\['\"\\]*" $str]} {
3491         return "\"$str\""
3492     }
3493     if {![string match "*'*" $str]} {
3494         return "'$str'"
3495     }
3496     return "\"[string map {\" \\\" \\ \\\\} $str]\""
3499 proc shellarglist {l} {
3500     set str {}
3501     foreach a $l {
3502         if {$str ne {}} {
3503             append str " "
3504         }
3505         append str [shellquote $a]
3506     }
3507     return $str
3510 proc shelldequote {str} {
3511     set ret {}
3512     set used -1
3513     while {1} {
3514         incr used
3515         if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3516             append ret [string range $str $used end]
3517             set used [string length $str]
3518             break
3519         }
3520         set first [lindex $first 0]
3521         set ch [string index $str $first]
3522         if {$first > $used} {
3523             append ret [string range $str $used [expr {$first - 1}]]
3524             set used $first
3525         }
3526         if {$ch eq " " || $ch eq "\t"} break
3527         incr used
3528         if {$ch eq "'"} {
3529             set first [string first "'" $str $used]
3530             if {$first < 0} {
3531                 error "unmatched single-quote"
3532             }
3533             append ret [string range $str $used [expr {$first - 1}]]
3534             set used $first
3535             continue
3536         }
3537         if {$ch eq "\\"} {
3538             if {$used >= [string length $str]} {
3539                 error "trailing backslash"
3540             }
3541             append ret [string index $str $used]
3542             continue
3543         }
3544         # here ch == "\""
3545         while {1} {
3546             if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3547                 error "unmatched double-quote"
3548             }
3549             set first [lindex $first 0]
3550             set ch [string index $str $first]
3551             if {$first > $used} {
3552                 append ret [string range $str $used [expr {$first - 1}]]
3553                 set used $first
3554             }
3555             if {$ch eq "\""} break
3556             incr used
3557             append ret [string index $str $used]
3558             incr used
3559         }
3560     }
3561     return [list $used $ret]
3564 proc shellsplit {str} {
3565     set l {}
3566     while {1} {
3567         set str [string trimleft $str]
3568         if {$str eq {}} break
3569         set dq [shelldequote $str]
3570         set n [lindex $dq 0]
3571         set word [lindex $dq 1]
3572         set str [string range $str $n end]
3573         lappend l $word
3574     }
3575     return $l
3578 # Code to implement multiple views
3580 proc newview {ishighlight} {
3581     global nextviewnum newviewname newishighlight
3582     global revtreeargs viewargscmd newviewopts curview
3584     set newishighlight $ishighlight
3585     set top .gitkview
3586     if {[winfo exists $top]} {
3587         raise $top
3588         return
3589     }
3590     set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3591     set newviewopts($nextviewnum,perm) 0
3592     set newviewopts($nextviewnum,cmd)  $viewargscmd($curview)
3593     decode_view_opts $nextviewnum $revtreeargs
3594     vieweditor $top $nextviewnum [mc "Gitk view definition"]
3597 set known_view_options {
3598     {perm    b    . {}               {mc "Remember this view"}}
3599     {args    t50= + {}               {mc "Commits to include (arguments to git log):"}}
3600     {all     b    * "--all"          {mc "Use all refs"}}
3601     {dorder  b    . {"--date-order" "-d"}      {mc "Strictly sort by date"}}
3602     {lright  b    . "--left-right"   {mc "Mark branch sides"}}
3603     {since   t15  + {"--since=*" "--after=*"}  {mc "Since date:"}}
3604     {until   t15  . {"--until=*" "--before=*"} {mc "Until date:"}}
3605     {limit   t10  + "--max-count=*"  {mc "Max count:"}}
3606     {skip    t10  . "--skip=*"       {mc "Skip:"}}
3607     {first   b    . "--first-parent" {mc "Limit to first parent"}}
3608     {cmd     t50= + {}               {mc "Command to generate more commits to include:"}}
3609     }
3611 proc encode_view_opts {n} {
3612     global known_view_options newviewopts
3614     set rargs [list]
3615     foreach opt $known_view_options {
3616         set patterns [lindex $opt 3]
3617         if {$patterns eq {}} continue
3618         set pattern [lindex $patterns 0]
3620         set val $newviewopts($n,[lindex $opt 0])
3621         
3622         if {[lindex $opt 1] eq "b"} {
3623             if {$val} {
3624                 lappend rargs $pattern
3625             }
3626         } else {
3627             set val [string trim $val]
3628             if {$val ne {}} {
3629                 set pfix [string range $pattern 0 end-1]
3630                 lappend rargs $pfix$val
3631             }
3632         }
3633     }
3634     return [concat $rargs [shellsplit $newviewopts($n,args)]]
3637 proc decode_view_opts {n view_args} {
3638     global known_view_options newviewopts
3640     foreach opt $known_view_options {
3641         if {[lindex $opt 1] eq "b"} {
3642             set val 0
3643         } else {
3644             set val {}
3645         }
3646         set newviewopts($n,[lindex $opt 0]) $val
3647     }
3648     set oargs [list]
3649     foreach arg $view_args {
3650         if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3651             && ![info exists found(limit)]} {
3652             set newviewopts($n,limit) $cnt
3653             set found(limit) 1
3654             continue
3655         }
3656         catch { unset val }
3657         foreach opt $known_view_options {
3658             set id [lindex $opt 0]
3659             if {[info exists found($id)]} continue
3660             foreach pattern [lindex $opt 3] {
3661                 if {![string match $pattern $arg]} continue
3662                 if {[lindex $opt 1] ne "b"} {
3663                     set size [string length $pattern]
3664                     set val [string range $arg [expr {$size-1}] end]
3665                 } else {
3666                     set val 1
3667                 }
3668                 set newviewopts($n,$id) $val
3669                 set found($id) 1
3670                 break
3671             }
3672             if {[info exists val]} break
3673         }
3674         if {[info exists val]} continue
3675         lappend oargs $arg
3676     }
3677     set newviewopts($n,args) [shellarglist $oargs]
3680 proc edit_or_newview {} {
3681     global curview
3683     if {$curview > 0} {
3684         editview
3685     } else {
3686         newview 0
3687     }
3690 proc editview {} {
3691     global curview
3692     global viewname viewperm newviewname newviewopts
3693     global viewargs viewargscmd
3695     set top .gitkvedit-$curview
3696     if {[winfo exists $top]} {
3697         raise $top
3698         return
3699     }
3700     set newviewname($curview)      $viewname($curview)
3701     set newviewopts($curview,perm) $viewperm($curview)
3702     set newviewopts($curview,cmd)  $viewargscmd($curview)
3703     decode_view_opts $curview $viewargs($curview)
3704     vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3707 proc vieweditor {top n title} {
3708     global newviewname newviewopts viewfiles bgcolor
3709     global known_view_options
3711     toplevel $top
3712     wm title $top $title
3713     make_transient $top .
3715     # View name
3716     frame $top.nfr
3717     label $top.nl -text [mc "Name"]
3718     entry $top.name -width 20 -textvariable newviewname($n)
3719     pack $top.nfr -in $top -fill x -pady 5 -padx 3
3720     pack $top.nl -in $top.nfr -side left -padx {0 30}
3721     pack $top.name -in $top.nfr -side left
3723     # View options
3724     set cframe $top.nfr
3725     set cexpand 0
3726     set cnt 0
3727     foreach opt $known_view_options {
3728         set id [lindex $opt 0]
3729         set type [lindex $opt 1]
3730         set flags [lindex $opt 2]
3731         set title [eval [lindex $opt 4]]
3732         set lxpad 0
3734         if {$flags eq "+" || $flags eq "*"} {
3735             set cframe $top.fr$cnt
3736             incr cnt
3737             frame $cframe
3738             pack $cframe -in $top -fill x -pady 3 -padx 3
3739             set cexpand [expr {$flags eq "*"}]
3740         } else {
3741             set lxpad 5
3742         }
3744         if {$type eq "b"} {
3745             checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3746             pack $cframe.c_$id -in $cframe -side left \
3747                 -padx [list $lxpad 0] -expand $cexpand -anchor w
3748         } elseif {[regexp {^t(\d+)$} $type type sz]} {
3749             message $cframe.l_$id -aspect 1500 -text $title
3750             entry $cframe.e_$id -width $sz -background $bgcolor \
3751                 -textvariable newviewopts($n,$id)
3752             pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3753             pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3754         } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3755             message $cframe.l_$id -aspect 1500 -text $title
3756             entry $cframe.e_$id -width $sz -background $bgcolor \
3757                 -textvariable newviewopts($n,$id)
3758             pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3759             pack $cframe.e_$id -in $cframe -side top -fill x
3760         }
3761     }
3763     # Path list
3764     message $top.l -aspect 1500 \
3765         -text [mc "Enter files and directories to include, one per line:"]
3766     pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3767     text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3768     if {[info exists viewfiles($n)]} {
3769         foreach f $viewfiles($n) {
3770             $top.t insert end $f
3771             $top.t insert end "\n"
3772         }
3773         $top.t delete {end - 1c} end
3774         $top.t mark set insert 0.0
3775     }
3776     pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3777     frame $top.buts
3778     button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3779     button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3780     button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3781     bind $top <Control-Return> [list newviewok $top $n]
3782     bind $top <F5> [list newviewok $top $n 1]
3783     bind $top <Escape> [list destroy $top]
3784     grid $top.buts.ok $top.buts.apply $top.buts.can
3785     grid columnconfigure $top.buts 0 -weight 1 -uniform a
3786     grid columnconfigure $top.buts 1 -weight 1 -uniform a
3787     grid columnconfigure $top.buts 2 -weight 1 -uniform a
3788     pack $top.buts -in $top -side top -fill x
3789     focus $top.t
3792 proc doviewmenu {m first cmd op argv} {
3793     set nmenu [$m index end]
3794     for {set i $first} {$i <= $nmenu} {incr i} {
3795         if {[$m entrycget $i -command] eq $cmd} {
3796             eval $m $op $i $argv
3797             break
3798         }
3799     }
3802 proc allviewmenus {n op args} {
3803     # global viewhlmenu
3805     doviewmenu .bar.view 5 [list showview $n] $op $args
3806     # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3809 proc newviewok {top n {apply 0}} {
3810     global nextviewnum newviewperm newviewname newishighlight
3811     global viewname viewfiles viewperm selectedview curview
3812     global viewargs viewargscmd newviewopts viewhlmenu
3814     if {[catch {
3815         set newargs [encode_view_opts $n]
3816     } err]} {
3817         error_popup "[mc "Error in commit selection arguments:"] $err" $top
3818         return
3819     }
3820     set files {}
3821     foreach f [split [$top.t get 0.0 end] "\n"] {
3822         set ft [string trim $f]
3823         if {$ft ne {}} {
3824             lappend files $ft
3825         }
3826     }
3827     if {![info exists viewfiles($n)]} {
3828         # creating a new view
3829         incr nextviewnum
3830         set viewname($n) $newviewname($n)
3831         set viewperm($n) $newviewopts($n,perm)
3832         set viewfiles($n) $files
3833         set viewargs($n) $newargs
3834         set viewargscmd($n) $newviewopts($n,cmd)
3835         addviewmenu $n
3836         if {!$newishighlight} {
3837             run showview $n
3838         } else {
3839             run addvhighlight $n
3840         }
3841     } else {
3842         # editing an existing view
3843         set viewperm($n) $newviewopts($n,perm)
3844         if {$newviewname($n) ne $viewname($n)} {
3845             set viewname($n) $newviewname($n)
3846             doviewmenu .bar.view 5 [list showview $n] \
3847                 entryconf [list -label $viewname($n)]
3848             # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3849                 # entryconf [list -label $viewname($n) -value $viewname($n)]
3850         }
3851         if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3852                 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3853             set viewfiles($n) $files
3854             set viewargs($n) $newargs
3855             set viewargscmd($n) $newviewopts($n,cmd)
3856             if {$curview == $n} {
3857                 run reloadcommits
3858             }
3859         }
3860     }
3861     if {$apply} return
3862     catch {destroy $top}
3865 proc delview {} {
3866     global curview viewperm hlview selectedhlview
3868     if {$curview == 0} return
3869     if {[info exists hlview] && $hlview == $curview} {
3870         set selectedhlview [mc "None"]
3871         unset hlview
3872     }
3873     allviewmenus $curview delete
3874     set viewperm($curview) 0
3875     showview 0
3878 proc addviewmenu {n} {
3879     global viewname viewhlmenu
3881     .bar.view add radiobutton -label $viewname($n) \
3882         -command [list showview $n] -variable selectedview -value $n
3883     #$viewhlmenu add radiobutton -label $viewname($n) \
3884     #   -command [list addvhighlight $n] -variable selectedhlview
3887 proc showview {n} {
3888     global curview cached_commitrow ordertok
3889     global displayorder parentlist rowidlist rowisopt rowfinal
3890     global colormap rowtextx nextcolor canvxmax
3891     global numcommits viewcomplete
3892     global selectedline currentid canv canvy0
3893     global treediffs
3894     global pending_select mainheadid
3895     global commitidx
3896     global selectedview
3897     global hlview selectedhlview commitinterest
3899     if {$n == $curview} return
3900     set selid {}
3901     set ymax [lindex [$canv cget -scrollregion] 3]
3902     set span [$canv yview]
3903     set ytop [expr {[lindex $span 0] * $ymax}]
3904     set ybot [expr {[lindex $span 1] * $ymax}]
3905     set yscreen [expr {($ybot - $ytop) / 2}]
3906     if {$selectedline ne {}} {
3907         set selid $currentid
3908         set y [yc $selectedline]
3909         if {$ytop < $y && $y < $ybot} {
3910             set yscreen [expr {$y - $ytop}]
3911         }
3912     } elseif {[info exists pending_select]} {
3913         set selid $pending_select
3914         unset pending_select
3915     }
3916     unselectline
3917     normalline
3918     catch {unset treediffs}
3919     clear_display
3920     if {[info exists hlview] && $hlview == $n} {
3921         unset hlview
3922         set selectedhlview [mc "None"]
3923     }
3924     catch {unset commitinterest}
3925     catch {unset cached_commitrow}
3926     catch {unset ordertok}
3928     set curview $n
3929     set selectedview $n
3930     .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3931     .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3933     run refill_reflist
3934     if {![info exists viewcomplete($n)]} {
3935         getcommits $selid
3936         return
3937     }
3939     set displayorder {}
3940     set parentlist {}
3941     set rowidlist {}
3942     set rowisopt {}
3943     set rowfinal {}
3944     set numcommits $commitidx($n)
3946     catch {unset colormap}
3947     catch {unset rowtextx}
3948     set nextcolor 0
3949     set canvxmax [$canv cget -width]
3950     set curview $n
3951     set row 0
3952     setcanvscroll
3953     set yf 0
3954     set row {}
3955     if {$selid ne {} && [commitinview $selid $n]} {
3956         set row [rowofcommit $selid]
3957         # try to get the selected row in the same position on the screen
3958         set ymax [lindex [$canv cget -scrollregion] 3]
3959         set ytop [expr {[yc $row] - $yscreen}]
3960         if {$ytop < 0} {
3961             set ytop 0
3962         }
3963         set yf [expr {$ytop * 1.0 / $ymax}]
3964     }
3965     allcanvs yview moveto $yf
3966     drawvisible
3967     if {$row ne {}} {
3968         selectline $row 0
3969     } elseif {!$viewcomplete($n)} {
3970         reset_pending_select $selid
3971     } else {
3972         reset_pending_select {}
3974         if {[commitinview $pending_select $curview]} {
3975             selectline [rowofcommit $pending_select] 1
3976         } else {
3977             set row [first_real_row]
3978             if {$row < $numcommits} {
3979                 selectline $row 0
3980             }
3981         }
3982     }
3983     if {!$viewcomplete($n)} {
3984         if {$numcommits == 0} {
3985             show_status [mc "Reading commits..."]
3986         }
3987     } elseif {$numcommits == 0} {
3988         show_status [mc "No commits selected"]
3989     }
3992 # Stuff relating to the highlighting facility
3994 proc ishighlighted {id} {
3995     global vhighlights fhighlights nhighlights rhighlights
3997     if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
3998         return $nhighlights($id)
3999     }
4000     if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4001         return $vhighlights($id)
4002     }
4003     if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4004         return $fhighlights($id)
4005     }
4006     if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4007         return $rhighlights($id)
4008     }
4009     return 0
4012 proc bolden {id font} {
4013     global canv linehtag currentid boldids need_redisplay
4015     # need_redisplay = 1 means the display is stale and about to be redrawn
4016     if {$need_redisplay} return
4017     lappend boldids $id
4018     $canv itemconf $linehtag($id) -font $font
4019     if {[info exists currentid] && $id eq $currentid} {
4020         $canv delete secsel
4021         set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4022                    -outline {{}} -tags secsel \
4023                    -fill [$canv cget -selectbackground]]
4024         $canv lower $t
4025     }
4028 proc bolden_name {id font} {
4029     global canv2 linentag currentid boldnameids need_redisplay
4031     if {$need_redisplay} return
4032     lappend boldnameids $id
4033     $canv2 itemconf $linentag($id) -font $font
4034     if {[info exists currentid] && $id eq $currentid} {
4035         $canv2 delete secsel
4036         set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4037                    -outline {{}} -tags secsel \
4038                    -fill [$canv2 cget -selectbackground]]
4039         $canv2 lower $t
4040     }
4043 proc unbolden {} {
4044     global boldids
4046     set stillbold {}
4047     foreach id $boldids {
4048         if {![ishighlighted $id]} {
4049             bolden $id mainfont
4050         } else {
4051             lappend stillbold $id
4052         }
4053     }
4054     set boldids $stillbold
4057 proc addvhighlight {n} {
4058     global hlview viewcomplete curview vhl_done commitidx
4060     if {[info exists hlview]} {
4061         delvhighlight
4062     }
4063     set hlview $n
4064     if {$n != $curview && ![info exists viewcomplete($n)]} {
4065         start_rev_list $n
4066     }
4067     set vhl_done $commitidx($hlview)
4068     if {$vhl_done > 0} {
4069         drawvisible
4070     }
4073 proc delvhighlight {} {
4074     global hlview vhighlights
4076     if {![info exists hlview]} return
4077     unset hlview
4078     catch {unset vhighlights}
4079     unbolden
4082 proc vhighlightmore {} {
4083     global hlview vhl_done commitidx vhighlights curview
4085     set max $commitidx($hlview)
4086     set vr [visiblerows]
4087     set r0 [lindex $vr 0]
4088     set r1 [lindex $vr 1]
4089     for {set i $vhl_done} {$i < $max} {incr i} {
4090         set id [commitonrow $i $hlview]
4091         if {[commitinview $id $curview]} {
4092             set row [rowofcommit $id]
4093             if {$r0 <= $row && $row <= $r1} {
4094                 if {![highlighted $row]} {
4095                     bolden $id mainfontbold
4096                 }
4097                 set vhighlights($id) 1
4098             }
4099         }
4100     }
4101     set vhl_done $max
4102     return 0
4105 proc askvhighlight {row id} {
4106     global hlview vhighlights iddrawn
4108     if {[commitinview $id $hlview]} {
4109         if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4110             bolden $id mainfontbold
4111         }
4112         set vhighlights($id) 1
4113     } else {
4114         set vhighlights($id) 0
4115     }
4118 proc hfiles_change {} {
4119     global highlight_files filehighlight fhighlights fh_serial
4120     global highlight_paths
4122     if {[info exists filehighlight]} {
4123         # delete previous highlights
4124         catch {close $filehighlight}
4125         unset filehighlight
4126         catch {unset fhighlights}
4127         unbolden
4128         unhighlight_filelist
4129     }
4130     set highlight_paths {}
4131     after cancel do_file_hl $fh_serial
4132     incr fh_serial
4133     if {$highlight_files ne {}} {
4134         after 300 do_file_hl $fh_serial
4135     }
4138 proc gdttype_change {name ix op} {
4139     global gdttype highlight_files findstring findpattern
4141     stopfinding
4142     if {$findstring ne {}} {
4143         if {$gdttype eq [mc "containing:"]} {
4144             if {$highlight_files ne {}} {
4145                 set highlight_files {}
4146                 hfiles_change
4147             }
4148             findcom_change
4149         } else {
4150             if {$findpattern ne {}} {
4151                 set findpattern {}
4152                 findcom_change
4153             }
4154             set highlight_files $findstring
4155             hfiles_change
4156         }
4157         drawvisible
4158     }
4159     # enable/disable findtype/findloc menus too
4162 proc find_change {name ix op} {
4163     global gdttype findstring highlight_files
4165     stopfinding
4166     if {$gdttype eq [mc "containing:"]} {
4167         findcom_change
4168     } else {
4169         if {$highlight_files ne $findstring} {
4170             set highlight_files $findstring
4171             hfiles_change
4172         }
4173     }
4174     drawvisible
4177 proc findcom_change args {
4178     global nhighlights boldnameids
4179     global findpattern findtype findstring gdttype
4181     stopfinding
4182     # delete previous highlights, if any
4183     foreach id $boldnameids {
4184         bolden_name $id mainfont
4185     }
4186     set boldnameids {}
4187     catch {unset nhighlights}
4188     unbolden
4189     unmarkmatches
4190     if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4191         set findpattern {}
4192     } elseif {$findtype eq [mc "Regexp"]} {
4193         set findpattern $findstring
4194     } else {
4195         set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4196                    $findstring]
4197         set findpattern "*$e*"
4198     }
4201 proc makepatterns {l} {
4202     set ret {}
4203     foreach e $l {
4204         set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4205         if {[string index $ee end] eq "/"} {
4206             lappend ret "$ee*"
4207         } else {
4208             lappend ret $ee
4209             lappend ret "$ee/*"
4210         }
4211     }
4212     return $ret
4215 proc do_file_hl {serial} {
4216     global highlight_files filehighlight highlight_paths gdttype fhl_list
4218     if {$gdttype eq [mc "touching paths:"]} {
4219         if {[catch {set paths [shellsplit $highlight_files]}]} return
4220         set highlight_paths [makepatterns $paths]
4221         highlight_filelist
4222         set gdtargs [concat -- $paths]
4223     } elseif {$gdttype eq [mc "adding/removing string:"]} {
4224         set gdtargs [list "-S$highlight_files"]
4225     } else {
4226         # must be "containing:", i.e. we're searching commit info
4227         return
4228     }
4229     set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4230     set filehighlight [open $cmd r+]
4231     fconfigure $filehighlight -blocking 0
4232     filerun $filehighlight readfhighlight
4233     set fhl_list {}
4234     drawvisible
4235     flushhighlights
4238 proc flushhighlights {} {
4239     global filehighlight fhl_list
4241     if {[info exists filehighlight]} {
4242         lappend fhl_list {}
4243         puts $filehighlight ""
4244         flush $filehighlight
4245     }
4248 proc askfilehighlight {row id} {
4249     global filehighlight fhighlights fhl_list
4251     lappend fhl_list $id
4252     set fhighlights($id) -1
4253     puts $filehighlight $id
4256 proc readfhighlight {} {
4257     global filehighlight fhighlights curview iddrawn
4258     global fhl_list find_dirn
4260     if {![info exists filehighlight]} {
4261         return 0
4262     }
4263     set nr 0
4264     while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4265         set line [string trim $line]
4266         set i [lsearch -exact $fhl_list $line]
4267         if {$i < 0} continue
4268         for {set j 0} {$j < $i} {incr j} {
4269             set id [lindex $fhl_list $j]
4270             set fhighlights($id) 0
4271         }
4272         set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4273         if {$line eq {}} continue
4274         if {![commitinview $line $curview]} continue
4275         if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4276             bolden $line mainfontbold
4277         }
4278         set fhighlights($line) 1
4279     }
4280     if {[eof $filehighlight]} {
4281         # strange...
4282         puts "oops, git diff-tree died"
4283         catch {close $filehighlight}
4284         unset filehighlight
4285         return 0
4286     }
4287     if {[info exists find_dirn]} {
4288         run findmore
4289     }
4290     return 1
4293 proc doesmatch {f} {
4294     global findtype findpattern
4296     if {$findtype eq [mc "Regexp"]} {
4297         return [regexp $findpattern $f]
4298     } elseif {$findtype eq [mc "IgnCase"]} {
4299         return [string match -nocase $findpattern $f]
4300     } else {
4301         return [string match $findpattern $f]
4302     }
4305 proc askfindhighlight {row id} {
4306     global nhighlights commitinfo iddrawn
4307     global findloc
4308     global markingmatches
4310     if {![info exists commitinfo($id)]} {
4311         getcommit $id
4312     }
4313     set info $commitinfo($id)
4314     set isbold 0
4315     set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4316     foreach f $info ty $fldtypes {
4317         if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4318             [doesmatch $f]} {
4319             if {$ty eq [mc "Author"]} {
4320                 set isbold 2
4321                 break
4322             }
4323             set isbold 1
4324         }
4325     }
4326     if {$isbold && [info exists iddrawn($id)]} {
4327         if {![ishighlighted $id]} {
4328             bolden $id mainfontbold
4329             if {$isbold > 1} {
4330                 bolden_name $id mainfontbold
4331             }
4332         }
4333         if {$markingmatches} {
4334             markrowmatches $row $id
4335         }
4336     }
4337     set nhighlights($id) $isbold
4340 proc markrowmatches {row id} {
4341     global canv canv2 linehtag linentag commitinfo findloc
4343     set headline [lindex $commitinfo($id) 0]
4344     set author [lindex $commitinfo($id) 1]
4345     $canv delete match$row
4346     $canv2 delete match$row
4347     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4348         set m [findmatches $headline]
4349         if {$m ne {}} {
4350             markmatches $canv $row $headline $linehtag($id) $m \
4351                 [$canv itemcget $linehtag($id) -font] $row
4352         }
4353     }
4354     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4355         set m [findmatches $author]
4356         if {$m ne {}} {
4357             markmatches $canv2 $row $author $linentag($id) $m \
4358                 [$canv2 itemcget $linentag($id) -font] $row
4359         }
4360     }
4363 proc vrel_change {name ix op} {
4364     global highlight_related
4366     rhighlight_none
4367     if {$highlight_related ne [mc "None"]} {
4368         run drawvisible
4369     }
4372 # prepare for testing whether commits are descendents or ancestors of a
4373 proc rhighlight_sel {a} {
4374     global descendent desc_todo ancestor anc_todo
4375     global highlight_related
4377     catch {unset descendent}
4378     set desc_todo [list $a]
4379     catch {unset ancestor}
4380     set anc_todo [list $a]
4381     if {$highlight_related ne [mc "None"]} {
4382         rhighlight_none
4383         run drawvisible
4384     }
4387 proc rhighlight_none {} {
4388     global rhighlights
4390     catch {unset rhighlights}
4391     unbolden
4394 proc is_descendent {a} {
4395     global curview children descendent desc_todo
4397     set v $curview
4398     set la [rowofcommit $a]
4399     set todo $desc_todo
4400     set leftover {}
4401     set done 0
4402     for {set i 0} {$i < [llength $todo]} {incr i} {
4403         set do [lindex $todo $i]
4404         if {[rowofcommit $do] < $la} {
4405             lappend leftover $do
4406             continue
4407         }
4408         foreach nk $children($v,$do) {
4409             if {![info exists descendent($nk)]} {
4410                 set descendent($nk) 1
4411                 lappend todo $nk
4412                 if {$nk eq $a} {
4413                     set done 1
4414                 }
4415             }
4416         }
4417         if {$done} {
4418             set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4419             return
4420         }
4421     }
4422     set descendent($a) 0
4423     set desc_todo $leftover
4426 proc is_ancestor {a} {
4427     global curview parents ancestor anc_todo
4429     set v $curview
4430     set la [rowofcommit $a]
4431     set todo $anc_todo
4432     set leftover {}
4433     set done 0
4434     for {set i 0} {$i < [llength $todo]} {incr i} {
4435         set do [lindex $todo $i]
4436         if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4437             lappend leftover $do
4438             continue
4439         }
4440         foreach np $parents($v,$do) {
4441             if {![info exists ancestor($np)]} {
4442                 set ancestor($np) 1
4443                 lappend todo $np
4444                 if {$np eq $a} {
4445                     set done 1
4446                 }
4447             }
4448         }
4449         if {$done} {
4450             set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4451             return
4452         }
4453     }
4454     set ancestor($a) 0
4455     set anc_todo $leftover
4458 proc askrelhighlight {row id} {
4459     global descendent highlight_related iddrawn rhighlights
4460     global selectedline ancestor
4462     if {$selectedline eq {}} return
4463     set isbold 0
4464     if {$highlight_related eq [mc "Descendant"] ||
4465         $highlight_related eq [mc "Not descendant"]} {
4466         if {![info exists descendent($id)]} {
4467             is_descendent $id
4468         }
4469         if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4470             set isbold 1
4471         }
4472     } elseif {$highlight_related eq [mc "Ancestor"] ||
4473               $highlight_related eq [mc "Not ancestor"]} {
4474         if {![info exists ancestor($id)]} {
4475             is_ancestor $id
4476         }
4477         if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4478             set isbold 1
4479         }
4480     }
4481     if {[info exists iddrawn($id)]} {
4482         if {$isbold && ![ishighlighted $id]} {
4483             bolden $id mainfontbold
4484         }
4485     }
4486     set rhighlights($id) $isbold
4489 # Graph layout functions
4491 proc shortids {ids} {
4492     set res {}
4493     foreach id $ids {
4494         if {[llength $id] > 1} {
4495             lappend res [shortids $id]
4496         } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4497             lappend res [string range $id 0 7]
4498         } else {
4499             lappend res $id
4500         }
4501     }
4502     return $res
4505 proc ntimes {n o} {
4506     set ret {}
4507     set o [list $o]
4508     for {set mask 1} {$mask <= $n} {incr mask $mask} {
4509         if {($n & $mask) != 0} {
4510             set ret [concat $ret $o]
4511         }
4512         set o [concat $o $o]
4513     }
4514     return $ret
4517 proc ordertoken {id} {
4518     global ordertok curview varcid varcstart varctok curview parents children
4519     global nullid nullid2
4521     if {[info exists ordertok($id)]} {
4522         return $ordertok($id)
4523     }
4524     set origid $id
4525     set todo {}
4526     while {1} {
4527         if {[info exists varcid($curview,$id)]} {
4528             set a $varcid($curview,$id)
4529             set p [lindex $varcstart($curview) $a]
4530         } else {
4531             set p [lindex $children($curview,$id) 0]
4532         }
4533         if {[info exists ordertok($p)]} {
4534             set tok $ordertok($p)
4535             break
4536         }
4537         set id [first_real_child $curview,$p]
4538         if {$id eq {}} {
4539             # it's a root
4540             set tok [lindex $varctok($curview) $varcid($curview,$p)]
4541             break
4542         }
4543         if {[llength $parents($curview,$id)] == 1} {
4544             lappend todo [list $p {}]
4545         } else {
4546             set j [lsearch -exact $parents($curview,$id) $p]
4547             if {$j < 0} {
4548                 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4549             }
4550             lappend todo [list $p [strrep $j]]
4551         }
4552     }
4553     for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4554         set p [lindex $todo $i 0]
4555         append tok [lindex $todo $i 1]
4556         set ordertok($p) $tok
4557     }
4558     set ordertok($origid) $tok
4559     return $tok
4562 # Work out where id should go in idlist so that order-token
4563 # values increase from left to right
4564 proc idcol {idlist id {i 0}} {
4565     set t [ordertoken $id]
4566     if {$i < 0} {
4567         set i 0
4568     }
4569     if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4570         if {$i > [llength $idlist]} {
4571             set i [llength $idlist]
4572         }
4573         while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4574         incr i
4575     } else {
4576         if {$t > [ordertoken [lindex $idlist $i]]} {
4577             while {[incr i] < [llength $idlist] &&
4578                    $t >= [ordertoken [lindex $idlist $i]]} {}
4579         }
4580     }
4581     return $i
4584 proc initlayout {} {
4585     global rowidlist rowisopt rowfinal displayorder parentlist
4586     global numcommits canvxmax canv
4587     global nextcolor
4588     global colormap rowtextx
4590     set numcommits 0
4591     set displayorder {}
4592     set parentlist {}
4593     set nextcolor 0
4594     set rowidlist {}
4595     set rowisopt {}
4596     set rowfinal {}
4597     set canvxmax [$canv cget -width]
4598     catch {unset colormap}
4599     catch {unset rowtextx}
4600     setcanvscroll
4603 proc setcanvscroll {} {
4604     global canv canv2 canv3 numcommits linespc canvxmax canvy0
4605     global lastscrollset lastscrollrows
4607     set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4608     $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4609     $canv2 conf -scrollregion [list 0 0 0 $ymax]
4610     $canv3 conf -scrollregion [list 0 0 0 $ymax]
4611     set lastscrollset [clock clicks -milliseconds]
4612     set lastscrollrows $numcommits
4615 proc visiblerows {} {
4616     global canv numcommits linespc
4618     set ymax [lindex [$canv cget -scrollregion] 3]
4619     if {$ymax eq {} || $ymax == 0} return
4620     set f [$canv yview]
4621     set y0 [expr {int([lindex $f 0] * $ymax)}]
4622     set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4623     if {$r0 < 0} {
4624         set r0 0
4625     }
4626     set y1 [expr {int([lindex $f 1] * $ymax)}]
4627     set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4628     if {$r1 >= $numcommits} {
4629         set r1 [expr {$numcommits - 1}]
4630     }
4631     return [list $r0 $r1]
4634 proc layoutmore {} {
4635     global commitidx viewcomplete curview
4636     global numcommits pending_select curview
4637     global lastscrollset lastscrollrows
4639     if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4640         [clock clicks -milliseconds] - $lastscrollset > 500} {
4641         setcanvscroll
4642     }
4643     if {[info exists pending_select] &&
4644         [commitinview $pending_select $curview]} {
4645         update
4646         selectline [rowofcommit $pending_select] 1
4647     }
4648     drawvisible
4651 # With path limiting, we mightn't get the actual HEAD commit,
4652 # so ask git rev-list what is the first ancestor of HEAD that
4653 # touches a file in the path limit.
4654 proc get_viewmainhead {view} {
4655     global viewmainheadid vfilelimit viewinstances mainheadid
4657     catch {
4658         set rfd [open [concat | git rev-list -1 $mainheadid \
4659                            -- $vfilelimit($view)] r]
4660         set j [reg_instance $rfd]
4661         lappend viewinstances($view) $j
4662         fconfigure $rfd -blocking 0
4663         filerun $rfd [list getviewhead $rfd $j $view]
4664         set viewmainheadid($curview) {}
4665     }
4668 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4669 proc getviewhead {fd inst view} {
4670     global viewmainheadid commfd curview viewinstances showlocalchanges
4672     set id {}
4673     if {[gets $fd line] < 0} {
4674         if {![eof $fd]} {
4675             return 1
4676         }
4677     } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4678         set id $line
4679     }
4680     set viewmainheadid($view) $id
4681     close $fd
4682     unset commfd($inst)
4683     set i [lsearch -exact $viewinstances($view) $inst]
4684     if {$i >= 0} {
4685         set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4686     }
4687     if {$showlocalchanges && $id ne {} && $view == $curview} {
4688         doshowlocalchanges
4689     }
4690     return 0
4693 proc doshowlocalchanges {} {
4694     global curview viewmainheadid
4696     if {$viewmainheadid($curview) eq {}} return
4697     if {[commitinview $viewmainheadid($curview) $curview]} {
4698         dodiffindex
4699     } else {
4700         interestedin $viewmainheadid($curview) dodiffindex
4701     }
4704 proc dohidelocalchanges {} {
4705     global nullid nullid2 lserial curview
4707     if {[commitinview $nullid $curview]} {
4708         removefakerow $nullid
4709     }
4710     if {[commitinview $nullid2 $curview]} {
4711         removefakerow $nullid2
4712     }
4713     incr lserial
4716 # spawn off a process to do git diff-index --cached HEAD
4717 proc dodiffindex {} {
4718     global lserial showlocalchanges vfilelimit curview
4719     global isworktree
4721     if {!$showlocalchanges || !$isworktree} return
4722     incr lserial
4723     set cmd "|git diff-index --cached HEAD"
4724     if {$vfilelimit($curview) ne {}} {
4725         set cmd [concat $cmd -- $vfilelimit($curview)]
4726     }
4727     set fd [open $cmd r]
4728     fconfigure $fd -blocking 0
4729     set i [reg_instance $fd]
4730     filerun $fd [list readdiffindex $fd $lserial $i]
4733 proc readdiffindex {fd serial inst} {
4734     global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4735     global vfilelimit
4737     set isdiff 1
4738     if {[gets $fd line] < 0} {
4739         if {![eof $fd]} {
4740             return 1
4741         }
4742         set isdiff 0
4743     }
4744     # we only need to see one line and we don't really care what it says...
4745     stop_instance $inst
4747     if {$serial != $lserial} {
4748         return 0
4749     }
4751     # now see if there are any local changes not checked in to the index
4752     set cmd "|git diff-files"
4753     if {$vfilelimit($curview) ne {}} {
4754         set cmd [concat $cmd -- $vfilelimit($curview)]
4755     }
4756     set fd [open $cmd r]
4757     fconfigure $fd -blocking 0
4758     set i [reg_instance $fd]
4759     filerun $fd [list readdifffiles $fd $serial $i]
4761     if {$isdiff && ![commitinview $nullid2 $curview]} {
4762         # add the line for the changes in the index to the graph
4763         set hl [mc "Local changes checked in to index but not committed"]
4764         set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
4765         set commitdata($nullid2) "\n    $hl\n"
4766         if {[commitinview $nullid $curview]} {
4767             removefakerow $nullid
4768         }
4769         insertfakerow $nullid2 $viewmainheadid($curview)
4770     } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4771         if {[commitinview $nullid $curview]} {
4772             removefakerow $nullid
4773         }
4774         removefakerow $nullid2
4775     }
4776     return 0
4779 proc readdifffiles {fd serial inst} {
4780     global viewmainheadid nullid nullid2 curview
4781     global commitinfo commitdata lserial
4783     set isdiff 1
4784     if {[gets $fd line] < 0} {
4785         if {![eof $fd]} {
4786             return 1
4787         }
4788         set isdiff 0
4789     }
4790     # we only need to see one line and we don't really care what it says...
4791     stop_instance $inst
4793     if {$serial != $lserial} {
4794         return 0
4795     }
4797     if {$isdiff && ![commitinview $nullid $curview]} {
4798         # add the line for the local diff to the graph
4799         set hl [mc "Local uncommitted changes, not checked in to index"]
4800         set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
4801         set commitdata($nullid) "\n    $hl\n"
4802         if {[commitinview $nullid2 $curview]} {
4803             set p $nullid2
4804         } else {
4805             set p $viewmainheadid($curview)
4806         }
4807         insertfakerow $nullid $p
4808     } elseif {!$isdiff && [commitinview $nullid $curview]} {
4809         removefakerow $nullid
4810     }
4811     return 0
4814 proc nextuse {id row} {
4815     global curview children
4817     if {[info exists children($curview,$id)]} {
4818         foreach kid $children($curview,$id) {
4819             if {![commitinview $kid $curview]} {
4820                 return -1
4821             }
4822             if {[rowofcommit $kid] > $row} {
4823                 return [rowofcommit $kid]
4824             }
4825         }
4826     }
4827     if {[commitinview $id $curview]} {
4828         return [rowofcommit $id]
4829     }
4830     return -1
4833 proc prevuse {id row} {
4834     global curview children
4836     set ret -1
4837     if {[info exists children($curview,$id)]} {
4838         foreach kid $children($curview,$id) {
4839             if {![commitinview $kid $curview]} break
4840             if {[rowofcommit $kid] < $row} {
4841                 set ret [rowofcommit $kid]
4842             }
4843         }
4844     }
4845     return $ret
4848 proc make_idlist {row} {
4849     global displayorder parentlist uparrowlen downarrowlen mingaplen
4850     global commitidx curview children
4852     set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4853     if {$r < 0} {
4854         set r 0
4855     }
4856     set ra [expr {$row - $downarrowlen}]
4857     if {$ra < 0} {
4858         set ra 0
4859     }
4860     set rb [expr {$row + $uparrowlen}]
4861     if {$rb > $commitidx($curview)} {
4862         set rb $commitidx($curview)
4863     }
4864     make_disporder $r [expr {$rb + 1}]
4865     set ids {}
4866     for {} {$r < $ra} {incr r} {
4867         set nextid [lindex $displayorder [expr {$r + 1}]]
4868         foreach p [lindex $parentlist $r] {
4869             if {$p eq $nextid} continue
4870             set rn [nextuse $p $r]
4871             if {$rn >= $row &&
4872                 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4873                 lappend ids [list [ordertoken $p] $p]
4874             }
4875         }
4876     }
4877     for {} {$r < $row} {incr r} {
4878         set nextid [lindex $displayorder [expr {$r + 1}]]
4879         foreach p [lindex $parentlist $r] {
4880             if {$p eq $nextid} continue
4881             set rn [nextuse $p $r]
4882             if {$rn < 0 || $rn >= $row} {
4883                 lappend ids [list [ordertoken $p] $p]
4884             }
4885         }
4886     }
4887     set id [lindex $displayorder $row]
4888     lappend ids [list [ordertoken $id] $id]
4889     while {$r < $rb} {
4890         foreach p [lindex $parentlist $r] {
4891             set firstkid [lindex $children($curview,$p) 0]
4892             if {[rowofcommit $firstkid] < $row} {
4893                 lappend ids [list [ordertoken $p] $p]
4894             }
4895         }
4896         incr r
4897         set id [lindex $displayorder $r]
4898         if {$id ne {}} {
4899             set firstkid [lindex $children($curview,$id) 0]
4900             if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4901                 lappend ids [list [ordertoken $id] $id]
4902             }
4903         }
4904     }
4905     set idlist {}
4906     foreach idx [lsort -unique $ids] {
4907         lappend idlist [lindex $idx 1]
4908     }
4909     return $idlist
4912 proc rowsequal {a b} {
4913     while {[set i [lsearch -exact $a {}]] >= 0} {
4914         set a [lreplace $a $i $i]
4915     }
4916     while {[set i [lsearch -exact $b {}]] >= 0} {
4917         set b [lreplace $b $i $i]
4918     }
4919     return [expr {$a eq $b}]
4922 proc makeupline {id row rend col} {
4923     global rowidlist uparrowlen downarrowlen mingaplen
4925     for {set r $rend} {1} {set r $rstart} {
4926         set rstart [prevuse $id $r]
4927         if {$rstart < 0} return
4928         if {$rstart < $row} break
4929     }
4930     if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4931         set rstart [expr {$rend - $uparrowlen - 1}]
4932     }
4933     for {set r $rstart} {[incr r] <= $row} {} {
4934         set idlist [lindex $rowidlist $r]
4935         if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4936             set col [idcol $idlist $id $col]
4937             lset rowidlist $r [linsert $idlist $col $id]
4938             changedrow $r
4939         }
4940     }
4943 proc layoutrows {row endrow} {
4944     global rowidlist rowisopt rowfinal displayorder
4945     global uparrowlen downarrowlen maxwidth mingaplen
4946     global children parentlist
4947     global commitidx viewcomplete curview
4949     make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4950     set idlist {}
4951     if {$row > 0} {
4952         set rm1 [expr {$row - 1}]
4953         foreach id [lindex $rowidlist $rm1] {
4954             if {$id ne {}} {
4955                 lappend idlist $id
4956             }
4957         }
4958         set final [lindex $rowfinal $rm1]
4959     }
4960     for {} {$row < $endrow} {incr row} {
4961         set rm1 [expr {$row - 1}]
4962         if {$rm1 < 0 || $idlist eq {}} {
4963             set idlist [make_idlist $row]
4964             set final 1
4965         } else {
4966             set id [lindex $displayorder $rm1]
4967             set col [lsearch -exact $idlist $id]
4968             set idlist [lreplace $idlist $col $col]
4969             foreach p [lindex $parentlist $rm1] {
4970                 if {[lsearch -exact $idlist $p] < 0} {
4971                     set col [idcol $idlist $p $col]
4972                     set idlist [linsert $idlist $col $p]
4973                     # if not the first child, we have to insert a line going up
4974                     if {$id ne [lindex $children($curview,$p) 0]} {
4975                         makeupline $p $rm1 $row $col
4976                     }
4977                 }
4978             }
4979             set id [lindex $displayorder $row]
4980             if {$row > $downarrowlen} {
4981                 set termrow [expr {$row - $downarrowlen - 1}]
4982                 foreach p [lindex $parentlist $termrow] {
4983                     set i [lsearch -exact $idlist $p]
4984                     if {$i < 0} continue
4985                     set nr [nextuse $p $termrow]
4986                     if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4987                         set idlist [lreplace $idlist $i $i]
4988                     }
4989                 }
4990             }
4991             set col [lsearch -exact $idlist $id]
4992             if {$col < 0} {
4993                 set col [idcol $idlist $id]
4994                 set idlist [linsert $idlist $col $id]
4995                 if {$children($curview,$id) ne {}} {
4996                     makeupline $id $rm1 $row $col
4997                 }
4998             }
4999             set r [expr {$row + $uparrowlen - 1}]
5000             if {$r < $commitidx($curview)} {
5001                 set x $col
5002                 foreach p [lindex $parentlist $r] {
5003                     if {[lsearch -exact $idlist $p] >= 0} continue
5004                     set fk [lindex $children($curview,$p) 0]
5005                     if {[rowofcommit $fk] < $row} {
5006                         set x [idcol $idlist $p $x]
5007                         set idlist [linsert $idlist $x $p]
5008                     }
5009                 }
5010                 if {[incr r] < $commitidx($curview)} {
5011                     set p [lindex $displayorder $r]
5012                     if {[lsearch -exact $idlist $p] < 0} {
5013                         set fk [lindex $children($curview,$p) 0]
5014                         if {$fk ne {} && [rowofcommit $fk] < $row} {
5015                             set x [idcol $idlist $p $x]
5016                             set idlist [linsert $idlist $x $p]
5017                         }
5018                     }
5019                 }
5020             }
5021         }
5022         if {$final && !$viewcomplete($curview) &&
5023             $row + $uparrowlen + $mingaplen + $downarrowlen
5024                 >= $commitidx($curview)} {
5025             set final 0
5026         }
5027         set l [llength $rowidlist]
5028         if {$row == $l} {
5029             lappend rowidlist $idlist
5030             lappend rowisopt 0
5031             lappend rowfinal $final
5032         } elseif {$row < $l} {
5033             if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5034                 lset rowidlist $row $idlist
5035                 changedrow $row
5036             }
5037             lset rowfinal $row $final
5038         } else {
5039             set pad [ntimes [expr {$row - $l}] {}]
5040             set rowidlist [concat $rowidlist $pad]
5041             lappend rowidlist $idlist
5042             set rowfinal [concat $rowfinal $pad]
5043             lappend rowfinal $final
5044             set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5045         }
5046     }
5047     return $row
5050 proc changedrow {row} {
5051     global displayorder iddrawn rowisopt need_redisplay
5053     set l [llength $rowisopt]
5054     if {$row < $l} {
5055         lset rowisopt $row 0
5056         if {$row + 1 < $l} {
5057             lset rowisopt [expr {$row + 1}] 0
5058             if {$row + 2 < $l} {
5059                 lset rowisopt [expr {$row + 2}] 0
5060             }
5061         }
5062     }
5063     set id [lindex $displayorder $row]
5064     if {[info exists iddrawn($id)]} {
5065         set need_redisplay 1
5066     }
5069 proc insert_pad {row col npad} {
5070     global rowidlist
5072     set pad [ntimes $npad {}]
5073     set idlist [lindex $rowidlist $row]
5074     set bef [lrange $idlist 0 [expr {$col - 1}]]
5075     set aft [lrange $idlist $col end]
5076     set i [lsearch -exact $aft {}]
5077     if {$i > 0} {
5078         set aft [lreplace $aft $i $i]
5079     }
5080     lset rowidlist $row [concat $bef $pad $aft]
5081     changedrow $row
5084 proc optimize_rows {row col endrow} {
5085     global rowidlist rowisopt displayorder curview children
5087     if {$row < 1} {
5088         set row 1
5089     }
5090     for {} {$row < $endrow} {incr row; set col 0} {
5091         if {[lindex $rowisopt $row]} continue
5092         set haspad 0
5093         set y0 [expr {$row - 1}]
5094         set ym [expr {$row - 2}]
5095         set idlist [lindex $rowidlist $row]
5096         set previdlist [lindex $rowidlist $y0]
5097         if {$idlist eq {} || $previdlist eq {}} continue
5098         if {$ym >= 0} {
5099             set pprevidlist [lindex $rowidlist $ym]
5100             if {$pprevidlist eq {}} continue
5101         } else {
5102             set pprevidlist {}
5103         }
5104         set x0 -1
5105         set xm -1
5106         for {} {$col < [llength $idlist]} {incr col} {
5107             set id [lindex $idlist $col]
5108             if {[lindex $previdlist $col] eq $id} continue
5109             if {$id eq {}} {
5110                 set haspad 1
5111                 continue
5112             }
5113             set x0 [lsearch -exact $previdlist $id]
5114             if {$x0 < 0} continue
5115             set z [expr {$x0 - $col}]
5116             set isarrow 0
5117             set z0 {}
5118             if {$ym >= 0} {
5119                 set xm [lsearch -exact $pprevidlist $id]
5120                 if {$xm >= 0} {
5121                     set z0 [expr {$xm - $x0}]
5122                 }
5123             }
5124             if {$z0 eq {}} {
5125                 # if row y0 is the first child of $id then it's not an arrow
5126                 if {[lindex $children($curview,$id) 0] ne
5127                     [lindex $displayorder $y0]} {
5128                     set isarrow 1
5129                 }
5130             }
5131             if {!$isarrow && $id ne [lindex $displayorder $row] &&
5132                 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5133                 set isarrow 1
5134             }
5135             # Looking at lines from this row to the previous row,
5136             # make them go straight up if they end in an arrow on
5137             # the previous row; otherwise make them go straight up
5138             # or at 45 degrees.
5139             if {$z < -1 || ($z < 0 && $isarrow)} {
5140                 # Line currently goes left too much;
5141                 # insert pads in the previous row, then optimize it
5142                 set npad [expr {-1 - $z + $isarrow}]
5143                 insert_pad $y0 $x0 $npad
5144                 if {$y0 > 0} {
5145                     optimize_rows $y0 $x0 $row
5146                 }
5147                 set previdlist [lindex $rowidlist $y0]
5148                 set x0 [lsearch -exact $previdlist $id]
5149                 set z [expr {$x0 - $col}]
5150                 if {$z0 ne {}} {
5151                     set pprevidlist [lindex $rowidlist $ym]
5152                     set xm [lsearch -exact $pprevidlist $id]
5153                     set z0 [expr {$xm - $x0}]
5154                 }
5155             } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5156                 # Line currently goes right too much;
5157                 # insert pads in this line
5158                 set npad [expr {$z - 1 + $isarrow}]
5159                 insert_pad $row $col $npad
5160                 set idlist [lindex $rowidlist $row]
5161                 incr col $npad
5162                 set z [expr {$x0 - $col}]
5163                 set haspad 1
5164             }
5165             if {$z0 eq {} && !$isarrow && $ym >= 0} {
5166                 # this line links to its first child on row $row-2
5167                 set id [lindex $displayorder $ym]
5168                 set xc [lsearch -exact $pprevidlist $id]
5169                 if {$xc >= 0} {
5170                     set z0 [expr {$xc - $x0}]
5171                 }
5172             }
5173             # avoid lines jigging left then immediately right
5174             if {$z0 ne {} && $z < 0 && $z0 > 0} {
5175                 insert_pad $y0 $x0 1
5176                 incr x0
5177                 optimize_rows $y0 $x0 $row
5178                 set previdlist [lindex $rowidlist $y0]
5179             }
5180         }
5181         if {!$haspad} {
5182             # Find the first column that doesn't have a line going right
5183             for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5184                 set id [lindex $idlist $col]
5185                 if {$id eq {}} break
5186                 set x0 [lsearch -exact $previdlist $id]
5187                 if {$x0 < 0} {
5188                     # check if this is the link to the first child
5189                     set kid [lindex $displayorder $y0]
5190                     if {[lindex $children($curview,$id) 0] eq $kid} {
5191                         # it is, work out offset to child
5192                         set x0 [lsearch -exact $previdlist $kid]
5193                     }
5194                 }
5195                 if {$x0 <= $col} break
5196             }
5197             # Insert a pad at that column as long as it has a line and
5198             # isn't the last column
5199             if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5200                 set idlist [linsert $idlist $col {}]
5201                 lset rowidlist $row $idlist
5202                 changedrow $row
5203             }
5204         }
5205     }
5208 proc xc {row col} {
5209     global canvx0 linespc
5210     return [expr {$canvx0 + $col * $linespc}]
5213 proc yc {row} {
5214     global canvy0 linespc
5215     return [expr {$canvy0 + $row * $linespc}]
5218 proc linewidth {id} {
5219     global thickerline lthickness
5221     set wid $lthickness
5222     if {[info exists thickerline] && $id eq $thickerline} {
5223         set wid [expr {2 * $lthickness}]
5224     }
5225     return $wid
5228 proc rowranges {id} {
5229     global curview children uparrowlen downarrowlen
5230     global rowidlist
5232     set kids $children($curview,$id)
5233     if {$kids eq {}} {
5234         return {}
5235     }
5236     set ret {}
5237     lappend kids $id
5238     foreach child $kids {
5239         if {![commitinview $child $curview]} break
5240         set row [rowofcommit $child]
5241         if {![info exists prev]} {
5242             lappend ret [expr {$row + 1}]
5243         } else {
5244             if {$row <= $prevrow} {
5245                 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5246             }
5247             # see if the line extends the whole way from prevrow to row
5248             if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5249                 [lsearch -exact [lindex $rowidlist \
5250                             [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5251                 # it doesn't, see where it ends
5252                 set r [expr {$prevrow + $downarrowlen}]
5253                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5254                     while {[incr r -1] > $prevrow &&
5255                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5256                 } else {
5257                     while {[incr r] <= $row &&
5258                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5259                     incr r -1
5260                 }
5261                 lappend ret $r
5262                 # see where it starts up again
5263                 set r [expr {$row - $uparrowlen}]
5264                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5265                     while {[incr r] < $row &&
5266                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5267                 } else {
5268                     while {[incr r -1] >= $prevrow &&
5269                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5270                     incr r
5271                 }
5272                 lappend ret $r
5273             }
5274         }
5275         if {$child eq $id} {
5276             lappend ret $row
5277         }
5278         set prev $child
5279         set prevrow $row
5280     }
5281     return $ret
5284 proc drawlineseg {id row endrow arrowlow} {
5285     global rowidlist displayorder iddrawn linesegs
5286     global canv colormap linespc curview maxlinelen parentlist
5288     set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5289     set le [expr {$row + 1}]
5290     set arrowhigh 1
5291     while {1} {
5292         set c [lsearch -exact [lindex $rowidlist $le] $id]
5293         if {$c < 0} {
5294             incr le -1
5295             break
5296         }
5297         lappend cols $c
5298         set x [lindex $displayorder $le]
5299         if {$x eq $id} {
5300             set arrowhigh 0
5301             break
5302         }
5303         if {[info exists iddrawn($x)] || $le == $endrow} {
5304             set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5305             if {$c >= 0} {
5306                 lappend cols $c
5307                 set arrowhigh 0
5308             }
5309             break
5310         }
5311         incr le
5312     }
5313     if {$le <= $row} {
5314         return $row
5315     }
5317     set lines {}
5318     set i 0
5319     set joinhigh 0
5320     if {[info exists linesegs($id)]} {
5321         set lines $linesegs($id)
5322         foreach li $lines {
5323             set r0 [lindex $li 0]
5324             if {$r0 > $row} {
5325                 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5326                     set joinhigh 1
5327                 }
5328                 break
5329             }
5330             incr i
5331         }
5332     }
5333     set joinlow 0
5334     if {$i > 0} {
5335         set li [lindex $lines [expr {$i-1}]]
5336         set r1 [lindex $li 1]
5337         if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5338             set joinlow 1
5339         }
5340     }
5342     set x [lindex $cols [expr {$le - $row}]]
5343     set xp [lindex $cols [expr {$le - 1 - $row}]]
5344     set dir [expr {$xp - $x}]
5345     if {$joinhigh} {
5346         set ith [lindex $lines $i 2]
5347         set coords [$canv coords $ith]
5348         set ah [$canv itemcget $ith -arrow]
5349         set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5350         set x2 [lindex $cols [expr {$le + 1 - $row}]]
5351         if {$x2 ne {} && $x - $x2 == $dir} {
5352             set coords [lrange $coords 0 end-2]
5353         }
5354     } else {
5355         set coords [list [xc $le $x] [yc $le]]
5356     }
5357     if {$joinlow} {
5358         set itl [lindex $lines [expr {$i-1}] 2]
5359         set al [$canv itemcget $itl -arrow]
5360         set arrowlow [expr {$al eq "last" || $al eq "both"}]
5361     } elseif {$arrowlow} {
5362         if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5363             [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5364             set arrowlow 0
5365         }
5366     }
5367     set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5368     for {set y $le} {[incr y -1] > $row} {} {
5369         set x $xp
5370         set xp [lindex $cols [expr {$y - 1 - $row}]]
5371         set ndir [expr {$xp - $x}]
5372         if {$dir != $ndir || $xp < 0} {
5373             lappend coords [xc $y $x] [yc $y]
5374         }
5375         set dir $ndir
5376     }
5377     if {!$joinlow} {
5378         if {$xp < 0} {
5379             # join parent line to first child
5380             set ch [lindex $displayorder $row]
5381             set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5382             if {$xc < 0} {
5383                 puts "oops: drawlineseg: child $ch not on row $row"
5384             } elseif {$xc != $x} {
5385                 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5386                     set d [expr {int(0.5 * $linespc)}]
5387                     set x1 [xc $row $x]
5388                     if {$xc < $x} {
5389                         set x2 [expr {$x1 - $d}]
5390                     } else {
5391                         set x2 [expr {$x1 + $d}]
5392                     }
5393                     set y2 [yc $row]
5394                     set y1 [expr {$y2 + $d}]
5395                     lappend coords $x1 $y1 $x2 $y2
5396                 } elseif {$xc < $x - 1} {
5397                     lappend coords [xc $row [expr {$x-1}]] [yc $row]
5398                 } elseif {$xc > $x + 1} {
5399                     lappend coords [xc $row [expr {$x+1}]] [yc $row]
5400                 }
5401                 set x $xc
5402             }
5403             lappend coords [xc $row $x] [yc $row]
5404         } else {
5405             set xn [xc $row $xp]
5406             set yn [yc $row]
5407             lappend coords $xn $yn
5408         }
5409         if {!$joinhigh} {
5410             assigncolor $id
5411             set t [$canv create line $coords -width [linewidth $id] \
5412                        -fill $colormap($id) -tags lines.$id -arrow $arrow]
5413             $canv lower $t
5414             bindline $t $id
5415             set lines [linsert $lines $i [list $row $le $t]]
5416         } else {
5417             $canv coords $ith $coords
5418             if {$arrow ne $ah} {
5419                 $canv itemconf $ith -arrow $arrow
5420             }
5421             lset lines $i 0 $row
5422         }
5423     } else {
5424         set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5425         set ndir [expr {$xo - $xp}]
5426         set clow [$canv coords $itl]
5427         if {$dir == $ndir} {
5428             set clow [lrange $clow 2 end]
5429         }
5430         set coords [concat $coords $clow]
5431         if {!$joinhigh} {
5432             lset lines [expr {$i-1}] 1 $le
5433         } else {
5434             # coalesce two pieces
5435             $canv delete $ith
5436             set b [lindex $lines [expr {$i-1}] 0]
5437             set e [lindex $lines $i 1]
5438             set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5439         }
5440         $canv coords $itl $coords
5441         if {$arrow ne $al} {
5442             $canv itemconf $itl -arrow $arrow
5443         }
5444     }
5446     set linesegs($id) $lines
5447     return $le
5450 proc drawparentlinks {id row} {
5451     global rowidlist canv colormap curview parentlist
5452     global idpos linespc
5454     set rowids [lindex $rowidlist $row]
5455     set col [lsearch -exact $rowids $id]
5456     if {$col < 0} return
5457     set olds [lindex $parentlist $row]
5458     set row2 [expr {$row + 1}]
5459     set x [xc $row $col]
5460     set y [yc $row]
5461     set y2 [yc $row2]
5462     set d [expr {int(0.5 * $linespc)}]
5463     set ymid [expr {$y + $d}]
5464     set ids [lindex $rowidlist $row2]
5465     # rmx = right-most X coord used
5466     set rmx 0
5467     foreach p $olds {
5468         set i [lsearch -exact $ids $p]
5469         if {$i < 0} {
5470             puts "oops, parent $p of $id not in list"
5471             continue
5472         }
5473         set x2 [xc $row2 $i]
5474         if {$x2 > $rmx} {
5475             set rmx $x2
5476         }
5477         set j [lsearch -exact $rowids $p]
5478         if {$j < 0} {
5479             # drawlineseg will do this one for us
5480             continue
5481         }
5482         assigncolor $p
5483         # should handle duplicated parents here...
5484         set coords [list $x $y]
5485         if {$i != $col} {
5486             # if attaching to a vertical segment, draw a smaller
5487             # slant for visual distinctness
5488             if {$i == $j} {
5489                 if {$i < $col} {
5490                     lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5491                 } else {
5492                     lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5493                 }
5494             } elseif {$i < $col && $i < $j} {
5495                 # segment slants towards us already
5496                 lappend coords [xc $row $j] $y
5497             } else {
5498                 if {$i < $col - 1} {
5499                     lappend coords [expr {$x2 + $linespc}] $y
5500                 } elseif {$i > $col + 1} {
5501                     lappend coords [expr {$x2 - $linespc}] $y
5502                 }
5503                 lappend coords $x2 $y2
5504             }
5505         } else {
5506             lappend coords $x2 $y2
5507         }
5508         set t [$canv create line $coords -width [linewidth $p] \
5509                    -fill $colormap($p) -tags lines.$p]
5510         $canv lower $t
5511         bindline $t $p
5512     }
5513     if {$rmx > [lindex $idpos($id) 1]} {
5514         lset idpos($id) 1 $rmx
5515         redrawtags $id
5516     }
5519 proc drawlines {id} {
5520     global canv
5522     $canv itemconf lines.$id -width [linewidth $id]
5525 proc drawcmittext {id row col} {
5526     global linespc canv canv2 canv3 fgcolor curview
5527     global cmitlisted commitinfo rowidlist parentlist
5528     global rowtextx idpos idtags idheads idotherrefs
5529     global linehtag linentag linedtag selectedline
5530     global canvxmax boldids boldnameids fgcolor
5531     global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5533     # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5534     set listed $cmitlisted($curview,$id)
5535     if {$id eq $nullid} {
5536         set ofill red
5537     } elseif {$id eq $nullid2} {
5538         set ofill green
5539     } elseif {$id eq $mainheadid} {
5540         set ofill yellow
5541     } else {
5542         set ofill [lindex $circlecolors $listed]
5543     }
5544     set x [xc $row $col]
5545     set y [yc $row]
5546     set orad [expr {$linespc / 3}]
5547     if {$listed <= 2} {
5548         set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5549                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5550                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
5551     } elseif {$listed == 3} {
5552         # triangle pointing left for left-side commits
5553         set t [$canv create polygon \
5554                    [expr {$x - $orad}] $y \
5555                    [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5556                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5557                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
5558     } else {
5559         # triangle pointing right for right-side commits
5560         set t [$canv create polygon \
5561                    [expr {$x + $orad - 1}] $y \
5562                    [expr {$x - $orad}] [expr {$y - $orad}] \
5563                    [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5564                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
5565     }
5566     set circleitem($row) $t
5567     $canv raise $t
5568     $canv bind $t <1> {selcanvline {} %x %y}
5569     set rmx [llength [lindex $rowidlist $row]]
5570     set olds [lindex $parentlist $row]
5571     if {$olds ne {}} {
5572         set nextids [lindex $rowidlist [expr {$row + 1}]]
5573         foreach p $olds {
5574             set i [lsearch -exact $nextids $p]
5575             if {$i > $rmx} {
5576                 set rmx $i
5577             }
5578         }
5579     }
5580     set xt [xc $row $rmx]
5581     set rowtextx($row) $xt
5582     set idpos($id) [list $x $xt $y]
5583     if {[info exists idtags($id)] || [info exists idheads($id)]
5584         || [info exists idotherrefs($id)]} {
5585         set xt [drawtags $id $x $xt $y]
5586     }
5587     set headline [lindex $commitinfo($id) 0]
5588     set name [lindex $commitinfo($id) 1]
5589     set date [lindex $commitinfo($id) 2]
5590     set date [formatdate $date]
5591     set font mainfont
5592     set nfont mainfont
5593     set isbold [ishighlighted $id]
5594     if {$isbold > 0} {
5595         lappend boldids $id
5596         set font mainfontbold
5597         if {$isbold > 1} {
5598             lappend boldnameids $id
5599             set nfont mainfontbold
5600         }
5601     }
5602     set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5603                            -text $headline -font $font -tags text]
5604     $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5605     set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5606                            -text $name -font $nfont -tags text]
5607     set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5608                            -text $date -font mainfont -tags text]
5609     if {$selectedline == $row} {
5610         make_secsel $id
5611     }
5612     set xr [expr {$xt + [font measure $font $headline]}]
5613     if {$xr > $canvxmax} {
5614         set canvxmax $xr
5615         setcanvscroll
5616     }
5619 proc drawcmitrow {row} {
5620     global displayorder rowidlist nrows_drawn
5621     global iddrawn markingmatches
5622     global commitinfo numcommits
5623     global filehighlight fhighlights findpattern nhighlights
5624     global hlview vhighlights
5625     global highlight_related rhighlights
5627     if {$row >= $numcommits} return
5629     set id [lindex $displayorder $row]
5630     if {[info exists hlview] && ![info exists vhighlights($id)]} {
5631         askvhighlight $row $id
5632     }
5633     if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5634         askfilehighlight $row $id
5635     }
5636     if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5637         askfindhighlight $row $id
5638     }
5639     if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5640         askrelhighlight $row $id
5641     }
5642     if {![info exists iddrawn($id)]} {
5643         set col [lsearch -exact [lindex $rowidlist $row] $id]
5644         if {$col < 0} {
5645             puts "oops, row $row id $id not in list"
5646             return
5647         }
5648         if {![info exists commitinfo($id)]} {
5649             getcommit $id
5650         }
5651         assigncolor $id
5652         drawcmittext $id $row $col
5653         set iddrawn($id) 1
5654         incr nrows_drawn
5655     }
5656     if {$markingmatches} {
5657         markrowmatches $row $id
5658     }
5661 proc drawcommits {row {endrow {}}} {
5662     global numcommits iddrawn displayorder curview need_redisplay
5663     global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5665     if {$row < 0} {
5666         set row 0
5667     }
5668     if {$endrow eq {}} {
5669         set endrow $row
5670     }
5671     if {$endrow >= $numcommits} {
5672         set endrow [expr {$numcommits - 1}]
5673     }
5675     set rl1 [expr {$row - $downarrowlen - 3}]
5676     if {$rl1 < 0} {
5677         set rl1 0
5678     }
5679     set ro1 [expr {$row - 3}]
5680     if {$ro1 < 0} {
5681         set ro1 0
5682     }
5683     set r2 [expr {$endrow + $uparrowlen + 3}]
5684     if {$r2 > $numcommits} {
5685         set r2 $numcommits
5686     }
5687     for {set r $rl1} {$r < $r2} {incr r} {
5688         if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5689             if {$rl1 < $r} {
5690                 layoutrows $rl1 $r
5691             }
5692             set rl1 [expr {$r + 1}]
5693         }
5694     }
5695     if {$rl1 < $r} {
5696         layoutrows $rl1 $r
5697     }
5698     optimize_rows $ro1 0 $r2
5699     if {$need_redisplay || $nrows_drawn > 2000} {
5700         clear_display
5701         drawvisible
5702     }
5704     # make the lines join to already-drawn rows either side
5705     set r [expr {$row - 1}]
5706     if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5707         set r $row
5708     }
5709     set er [expr {$endrow + 1}]
5710     if {$er >= $numcommits ||
5711         ![info exists iddrawn([lindex $displayorder $er])]} {
5712         set er $endrow
5713     }
5714     for {} {$r <= $er} {incr r} {
5715         set id [lindex $displayorder $r]
5716         set wasdrawn [info exists iddrawn($id)]
5717         drawcmitrow $r
5718         if {$r == $er} break
5719         set nextid [lindex $displayorder [expr {$r + 1}]]
5720         if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5721         drawparentlinks $id $r
5723         set rowids [lindex $rowidlist $r]
5724         foreach lid $rowids {
5725             if {$lid eq {}} continue
5726             if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5727             if {$lid eq $id} {
5728                 # see if this is the first child of any of its parents
5729                 foreach p [lindex $parentlist $r] {
5730                     if {[lsearch -exact $rowids $p] < 0} {
5731                         # make this line extend up to the child
5732                         set lineend($p) [drawlineseg $p $r $er 0]
5733                     }
5734                 }
5735             } else {
5736                 set lineend($lid) [drawlineseg $lid $r $er 1]
5737             }
5738         }
5739     }
5742 proc undolayout {row} {
5743     global uparrowlen mingaplen downarrowlen
5744     global rowidlist rowisopt rowfinal need_redisplay
5746     set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5747     if {$r < 0} {
5748         set r 0
5749     }
5750     if {[llength $rowidlist] > $r} {
5751         incr r -1
5752         set rowidlist [lrange $rowidlist 0 $r]
5753         set rowfinal [lrange $rowfinal 0 $r]
5754         set rowisopt [lrange $rowisopt 0 $r]
5755         set need_redisplay 1
5756         run drawvisible
5757     }
5760 proc drawvisible {} {
5761     global canv linespc curview vrowmod selectedline targetrow targetid
5762     global need_redisplay cscroll numcommits
5764     set fs [$canv yview]
5765     set ymax [lindex [$canv cget -scrollregion] 3]
5766     if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5767     set f0 [lindex $fs 0]
5768     set f1 [lindex $fs 1]
5769     set y0 [expr {int($f0 * $ymax)}]
5770     set y1 [expr {int($f1 * $ymax)}]
5772     if {[info exists targetid]} {
5773         if {[commitinview $targetid $curview]} {
5774             set r [rowofcommit $targetid]
5775             if {$r != $targetrow} {
5776                 # Fix up the scrollregion and change the scrolling position
5777                 # now that our target row has moved.
5778                 set diff [expr {($r - $targetrow) * $linespc}]
5779                 set targetrow $r
5780                 setcanvscroll
5781                 set ymax [lindex [$canv cget -scrollregion] 3]
5782                 incr y0 $diff
5783                 incr y1 $diff
5784                 set f0 [expr {$y0 / $ymax}]
5785                 set f1 [expr {$y1 / $ymax}]
5786                 allcanvs yview moveto $f0
5787                 $cscroll set $f0 $f1
5788                 set need_redisplay 1
5789             }
5790         } else {
5791             unset targetid
5792         }
5793     }
5795     set row [expr {int(($y0 - 3) / $linespc) - 1}]
5796     set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5797     if {$endrow >= $vrowmod($curview)} {
5798         update_arcrows $curview
5799     }
5800     if {$selectedline ne {} &&
5801         $row <= $selectedline && $selectedline <= $endrow} {
5802         set targetrow $selectedline
5803     } elseif {[info exists targetid]} {
5804         set targetrow [expr {int(($row + $endrow) / 2)}]
5805     }
5806     if {[info exists targetrow]} {
5807         if {$targetrow >= $numcommits} {
5808             set targetrow [expr {$numcommits - 1}]
5809         }
5810         set targetid [commitonrow $targetrow]
5811     }
5812     drawcommits $row $endrow
5815 proc clear_display {} {
5816     global iddrawn linesegs need_redisplay nrows_drawn
5817     global vhighlights fhighlights nhighlights rhighlights
5818     global linehtag linentag linedtag boldids boldnameids
5820     allcanvs delete all
5821     catch {unset iddrawn}
5822     catch {unset linesegs}
5823     catch {unset linehtag}
5824     catch {unset linentag}
5825     catch {unset linedtag}
5826     set boldids {}
5827     set boldnameids {}
5828     catch {unset vhighlights}
5829     catch {unset fhighlights}
5830     catch {unset nhighlights}
5831     catch {unset rhighlights}
5832     set need_redisplay 0
5833     set nrows_drawn 0
5836 proc findcrossings {id} {
5837     global rowidlist parentlist numcommits displayorder
5839     set cross {}
5840     set ccross {}
5841     foreach {s e} [rowranges $id] {
5842         if {$e >= $numcommits} {
5843             set e [expr {$numcommits - 1}]
5844         }
5845         if {$e <= $s} continue
5846         for {set row $e} {[incr row -1] >= $s} {} {
5847             set x [lsearch -exact [lindex $rowidlist $row] $id]
5848             if {$x < 0} break
5849             set olds [lindex $parentlist $row]
5850             set kid [lindex $displayorder $row]
5851             set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5852             if {$kidx < 0} continue
5853             set nextrow [lindex $rowidlist [expr {$row + 1}]]
5854             foreach p $olds {
5855                 set px [lsearch -exact $nextrow $p]
5856                 if {$px < 0} continue
5857                 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5858                     if {[lsearch -exact $ccross $p] >= 0} continue
5859                     if {$x == $px + ($kidx < $px? -1: 1)} {
5860                         lappend ccross $p
5861                     } elseif {[lsearch -exact $cross $p] < 0} {
5862                         lappend cross $p
5863                     }
5864                 }
5865             }
5866         }
5867     }
5868     return [concat $ccross {{}} $cross]
5871 proc assigncolor {id} {
5872     global colormap colors nextcolor
5873     global parents children children curview
5875     if {[info exists colormap($id)]} return
5876     set ncolors [llength $colors]
5877     if {[info exists children($curview,$id)]} {
5878         set kids $children($curview,$id)
5879     } else {
5880         set kids {}
5881     }
5882     if {[llength $kids] == 1} {
5883         set child [lindex $kids 0]
5884         if {[info exists colormap($child)]
5885             && [llength $parents($curview,$child)] == 1} {
5886             set colormap($id) $colormap($child)
5887             return
5888         }
5889     }
5890     set badcolors {}
5891     set origbad {}
5892     foreach x [findcrossings $id] {
5893         if {$x eq {}} {
5894             # delimiter between corner crossings and other crossings
5895             if {[llength $badcolors] >= $ncolors - 1} break
5896             set origbad $badcolors
5897         }
5898         if {[info exists colormap($x)]
5899             && [lsearch -exact $badcolors $colormap($x)] < 0} {
5900             lappend badcolors $colormap($x)
5901         }
5902     }
5903     if {[llength $badcolors] >= $ncolors} {
5904         set badcolors $origbad
5905     }
5906     set origbad $badcolors
5907     if {[llength $badcolors] < $ncolors - 1} {
5908         foreach child $kids {
5909             if {[info exists colormap($child)]
5910                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5911                 lappend badcolors $colormap($child)
5912             }
5913             foreach p $parents($curview,$child) {
5914                 if {[info exists colormap($p)]
5915                     && [lsearch -exact $badcolors $colormap($p)] < 0} {
5916                     lappend badcolors $colormap($p)
5917                 }
5918             }
5919         }
5920         if {[llength $badcolors] >= $ncolors} {
5921             set badcolors $origbad
5922         }
5923     }
5924     for {set i 0} {$i <= $ncolors} {incr i} {
5925         set c [lindex $colors $nextcolor]
5926         if {[incr nextcolor] >= $ncolors} {
5927             set nextcolor 0
5928         }
5929         if {[lsearch -exact $badcolors $c]} break
5930     }
5931     set colormap($id) $c
5934 proc bindline {t id} {
5935     global canv
5937     $canv bind $t <Enter> "lineenter %x %y $id"
5938     $canv bind $t <Motion> "linemotion %x %y $id"
5939     $canv bind $t <Leave> "lineleave $id"
5940     $canv bind $t <Button-1> "lineclick %x %y $id 1"
5943 proc drawtags {id x xt y1} {
5944     global idtags idheads idotherrefs mainhead
5945     global linespc lthickness
5946     global canv rowtextx curview fgcolor bgcolor ctxbut
5948     set marks {}
5949     set ntags 0
5950     set nheads 0
5951     if {[info exists idtags($id)]} {
5952         set marks $idtags($id)
5953         set ntags [llength $marks]
5954     }
5955     if {[info exists idheads($id)]} {
5956         set marks [concat $marks $idheads($id)]
5957         set nheads [llength $idheads($id)]
5958     }
5959     if {[info exists idotherrefs($id)]} {
5960         set marks [concat $marks $idotherrefs($id)]
5961     }
5962     if {$marks eq {}} {
5963         return $xt
5964     }
5966     set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5967     set yt [expr {$y1 - 0.5 * $linespc}]
5968     set yb [expr {$yt + $linespc - 1}]
5969     set xvals {}
5970     set wvals {}
5971     set i -1
5972     foreach tag $marks {
5973         incr i
5974         if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5975             set wid [font measure mainfontbold $tag]
5976         } else {
5977             set wid [font measure mainfont $tag]
5978         }
5979         lappend xvals $xt
5980         lappend wvals $wid
5981         set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5982     }
5983     set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5984                -width $lthickness -fill black -tags tag.$id]
5985     $canv lower $t
5986     foreach tag $marks x $xvals wid $wvals {
5987         set xl [expr {$x + $delta}]
5988         set xr [expr {$x + $delta + $wid + $lthickness}]
5989         set font mainfont
5990         if {[incr ntags -1] >= 0} {
5991             # draw a tag
5992             set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5993                        $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5994                        -width 1 -outline black -fill yellow -tags tag.$id]
5995             $canv bind $t <1> [list showtag $tag 1]
5996             set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
5997         } else {
5998             # draw a head or other ref
5999             if {[incr nheads -1] >= 0} {
6000                 set col green
6001                 if {$tag eq $mainhead} {
6002                     set font mainfontbold
6003                 }
6004             } else {
6005                 set col "#ddddff"
6006             }
6007             set xl [expr {$xl - $delta/2}]
6008             $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6009                 -width 1 -outline black -fill $col -tags tag.$id
6010             if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6011                 set rwid [font measure mainfont $remoteprefix]
6012                 set xi [expr {$x + 1}]
6013                 set yti [expr {$yt + 1}]
6014                 set xri [expr {$x + $rwid}]
6015                 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6016                         -width 0 -fill "#ffddaa" -tags tag.$id
6017             }
6018         }
6019         set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6020                    -font $font -tags [list tag.$id text]]
6021         if {$ntags >= 0} {
6022             $canv bind $t <1> [list showtag $tag 1]
6023         } elseif {$nheads >= 0} {
6024             $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6025         }
6026     }
6027     return $xt
6030 proc xcoord {i level ln} {
6031     global canvx0 xspc1 xspc2
6033     set x [expr {$canvx0 + $i * $xspc1($ln)}]
6034     if {$i > 0 && $i == $level} {
6035         set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6036     } elseif {$i > $level} {
6037         set x [expr {$x + $xspc2 - $xspc1($ln)}]
6038     }
6039     return $x
6042 proc show_status {msg} {
6043     global canv fgcolor
6045     clear_display
6046     $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6047         -tags text -fill $fgcolor
6050 # Don't change the text pane cursor if it is currently the hand cursor,
6051 # showing that we are over a sha1 ID link.
6052 proc settextcursor {c} {
6053     global ctext curtextcursor
6055     if {[$ctext cget -cursor] == $curtextcursor} {
6056         $ctext config -cursor $c
6057     }
6058     set curtextcursor $c
6061 proc nowbusy {what {name {}}} {
6062     global isbusy busyname statusw
6064     if {[array names isbusy] eq {}} {
6065         . config -cursor watch
6066         settextcursor watch
6067     }
6068     set isbusy($what) 1
6069     set busyname($what) $name
6070     if {$name ne {}} {
6071         $statusw conf -text $name
6072     }
6075 proc notbusy {what} {
6076     global isbusy maincursor textcursor busyname statusw
6078     catch {
6079         unset isbusy($what)
6080         if {$busyname($what) ne {} &&
6081             [$statusw cget -text] eq $busyname($what)} {
6082             $statusw conf -text {}
6083         }
6084     }
6085     if {[array names isbusy] eq {}} {
6086         . config -cursor $maincursor
6087         settextcursor $textcursor
6088     }
6091 proc findmatches {f} {
6092     global findtype findstring
6093     if {$findtype == [mc "Regexp"]} {
6094         set matches [regexp -indices -all -inline $findstring $f]
6095     } else {
6096         set fs $findstring
6097         if {$findtype == [mc "IgnCase"]} {
6098             set f [string tolower $f]
6099             set fs [string tolower $fs]
6100         }
6101         set matches {}
6102         set i 0
6103         set l [string length $fs]
6104         while {[set j [string first $fs $f $i]] >= 0} {
6105             lappend matches [list $j [expr {$j+$l-1}]]
6106             set i [expr {$j + $l}]
6107         }
6108     }
6109     return $matches
6112 proc dofind {{dirn 1} {wrap 1}} {
6113     global findstring findstartline findcurline selectedline numcommits
6114     global gdttype filehighlight fh_serial find_dirn findallowwrap
6116     if {[info exists find_dirn]} {
6117         if {$find_dirn == $dirn} return
6118         stopfinding
6119     }
6120     focus .
6121     if {$findstring eq {} || $numcommits == 0} return
6122     if {$selectedline eq {}} {
6123         set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6124     } else {
6125         set findstartline $selectedline
6126     }
6127     set findcurline $findstartline
6128     nowbusy finding [mc "Searching"]
6129     if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6130         after cancel do_file_hl $fh_serial
6131         do_file_hl $fh_serial
6132     }
6133     set find_dirn $dirn
6134     set findallowwrap $wrap
6135     run findmore
6138 proc stopfinding {} {
6139     global find_dirn findcurline fprogcoord
6141     if {[info exists find_dirn]} {
6142         unset find_dirn
6143         unset findcurline
6144         notbusy finding
6145         set fprogcoord 0
6146         adjustprogress
6147     }
6148     stopblaming
6151 proc findmore {} {
6152     global commitdata commitinfo numcommits findpattern findloc
6153     global findstartline findcurline findallowwrap
6154     global find_dirn gdttype fhighlights fprogcoord
6155     global curview varcorder vrownum varccommits vrowmod
6157     if {![info exists find_dirn]} {
6158         return 0
6159     }
6160     set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6161     set l $findcurline
6162     set moretodo 0
6163     if {$find_dirn > 0} {
6164         incr l
6165         if {$l >= $numcommits} {
6166             set l 0
6167         }
6168         if {$l <= $findstartline} {
6169             set lim [expr {$findstartline + 1}]
6170         } else {
6171             set lim $numcommits
6172             set moretodo $findallowwrap
6173         }
6174     } else {
6175         if {$l == 0} {
6176             set l $numcommits
6177         }
6178         incr l -1
6179         if {$l >= $findstartline} {
6180             set lim [expr {$findstartline - 1}]
6181         } else {
6182             set lim -1
6183             set moretodo $findallowwrap
6184         }
6185     }
6186     set n [expr {($lim - $l) * $find_dirn}]
6187     if {$n > 500} {
6188         set n 500
6189         set moretodo 1
6190     }
6191     if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6192         update_arcrows $curview
6193     }
6194     set found 0
6195     set domore 1
6196     set ai [bsearch $vrownum($curview) $l]
6197     set a [lindex $varcorder($curview) $ai]
6198     set arow [lindex $vrownum($curview) $ai]
6199     set ids [lindex $varccommits($curview,$a)]
6200     set arowend [expr {$arow + [llength $ids]}]
6201     if {$gdttype eq [mc "containing:"]} {
6202         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6203             if {$l < $arow || $l >= $arowend} {
6204                 incr ai $find_dirn
6205                 set a [lindex $varcorder($curview) $ai]
6206                 set arow [lindex $vrownum($curview) $ai]
6207                 set ids [lindex $varccommits($curview,$a)]
6208                 set arowend [expr {$arow + [llength $ids]}]
6209             }
6210             set id [lindex $ids [expr {$l - $arow}]]
6211             # shouldn't happen unless git log doesn't give all the commits...
6212             if {![info exists commitdata($id)] ||
6213                 ![doesmatch $commitdata($id)]} {
6214                 continue
6215             }
6216             if {![info exists commitinfo($id)]} {
6217                 getcommit $id
6218             }
6219             set info $commitinfo($id)
6220             foreach f $info ty $fldtypes {
6221                 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6222                     [doesmatch $f]} {
6223                     set found 1
6224                     break
6225                 }
6226             }
6227             if {$found} break
6228         }
6229     } else {
6230         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6231             if {$l < $arow || $l >= $arowend} {
6232                 incr ai $find_dirn
6233                 set a [lindex $varcorder($curview) $ai]
6234                 set arow [lindex $vrownum($curview) $ai]
6235                 set ids [lindex $varccommits($curview,$a)]
6236                 set arowend [expr {$arow + [llength $ids]}]
6237             }
6238             set id [lindex $ids [expr {$l - $arow}]]
6239             if {![info exists fhighlights($id)]} {
6240                 # this sets fhighlights($id) to -1
6241                 askfilehighlight $l $id
6242             }
6243             if {$fhighlights($id) > 0} {
6244                 set found $domore
6245                 break
6246             }
6247             if {$fhighlights($id) < 0} {
6248                 if {$domore} {
6249                     set domore 0
6250                     set findcurline [expr {$l - $find_dirn}]
6251                 }
6252             }
6253         }
6254     }
6255     if {$found || ($domore && !$moretodo)} {
6256         unset findcurline
6257         unset find_dirn
6258         notbusy finding
6259         set fprogcoord 0
6260         adjustprogress
6261         if {$found} {
6262             findselectline $l
6263         } else {
6264             bell
6265         }
6266         return 0
6267     }
6268     if {!$domore} {
6269         flushhighlights
6270     } else {
6271         set findcurline [expr {$l - $find_dirn}]
6272     }
6273     set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6274     if {$n < 0} {
6275         incr n $numcommits
6276     }
6277     set fprogcoord [expr {$n * 1.0 / $numcommits}]
6278     adjustprogress
6279     return $domore
6282 proc findselectline {l} {
6283     global findloc commentend ctext findcurline markingmatches gdttype
6285     set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6286     set findcurline $l
6287     selectline $l 1
6288     if {$markingmatches &&
6289         ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6290         # highlight the matches in the comments
6291         set f [$ctext get 1.0 $commentend]
6292         set matches [findmatches $f]
6293         foreach match $matches {
6294             set start [lindex $match 0]
6295             set end [expr {[lindex $match 1] + 1}]
6296             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6297         }
6298     }
6299     drawvisible
6302 # mark the bits of a headline or author that match a find string
6303 proc markmatches {canv l str tag matches font row} {
6304     global selectedline
6306     set bbox [$canv bbox $tag]
6307     set x0 [lindex $bbox 0]
6308     set y0 [lindex $bbox 1]
6309     set y1 [lindex $bbox 3]
6310     foreach match $matches {
6311         set start [lindex $match 0]
6312         set end [lindex $match 1]
6313         if {$start > $end} continue
6314         set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6315         set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6316         set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6317                    [expr {$x0+$xlen+2}] $y1 \
6318                    -outline {} -tags [list match$l matches] -fill yellow]
6319         $canv lower $t
6320         if {$row == $selectedline} {
6321             $canv raise $t secsel
6322         }
6323     }
6326 proc unmarkmatches {} {
6327     global markingmatches
6329     allcanvs delete matches
6330     set markingmatches 0
6331     stopfinding
6334 proc selcanvline {w x y} {
6335     global canv canvy0 ctext linespc
6336     global rowtextx
6337     set ymax [lindex [$canv cget -scrollregion] 3]
6338     if {$ymax == {}} return
6339     set yfrac [lindex [$canv yview] 0]
6340     set y [expr {$y + $yfrac * $ymax}]
6341     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6342     if {$l < 0} {
6343         set l 0
6344     }
6345     if {$w eq $canv} {
6346         set xmax [lindex [$canv cget -scrollregion] 2]
6347         set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6348         if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6349     }
6350     unmarkmatches
6351     selectline $l 1
6354 proc commit_descriptor {p} {
6355     global commitinfo
6356     if {![info exists commitinfo($p)]} {
6357         getcommit $p
6358     }
6359     set l "..."
6360     if {[llength $commitinfo($p)] > 1} {
6361         set l [lindex $commitinfo($p) 0]
6362     }
6363     return "$p ($l)\n"
6366 # append some text to the ctext widget, and make any SHA1 ID
6367 # that we know about be a clickable link.
6368 proc appendwithlinks {text tags} {
6369     global ctext linknum curview
6371     set start [$ctext index "end - 1c"]
6372     $ctext insert end $text $tags
6373     set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6374     foreach l $links {
6375         set s [lindex $l 0]
6376         set e [lindex $l 1]
6377         set linkid [string range $text $s $e]
6378         incr e
6379         $ctext tag delete link$linknum
6380         $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6381         setlink $linkid link$linknum
6382         incr linknum
6383     }
6386 proc setlink {id lk} {
6387     global curview ctext pendinglinks
6389     set known 0
6390     if {[string length $id] < 40} {
6391         set matches [longid $id]
6392         if {[llength $matches] > 0} {
6393             if {[llength $matches] > 1} return
6394             set known 1
6395             set id [lindex $matches 0]
6396         }
6397     } else {
6398         set known [commitinview $id $curview]
6399     }
6400     if {$known} {
6401         $ctext tag conf $lk -foreground blue -underline 1
6402         $ctext tag bind $lk <1> [list selbyid $id]
6403         $ctext tag bind $lk <Enter> {linkcursor %W 1}
6404         $ctext tag bind $lk <Leave> {linkcursor %W -1}
6405     } else {
6406         lappend pendinglinks($id) $lk
6407         interestedin $id {makelink %P}
6408     }
6411 proc makelink {id} {
6412     global pendinglinks
6414     if {![info exists pendinglinks($id)]} return
6415     foreach lk $pendinglinks($id) {
6416         setlink $id $lk
6417     }
6418     unset pendinglinks($id)
6421 proc linkcursor {w inc} {
6422     global linkentercount curtextcursor
6424     if {[incr linkentercount $inc] > 0} {
6425         $w configure -cursor hand2
6426     } else {
6427         $w configure -cursor $curtextcursor
6428         if {$linkentercount < 0} {
6429             set linkentercount 0
6430         }
6431     }
6434 proc viewnextline {dir} {
6435     global canv linespc
6437     $canv delete hover
6438     set ymax [lindex [$canv cget -scrollregion] 3]
6439     set wnow [$canv yview]
6440     set wtop [expr {[lindex $wnow 0] * $ymax}]
6441     set newtop [expr {$wtop + $dir * $linespc}]
6442     if {$newtop < 0} {
6443         set newtop 0
6444     } elseif {$newtop > $ymax} {
6445         set newtop $ymax
6446     }
6447     allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6450 # add a list of tag or branch names at position pos
6451 # returns the number of names inserted
6452 proc appendrefs {pos ids var} {
6453     global ctext linknum curview $var maxrefs
6455     if {[catch {$ctext index $pos}]} {
6456         return 0
6457     }
6458     $ctext conf -state normal
6459     $ctext delete $pos "$pos lineend"
6460     set tags {}
6461     foreach id $ids {
6462         foreach tag [set $var\($id\)] {
6463             lappend tags [list $tag $id]
6464         }
6465     }
6466     if {[llength $tags] > $maxrefs} {
6467         $ctext insert $pos "many ([llength $tags])"
6468     } else {
6469         set tags [lsort -index 0 -decreasing $tags]
6470         set sep {}
6471         foreach ti $tags {
6472             set id [lindex $ti 1]
6473             set lk link$linknum
6474             incr linknum
6475             $ctext tag delete $lk
6476             $ctext insert $pos $sep
6477             $ctext insert $pos [lindex $ti 0] $lk
6478             setlink $id $lk
6479             set sep ", "
6480         }
6481     }
6482     $ctext conf -state disabled
6483     return [llength $tags]
6486 # called when we have finished computing the nearby tags
6487 proc dispneartags {delay} {
6488     global selectedline currentid showneartags tagphase
6490     if {$selectedline eq {} || !$showneartags} return
6491     after cancel dispnexttag
6492     if {$delay} {
6493         after 200 dispnexttag
6494         set tagphase -1
6495     } else {
6496         after idle dispnexttag
6497         set tagphase 0
6498     }
6501 proc dispnexttag {} {
6502     global selectedline currentid showneartags tagphase ctext
6504     if {$selectedline eq {} || !$showneartags} return
6505     switch -- $tagphase {
6506         0 {
6507             set dtags [desctags $currentid]
6508             if {$dtags ne {}} {
6509                 appendrefs precedes $dtags idtags
6510             }
6511         }
6512         1 {
6513             set atags [anctags $currentid]
6514             if {$atags ne {}} {
6515                 appendrefs follows $atags idtags
6516             }
6517         }
6518         2 {
6519             set dheads [descheads $currentid]
6520             if {$dheads ne {}} {
6521                 if {[appendrefs branch $dheads idheads] > 1
6522                     && [$ctext get "branch -3c"] eq "h"} {
6523                     # turn "Branch" into "Branches"
6524                     $ctext conf -state normal
6525                     $ctext insert "branch -2c" "es"
6526                     $ctext conf -state disabled
6527                 }
6528             }
6529         }
6530     }
6531     if {[incr tagphase] <= 2} {
6532         after idle dispnexttag
6533     }
6536 proc make_secsel {id} {
6537     global linehtag linentag linedtag canv canv2 canv3
6539     if {![info exists linehtag($id)]} return
6540     $canv delete secsel
6541     set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6542                -tags secsel -fill [$canv cget -selectbackground]]
6543     $canv lower $t
6544     $canv2 delete secsel
6545     set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6546                -tags secsel -fill [$canv2 cget -selectbackground]]
6547     $canv2 lower $t
6548     $canv3 delete secsel
6549     set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6550                -tags secsel -fill [$canv3 cget -selectbackground]]
6551     $canv3 lower $t
6554 proc selectline {l isnew {desired_loc {}}} {
6555     global canv ctext commitinfo selectedline
6556     global canvy0 linespc parents children curview
6557     global currentid sha1entry
6558     global commentend idtags linknum
6559     global mergemax numcommits pending_select
6560     global cmitmode showneartags allcommits
6561     global targetrow targetid lastscrollrows
6562     global autoselect jump_to_here
6564     catch {unset pending_select}
6565     $canv delete hover
6566     normalline
6567     unsel_reflist
6568     stopfinding
6569     if {$l < 0 || $l >= $numcommits} return
6570     set id [commitonrow $l]
6571     set targetid $id
6572     set targetrow $l
6573     set selectedline $l
6574     set currentid $id
6575     if {$lastscrollrows < $numcommits} {
6576         setcanvscroll
6577     }
6579     set y [expr {$canvy0 + $l * $linespc}]
6580     set ymax [lindex [$canv cget -scrollregion] 3]
6581     set ytop [expr {$y - $linespc - 1}]
6582     set ybot [expr {$y + $linespc + 1}]
6583     set wnow [$canv yview]
6584     set wtop [expr {[lindex $wnow 0] * $ymax}]
6585     set wbot [expr {[lindex $wnow 1] * $ymax}]
6586     set wh [expr {$wbot - $wtop}]
6587     set newtop $wtop
6588     if {$ytop < $wtop} {
6589         if {$ybot < $wtop} {
6590             set newtop [expr {$y - $wh / 2.0}]
6591         } else {
6592             set newtop $ytop
6593             if {$newtop > $wtop - $linespc} {
6594                 set newtop [expr {$wtop - $linespc}]
6595             }
6596         }
6597     } elseif {$ybot > $wbot} {
6598         if {$ytop > $wbot} {
6599             set newtop [expr {$y - $wh / 2.0}]
6600         } else {
6601             set newtop [expr {$ybot - $wh}]
6602             if {$newtop < $wtop + $linespc} {
6603                 set newtop [expr {$wtop + $linespc}]
6604             }
6605         }
6606     }
6607     if {$newtop != $wtop} {
6608         if {$newtop < 0} {
6609             set newtop 0
6610         }
6611         allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6612         drawvisible
6613     }
6615     make_secsel $id
6617     if {$isnew} {
6618         addtohistory [list selbyid $id]
6619     }
6621     $sha1entry delete 0 end
6622     $sha1entry insert 0 $id
6623     if {$autoselect} {
6624         $sha1entry selection from 0
6625         $sha1entry selection to end
6626     }
6627     rhighlight_sel $id
6629     $ctext conf -state normal
6630     clear_ctext
6631     set linknum 0
6632     if {![info exists commitinfo($id)]} {
6633         getcommit $id
6634     }
6635     set info $commitinfo($id)
6636     set date [formatdate [lindex $info 2]]
6637     $ctext insert end "[mc "Author"]: [lindex $info 1]  $date\n"
6638     set date [formatdate [lindex $info 4]]
6639     $ctext insert end "[mc "Committer"]: [lindex $info 3]  $date\n"
6640     if {[info exists idtags($id)]} {
6641         $ctext insert end [mc "Tags:"]
6642         foreach tag $idtags($id) {
6643             $ctext insert end " $tag"
6644         }
6645         $ctext insert end "\n"
6646     }
6648     set headers {}
6649     set olds $parents($curview,$id)
6650     if {[llength $olds] > 1} {
6651         set np 0
6652         foreach p $olds {
6653             if {$np >= $mergemax} {
6654                 set tag mmax
6655             } else {
6656                 set tag m$np
6657             }
6658             $ctext insert end "[mc "Parent"]: " $tag
6659             appendwithlinks [commit_descriptor $p] {}
6660             incr np
6661         }
6662     } else {
6663         foreach p $olds {
6664             append headers "[mc "Parent"]: [commit_descriptor $p]"
6665         }
6666     }
6668     foreach c $children($curview,$id) {
6669         append headers "[mc "Child"]:  [commit_descriptor $c]"
6670     }
6672     # make anything that looks like a SHA1 ID be a clickable link
6673     appendwithlinks $headers {}
6674     if {$showneartags} {
6675         if {![info exists allcommits]} {
6676             getallcommits
6677         }
6678         $ctext insert end "[mc "Branch"]: "
6679         $ctext mark set branch "end -1c"
6680         $ctext mark gravity branch left
6681         $ctext insert end "\n[mc "Follows"]: "
6682         $ctext mark set follows "end -1c"
6683         $ctext mark gravity follows left
6684         $ctext insert end "\n[mc "Precedes"]: "
6685         $ctext mark set precedes "end -1c"
6686         $ctext mark gravity precedes left
6687         $ctext insert end "\n"
6688         dispneartags 1
6689     }
6690     $ctext insert end "\n"
6691     set comment [lindex $info 5]
6692     if {[string first "\r" $comment] >= 0} {
6693         set comment [string map {"\r" "\n    "} $comment]
6694     }
6695     appendwithlinks $comment {comment}
6697     $ctext tag remove found 1.0 end
6698     $ctext conf -state disabled
6699     set commentend [$ctext index "end - 1c"]
6701     set jump_to_here $desired_loc
6702     init_flist [mc "Comments"]
6703     if {$cmitmode eq "tree"} {
6704         gettree $id
6705     } elseif {[llength $olds] <= 1} {
6706         startdiff $id
6707     } else {
6708         mergediff $id
6709     }
6712 proc selfirstline {} {
6713     unmarkmatches
6714     selectline 0 1
6717 proc sellastline {} {
6718     global numcommits
6719     unmarkmatches
6720     set l [expr {$numcommits - 1}]
6721     selectline $l 1
6724 proc selnextline {dir} {
6725     global selectedline
6726     focus .
6727     if {$selectedline eq {}} return
6728     set l [expr {$selectedline + $dir}]
6729     unmarkmatches
6730     selectline $l 1
6733 proc selnextpage {dir} {
6734     global canv linespc selectedline numcommits
6736     set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6737     if {$lpp < 1} {
6738         set lpp 1
6739     }
6740     allcanvs yview scroll [expr {$dir * $lpp}] units
6741     drawvisible
6742     if {$selectedline eq {}} return
6743     set l [expr {$selectedline + $dir * $lpp}]
6744     if {$l < 0} {
6745         set l 0
6746     } elseif {$l >= $numcommits} {
6747         set l [expr $numcommits - 1]
6748     }
6749     unmarkmatches
6750     selectline $l 1
6753 proc unselectline {} {
6754     global selectedline currentid
6756     set selectedline {}
6757     catch {unset currentid}
6758     allcanvs delete secsel
6759     rhighlight_none
6762 proc reselectline {} {
6763     global selectedline
6765     if {$selectedline ne {}} {
6766         selectline $selectedline 0
6767     }
6770 proc addtohistory {cmd} {
6771     global history historyindex curview
6773     set elt [list $curview $cmd]
6774     if {$historyindex > 0
6775         && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6776         return
6777     }
6779     if {$historyindex < [llength $history]} {
6780         set history [lreplace $history $historyindex end $elt]
6781     } else {
6782         lappend history $elt
6783     }
6784     incr historyindex
6785     if {$historyindex > 1} {
6786         .tf.bar.leftbut conf -state normal
6787     } else {
6788         .tf.bar.leftbut conf -state disabled
6789     }
6790     .tf.bar.rightbut conf -state disabled
6793 proc godo {elt} {
6794     global curview
6796     set view [lindex $elt 0]
6797     set cmd [lindex $elt 1]
6798     if {$curview != $view} {
6799         showview $view
6800     }
6801     eval $cmd
6804 proc goback {} {
6805     global history historyindex
6806     focus .
6808     if {$historyindex > 1} {
6809         incr historyindex -1
6810         godo [lindex $history [expr {$historyindex - 1}]]
6811         .tf.bar.rightbut conf -state normal
6812     }
6813     if {$historyindex <= 1} {
6814         .tf.bar.leftbut conf -state disabled
6815     }
6818 proc goforw {} {
6819     global history historyindex
6820     focus .
6822     if {$historyindex < [llength $history]} {
6823         set cmd [lindex $history $historyindex]
6824         incr historyindex
6825         godo $cmd
6826         .tf.bar.leftbut conf -state normal
6827     }
6828     if {$historyindex >= [llength $history]} {
6829         .tf.bar.rightbut conf -state disabled
6830     }
6833 proc gettree {id} {
6834     global treefilelist treeidlist diffids diffmergeid treepending
6835     global nullid nullid2
6837     set diffids $id
6838     catch {unset diffmergeid}
6839     if {![info exists treefilelist($id)]} {
6840         if {![info exists treepending]} {
6841             if {$id eq $nullid} {
6842                 set cmd [list | git ls-files]
6843             } elseif {$id eq $nullid2} {
6844                 set cmd [list | git ls-files --stage -t]
6845             } else {
6846                 set cmd [list | git ls-tree -r $id]
6847             }
6848             if {[catch {set gtf [open $cmd r]}]} {
6849                 return
6850             }
6851             set treepending $id
6852             set treefilelist($id) {}
6853             set treeidlist($id) {}
6854             fconfigure $gtf -blocking 0 -encoding binary
6855             filerun $gtf [list gettreeline $gtf $id]
6856         }
6857     } else {
6858         setfilelist $id
6859     }
6862 proc gettreeline {gtf id} {
6863     global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6865     set nl 0
6866     while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6867         if {$diffids eq $nullid} {
6868             set fname $line
6869         } else {
6870             set i [string first "\t" $line]
6871             if {$i < 0} continue
6872             set fname [string range $line [expr {$i+1}] end]
6873             set line [string range $line 0 [expr {$i-1}]]
6874             if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6875             set sha1 [lindex $line 2]
6876             lappend treeidlist($id) $sha1
6877         }
6878         if {[string index $fname 0] eq "\""} {
6879             set fname [lindex $fname 0]
6880         }
6881         set fname [encoding convertfrom $fname]
6882         lappend treefilelist($id) $fname
6883     }
6884     if {![eof $gtf]} {
6885         return [expr {$nl >= 1000? 2: 1}]
6886     }
6887     close $gtf
6888     unset treepending
6889     if {$cmitmode ne "tree"} {
6890         if {![info exists diffmergeid]} {
6891             gettreediffs $diffids
6892         }
6893     } elseif {$id ne $diffids} {
6894         gettree $diffids
6895     } else {
6896         setfilelist $id
6897     }
6898     return 0
6901 proc showfile {f} {
6902     global treefilelist treeidlist diffids nullid nullid2
6903     global ctext_file_names ctext_file_lines
6904     global ctext commentend
6906     set i [lsearch -exact $treefilelist($diffids) $f]
6907     if {$i < 0} {
6908         puts "oops, $f not in list for id $diffids"
6909         return
6910     }
6911     if {$diffids eq $nullid} {
6912         if {[catch {set bf [open $f r]} err]} {
6913             puts "oops, can't read $f: $err"
6914             return
6915         }
6916     } else {
6917         set blob [lindex $treeidlist($diffids) $i]
6918         if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6919             puts "oops, error reading blob $blob: $err"
6920             return
6921         }
6922     }
6923     fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6924     filerun $bf [list getblobline $bf $diffids]
6925     $ctext config -state normal
6926     clear_ctext $commentend
6927     lappend ctext_file_names $f
6928     lappend ctext_file_lines [lindex [split $commentend "."] 0]
6929     $ctext insert end "\n"
6930     $ctext insert end "$f\n" filesep
6931     $ctext config -state disabled
6932     $ctext yview $commentend
6933     settabs 0
6936 proc getblobline {bf id} {
6937     global diffids cmitmode ctext
6939     if {$id ne $diffids || $cmitmode ne "tree"} {
6940         catch {close $bf}
6941         return 0
6942     }
6943     $ctext config -state normal
6944     set nl 0
6945     while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6946         $ctext insert end "$line\n"
6947     }
6948     if {[eof $bf]} {
6949         global jump_to_here ctext_file_names commentend
6951         # delete last newline
6952         $ctext delete "end - 2c" "end - 1c"
6953         close $bf
6954         if {$jump_to_here ne {} &&
6955             [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6956             set lnum [expr {[lindex $jump_to_here 1] +
6957                             [lindex [split $commentend .] 0]}]
6958             mark_ctext_line $lnum
6959         }
6960         return 0
6961     }
6962     $ctext config -state disabled
6963     return [expr {$nl >= 1000? 2: 1}]
6966 proc mark_ctext_line {lnum} {
6967     global ctext markbgcolor
6969     $ctext tag delete omark
6970     $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
6971     $ctext tag conf omark -background $markbgcolor
6972     $ctext see $lnum.0
6975 proc mergediff {id} {
6976     global diffmergeid
6977     global diffids treediffs
6978     global parents curview
6980     set diffmergeid $id
6981     set diffids $id
6982     set treediffs($id) {}
6983     set np [llength $parents($curview,$id)]
6984     settabs $np
6985     getblobdiffs $id
6988 proc startdiff {ids} {
6989     global treediffs diffids treepending diffmergeid nullid nullid2
6991     settabs 1
6992     set diffids $ids
6993     catch {unset diffmergeid}
6994     if {![info exists treediffs($ids)] ||
6995         [lsearch -exact $ids $nullid] >= 0 ||
6996         [lsearch -exact $ids $nullid2] >= 0} {
6997         if {![info exists treepending]} {
6998             gettreediffs $ids
6999         }
7000     } else {
7001         addtocflist $ids
7002     }
7005 proc path_filter {filter name} {
7006     foreach p $filter {
7007         set l [string length $p]
7008         if {[string index $p end] eq "/"} {
7009             if {[string compare -length $l $p $name] == 0} {
7010                 return 1
7011             }
7012         } else {
7013             if {[string compare -length $l $p $name] == 0 &&
7014                 ([string length $name] == $l ||
7015                  [string index $name $l] eq "/")} {
7016                 return 1
7017             }
7018         }
7019     }
7020     return 0
7023 proc addtocflist {ids} {
7024     global treediffs
7026     add_flist $treediffs($ids)
7027     getblobdiffs $ids
7030 proc diffcmd {ids flags} {
7031     global nullid nullid2
7033     set i [lsearch -exact $ids $nullid]
7034     set j [lsearch -exact $ids $nullid2]
7035     if {$i >= 0} {
7036         if {[llength $ids] > 1 && $j < 0} {
7037             # comparing working directory with some specific revision
7038             set cmd [concat | git diff-index $flags]
7039             if {$i == 0} {
7040                 lappend cmd -R [lindex $ids 1]
7041             } else {
7042                 lappend cmd [lindex $ids 0]
7043             }
7044         } else {
7045             # comparing working directory with index
7046             set cmd [concat | git diff-files $flags]
7047             if {$j == 1} {
7048                 lappend cmd -R
7049             }
7050         }
7051     } elseif {$j >= 0} {
7052         set cmd [concat | git diff-index --cached $flags]
7053         if {[llength $ids] > 1} {
7054             # comparing index with specific revision
7055             if {$i == 0} {
7056                 lappend cmd -R [lindex $ids 1]
7057             } else {
7058                 lappend cmd [lindex $ids 0]
7059             }
7060         } else {
7061             # comparing index with HEAD
7062             lappend cmd HEAD
7063         }
7064     } else {
7065         set cmd [concat | git diff-tree -r $flags $ids]
7066     }
7067     return $cmd
7070 proc gettreediffs {ids} {
7071     global treediff treepending
7073     if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7075     set treepending $ids
7076     set treediff {}
7077     fconfigure $gdtf -blocking 0 -encoding binary
7078     filerun $gdtf [list gettreediffline $gdtf $ids]
7081 proc gettreediffline {gdtf ids} {
7082     global treediff treediffs treepending diffids diffmergeid
7083     global cmitmode vfilelimit curview limitdiffs perfile_attrs
7085     set nr 0
7086     set sublist {}
7087     set max 1000
7088     if {$perfile_attrs} {
7089         # cache_gitattr is slow, and even slower on win32 where we
7090         # have to invoke it for only about 30 paths at a time
7091         set max 500
7092         if {[tk windowingsystem] == "win32"} {
7093             set max 120
7094         }
7095     }
7096     while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7097         set i [string first "\t" $line]
7098         if {$i >= 0} {
7099             set file [string range $line [expr {$i+1}] end]
7100             if {[string index $file 0] eq "\""} {
7101                 set file [lindex $file 0]
7102             }
7103             set file [encoding convertfrom $file]
7104             if {$file ne [lindex $treediff end]} {
7105                 lappend treediff $file
7106                 lappend sublist $file
7107             }
7108         }
7109     }
7110     if {$perfile_attrs} {
7111         cache_gitattr encoding $sublist
7112     }
7113     if {![eof $gdtf]} {
7114         return [expr {$nr >= $max? 2: 1}]
7115     }
7116     close $gdtf
7117     if {$limitdiffs && $vfilelimit($curview) ne {}} {
7118         set flist {}
7119         foreach f $treediff {
7120             if {[path_filter $vfilelimit($curview) $f]} {
7121                 lappend flist $f
7122             }
7123         }
7124         set treediffs($ids) $flist
7125     } else {
7126         set treediffs($ids) $treediff
7127     }
7128     unset treepending
7129     if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7130         gettree $diffids
7131     } elseif {$ids != $diffids} {
7132         if {![info exists diffmergeid]} {
7133             gettreediffs $diffids
7134         }
7135     } else {
7136         addtocflist $ids
7137     }
7138     return 0
7141 # empty string or positive integer
7142 proc diffcontextvalidate {v} {
7143     return [regexp {^(|[1-9][0-9]*)$} $v]
7146 proc diffcontextchange {n1 n2 op} {
7147     global diffcontextstring diffcontext
7149     if {[string is integer -strict $diffcontextstring]} {
7150         if {$diffcontextstring > 0} {
7151             set diffcontext $diffcontextstring
7152             reselectline
7153         }
7154     }
7157 proc changeignorespace {} {
7158     reselectline
7161 proc getblobdiffs {ids} {
7162     global blobdifffd diffids env
7163     global diffinhdr treediffs
7164     global diffcontext
7165     global ignorespace
7166     global limitdiffs vfilelimit curview
7167     global diffencoding targetline diffnparents
7169     set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7170     if {$ignorespace} {
7171         append cmd " -w"
7172     }
7173     if {$limitdiffs && $vfilelimit($curview) ne {}} {
7174         set cmd [concat $cmd -- $vfilelimit($curview)]
7175     }
7176     if {[catch {set bdf [open $cmd r]} err]} {
7177         error_popup [mc "Error getting diffs: %s" $err]
7178         return
7179     }
7180     set targetline {}
7181     set diffnparents 0
7182     set diffinhdr 0
7183     set diffencoding [get_path_encoding {}]
7184     fconfigure $bdf -blocking 0 -encoding binary
7185     set blobdifffd($ids) $bdf
7186     filerun $bdf [list getblobdiffline $bdf $diffids]
7189 proc setinlist {var i val} {
7190     global $var
7192     while {[llength [set $var]] < $i} {
7193         lappend $var {}
7194     }
7195     if {[llength [set $var]] == $i} {
7196         lappend $var $val
7197     } else {
7198         lset $var $i $val
7199     }
7202 proc makediffhdr {fname ids} {
7203     global ctext curdiffstart treediffs diffencoding
7204     global ctext_file_names jump_to_here targetline diffline
7206     set fname [encoding convertfrom $fname]
7207     set diffencoding [get_path_encoding $fname]
7208     set i [lsearch -exact $treediffs($ids) $fname]
7209     if {$i >= 0} {
7210         setinlist difffilestart $i $curdiffstart
7211     }
7212     lset ctext_file_names end $fname
7213     set l [expr {(78 - [string length $fname]) / 2}]
7214     set pad [string range "----------------------------------------" 1 $l]
7215     $ctext insert $curdiffstart "$pad $fname $pad" filesep
7216     set targetline {}
7217     if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7218         set targetline [lindex $jump_to_here 1]
7219     }
7220     set diffline 0
7223 proc getblobdiffline {bdf ids} {
7224     global diffids blobdifffd ctext curdiffstart
7225     global diffnexthead diffnextnote difffilestart
7226     global ctext_file_names ctext_file_lines
7227     global diffinhdr treediffs mergemax diffnparents
7228     global diffencoding jump_to_here targetline diffline
7230     set nr 0
7231     $ctext conf -state normal
7232     while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7233         if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7234             close $bdf
7235             return 0
7236         }
7237         if {![string compare -length 5 "diff " $line]} {
7238             if {![regexp {^diff (--cc|--git) } $line m type]} {
7239                 set line [encoding convertfrom $line]
7240                 $ctext insert end "$line\n" hunksep
7241                 continue
7242             }
7243             # start of a new file
7244             set diffinhdr 1
7245             $ctext insert end "\n"
7246             set curdiffstart [$ctext index "end - 1c"]
7247             lappend ctext_file_names ""
7248             lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7249             $ctext insert end "\n" filesep
7251             if {$type eq "--cc"} {
7252                 # start of a new file in a merge diff
7253                 set fname [string range $line 10 end]
7254                 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7255                     lappend treediffs($ids) $fname
7256                     add_flist [list $fname]
7257                 }
7259             } else {
7260                 set line [string range $line 11 end]
7261                 # If the name hasn't changed the length will be odd,
7262                 # the middle char will be a space, and the two bits either
7263                 # side will be a/name and b/name, or "a/name" and "b/name".
7264                 # If the name has changed we'll get "rename from" and
7265                 # "rename to" or "copy from" and "copy to" lines following
7266                 # this, and we'll use them to get the filenames.
7267                 # This complexity is necessary because spaces in the
7268                 # filename(s) don't get escaped.
7269                 set l [string length $line]
7270                 set i [expr {$l / 2}]
7271                 if {!(($l & 1) && [string index $line $i] eq " " &&
7272                       [string range $line 2 [expr {$i - 1}]] eq \
7273                           [string range $line [expr {$i + 3}] end])} {
7274                     continue
7275                 }
7276                 # unescape if quoted and chop off the a/ from the front
7277                 if {[string index $line 0] eq "\""} {
7278                     set fname [string range [lindex $line 0] 2 end]
7279                 } else {
7280                     set fname [string range $line 2 [expr {$i - 1}]]
7281                 }
7282             }
7283             makediffhdr $fname $ids
7285         } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7286             set fname [encoding convertfrom [string range $line 16 end]]
7287             $ctext insert end "\n"
7288             set curdiffstart [$ctext index "end - 1c"]
7289             lappend ctext_file_names $fname
7290             lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7291             $ctext insert end "$line\n" filesep
7292             set i [lsearch -exact $treediffs($ids) $fname]
7293             if {$i >= 0} {
7294                 setinlist difffilestart $i $curdiffstart
7295             }
7297         } elseif {![string compare -length 2 "@@" $line]} {
7298             regexp {^@@+} $line ats
7299             set line [encoding convertfrom $diffencoding $line]
7300             $ctext insert end "$line\n" hunksep
7301             if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7302                 set diffline $nl
7303             }
7304             set diffnparents [expr {[string length $ats] - 1}]
7305             set diffinhdr 0
7307         } elseif {$diffinhdr} {
7308             if {![string compare -length 12 "rename from " $line]} {
7309                 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7310                 if {[string index $fname 0] eq "\""} {
7311                     set fname [lindex $fname 0]
7312                 }
7313                 set fname [encoding convertfrom $fname]
7314                 set i [lsearch -exact $treediffs($ids) $fname]
7315                 if {$i >= 0} {
7316                     setinlist difffilestart $i $curdiffstart
7317                 }
7318             } elseif {![string compare -length 10 $line "rename to "] ||
7319                       ![string compare -length 8 $line "copy to "]} {
7320                 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7321                 if {[string index $fname 0] eq "\""} {
7322                     set fname [lindex $fname 0]
7323                 }
7324                 makediffhdr $fname $ids
7325             } elseif {[string compare -length 3 $line "---"] == 0} {
7326                 # do nothing
7327                 continue
7328             } elseif {[string compare -length 3 $line "+++"] == 0} {
7329                 set diffinhdr 0
7330                 continue
7331             }
7332             $ctext insert end "$line\n" filesep
7334         } else {
7335             set line [encoding convertfrom $diffencoding $line]
7336             # parse the prefix - one ' ', '-' or '+' for each parent
7337             set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7338             set tag [expr {$diffnparents > 1? "m": "d"}]
7339             if {[string trim $prefix " -+"] eq {}} {
7340                 # prefix only has " ", "-" and "+" in it: normal diff line
7341                 set num [string first "-" $prefix]
7342                 if {$num >= 0} {
7343                     # removed line, first parent with line is $num
7344                     if {$num >= $mergemax} {
7345                         set num "max"
7346                     }
7347                     $ctext insert end "$line\n" $tag$num
7348                 } else {
7349                     set tags {}
7350                     if {[string first "+" $prefix] >= 0} {
7351                         # added line
7352                         lappend tags ${tag}result
7353                         if {$diffnparents > 1} {
7354                             set num [string first " " $prefix]
7355                             if {$num >= 0} {
7356                                 if {$num >= $mergemax} {
7357                                     set num "max"
7358                                 }
7359                                 lappend tags m$num
7360                             }
7361                         }
7362                     }
7363                     if {$targetline ne {}} {
7364                         if {$diffline == $targetline} {
7365                             set seehere [$ctext index "end - 1 chars"]
7366                             set targetline {}
7367                         } else {
7368                             incr diffline
7369                         }
7370                     }
7371                     $ctext insert end "$line\n" $tags
7372                 }
7373             } else {
7374                 # "\ No newline at end of file",
7375                 # or something else we don't recognize
7376                 $ctext insert end "$line\n" hunksep
7377             }
7378         }
7379     }
7380     if {[info exists seehere]} {
7381         mark_ctext_line [lindex [split $seehere .] 0]
7382     }
7383     $ctext conf -state disabled
7384     if {[eof $bdf]} {
7385         close $bdf
7386         return 0
7387     }
7388     return [expr {$nr >= 1000? 2: 1}]
7391 proc changediffdisp {} {
7392     global ctext diffelide
7394     $ctext tag conf d0 -elide [lindex $diffelide 0]
7395     $ctext tag conf dresult -elide [lindex $diffelide 1]
7398 proc highlightfile {loc cline} {
7399     global ctext cflist cflist_top
7401     $ctext yview $loc
7402     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7403     $cflist tag add highlight $cline.0 "$cline.0 lineend"
7404     $cflist see $cline.0
7405     set cflist_top $cline
7408 proc prevfile {} {
7409     global difffilestart ctext cmitmode
7411     if {$cmitmode eq "tree"} return
7412     set prev 0.0
7413     set prevline 1
7414     set here [$ctext index @0,0]
7415     foreach loc $difffilestart {
7416         if {[$ctext compare $loc >= $here]} {
7417             highlightfile $prev $prevline
7418             return
7419         }
7420         set prev $loc
7421         incr prevline
7422     }
7423     highlightfile $prev $prevline
7426 proc nextfile {} {
7427     global difffilestart ctext cmitmode
7429     if {$cmitmode eq "tree"} return
7430     set here [$ctext index @0,0]
7431     set line 1
7432     foreach loc $difffilestart {
7433         incr line
7434         if {[$ctext compare $loc > $here]} {
7435             highlightfile $loc $line
7436             return
7437         }
7438     }
7441 proc clear_ctext {{first 1.0}} {
7442     global ctext smarktop smarkbot
7443     global ctext_file_names ctext_file_lines
7444     global pendinglinks
7446     set l [lindex [split $first .] 0]
7447     if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7448         set smarktop $l
7449     }
7450     if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7451         set smarkbot $l
7452     }
7453     $ctext delete $first end
7454     if {$first eq "1.0"} {
7455         catch {unset pendinglinks}
7456     }
7457     set ctext_file_names {}
7458     set ctext_file_lines {}
7461 proc settabs {{firstab {}}} {
7462     global firsttabstop tabstop ctext have_tk85
7464     if {$firstab ne {} && $have_tk85} {
7465         set firsttabstop $firstab
7466     }
7467     set w [font measure textfont "0"]
7468     if {$firsttabstop != 0} {
7469         $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7470                                [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7471     } elseif {$have_tk85 || $tabstop != 8} {
7472         $ctext conf -tabs [expr {$tabstop * $w}]
7473     } else {
7474         $ctext conf -tabs {}
7475     }
7478 proc incrsearch {name ix op} {
7479     global ctext searchstring searchdirn
7481     $ctext tag remove found 1.0 end
7482     if {[catch {$ctext index anchor}]} {
7483         # no anchor set, use start of selection, or of visible area
7484         set sel [$ctext tag ranges sel]
7485         if {$sel ne {}} {
7486             $ctext mark set anchor [lindex $sel 0]
7487         } elseif {$searchdirn eq "-forwards"} {
7488             $ctext mark set anchor @0,0
7489         } else {
7490             $ctext mark set anchor @0,[winfo height $ctext]
7491         }
7492     }
7493     if {$searchstring ne {}} {
7494         set here [$ctext search $searchdirn -- $searchstring anchor]
7495         if {$here ne {}} {
7496             $ctext see $here
7497         }
7498         searchmarkvisible 1
7499     }
7502 proc dosearch {} {
7503     global sstring ctext searchstring searchdirn
7505     focus $sstring
7506     $sstring icursor end
7507     set searchdirn -forwards
7508     if {$searchstring ne {}} {
7509         set sel [$ctext tag ranges sel]
7510         if {$sel ne {}} {
7511             set start "[lindex $sel 0] + 1c"
7512         } elseif {[catch {set start [$ctext index anchor]}]} {
7513             set start "@0,0"
7514         }
7515         set match [$ctext search -count mlen -- $searchstring $start]
7516         $ctext tag remove sel 1.0 end
7517         if {$match eq {}} {
7518             bell
7519             return
7520         }
7521         $ctext see $match
7522         set mend "$match + $mlen c"
7523         $ctext tag add sel $match $mend
7524         $ctext mark unset anchor
7525     }
7528 proc dosearchback {} {
7529     global sstring ctext searchstring searchdirn
7531     focus $sstring
7532     $sstring icursor end
7533     set searchdirn -backwards
7534     if {$searchstring ne {}} {
7535         set sel [$ctext tag ranges sel]
7536         if {$sel ne {}} {
7537             set start [lindex $sel 0]
7538         } elseif {[catch {set start [$ctext index anchor]}]} {
7539             set start @0,[winfo height $ctext]
7540         }
7541         set match [$ctext search -backwards -count ml -- $searchstring $start]
7542         $ctext tag remove sel 1.0 end
7543         if {$match eq {}} {
7544             bell
7545             return
7546         }
7547         $ctext see $match
7548         set mend "$match + $ml c"
7549         $ctext tag add sel $match $mend
7550         $ctext mark unset anchor
7551     }
7554 proc searchmark {first last} {
7555     global ctext searchstring
7557     set mend $first.0
7558     while {1} {
7559         set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7560         if {$match eq {}} break
7561         set mend "$match + $mlen c"
7562         $ctext tag add found $match $mend
7563     }
7566 proc searchmarkvisible {doall} {
7567     global ctext smarktop smarkbot
7569     set topline [lindex [split [$ctext index @0,0] .] 0]
7570     set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7571     if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7572         # no overlap with previous
7573         searchmark $topline $botline
7574         set smarktop $topline
7575         set smarkbot $botline
7576     } else {
7577         if {$topline < $smarktop} {
7578             searchmark $topline [expr {$smarktop-1}]
7579             set smarktop $topline
7580         }
7581         if {$botline > $smarkbot} {
7582             searchmark [expr {$smarkbot+1}] $botline
7583             set smarkbot $botline
7584         }
7585     }
7588 proc scrolltext {f0 f1} {
7589     global searchstring
7591     .bleft.bottom.sb set $f0 $f1
7592     if {$searchstring ne {}} {
7593         searchmarkvisible 0
7594     }
7597 proc setcoords {} {
7598     global linespc charspc canvx0 canvy0
7599     global xspc1 xspc2 lthickness
7601     set linespc [font metrics mainfont -linespace]
7602     set charspc [font measure mainfont "m"]
7603     set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7604     set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7605     set lthickness [expr {int($linespc / 9) + 1}]
7606     set xspc1(0) $linespc
7607     set xspc2 $linespc
7610 proc redisplay {} {
7611     global canv
7612     global selectedline
7614     set ymax [lindex [$canv cget -scrollregion] 3]
7615     if {$ymax eq {} || $ymax == 0} return
7616     set span [$canv yview]
7617     clear_display
7618     setcanvscroll
7619     allcanvs yview moveto [lindex $span 0]
7620     drawvisible
7621     if {$selectedline ne {}} {
7622         selectline $selectedline 0
7623         allcanvs yview moveto [lindex $span 0]
7624     }
7627 proc parsefont {f n} {
7628     global fontattr
7630     set fontattr($f,family) [lindex $n 0]
7631     set s [lindex $n 1]
7632     if {$s eq {} || $s == 0} {
7633         set s 10
7634     } elseif {$s < 0} {
7635         set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7636     }
7637     set fontattr($f,size) $s
7638     set fontattr($f,weight) normal
7639     set fontattr($f,slant) roman
7640     foreach style [lrange $n 2 end] {
7641         switch -- $style {
7642             "normal" -
7643             "bold"   {set fontattr($f,weight) $style}
7644             "roman" -
7645             "italic" {set fontattr($f,slant) $style}
7646         }
7647     }
7650 proc fontflags {f {isbold 0}} {
7651     global fontattr
7653     return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7654                 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7655                 -slant $fontattr($f,slant)]
7658 proc fontname {f} {
7659     global fontattr
7661     set n [list $fontattr($f,family) $fontattr($f,size)]
7662     if {$fontattr($f,weight) eq "bold"} {
7663         lappend n "bold"
7664     }
7665     if {$fontattr($f,slant) eq "italic"} {
7666         lappend n "italic"
7667     }
7668     return $n
7671 proc incrfont {inc} {
7672     global mainfont textfont ctext canv cflist showrefstop
7673     global stopped entries fontattr
7675     unmarkmatches
7676     set s $fontattr(mainfont,size)
7677     incr s $inc
7678     if {$s < 1} {
7679         set s 1
7680     }
7681     set fontattr(mainfont,size) $s
7682     font config mainfont -size $s
7683     font config mainfontbold -size $s
7684     set mainfont [fontname mainfont]
7685     set s $fontattr(textfont,size)
7686     incr s $inc
7687     if {$s < 1} {
7688         set s 1
7689     }
7690     set fontattr(textfont,size) $s
7691     font config textfont -size $s
7692     font config textfontbold -size $s
7693     set textfont [fontname textfont]
7694     setcoords
7695     settabs
7696     redisplay
7699 proc clearsha1 {} {
7700     global sha1entry sha1string
7701     if {[string length $sha1string] == 40} {
7702         $sha1entry delete 0 end
7703     }
7706 proc sha1change {n1 n2 op} {
7707     global sha1string currentid sha1but
7708     if {$sha1string == {}
7709         || ([info exists currentid] && $sha1string == $currentid)} {
7710         set state disabled
7711     } else {
7712         set state normal
7713     }
7714     if {[$sha1but cget -state] == $state} return
7715     if {$state == "normal"} {
7716         $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7717     } else {
7718         $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7719     }
7722 proc gotocommit {} {
7723     global sha1string tagids headids curview varcid
7725     if {$sha1string == {}
7726         || ([info exists currentid] && $sha1string == $currentid)} return
7727     if {[info exists tagids($sha1string)]} {
7728         set id $tagids($sha1string)
7729     } elseif {[info exists headids($sha1string)]} {
7730         set id $headids($sha1string)
7731     } else {
7732         set id [string tolower $sha1string]
7733         if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7734             set matches [longid $id]
7735             if {$matches ne {}} {
7736                 if {[llength $matches] > 1} {
7737                     error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7738                     return
7739                 }
7740                 set id [lindex $matches 0]
7741             }
7742         }
7743     }
7744     if {[commitinview $id $curview]} {
7745         selectline [rowofcommit $id] 1
7746         return
7747     }
7748     if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7749         set msg [mc "SHA1 id %s is not known" $sha1string]
7750     } else {
7751         set msg [mc "Tag/Head %s is not known" $sha1string]
7752     }
7753     error_popup $msg
7756 proc lineenter {x y id} {
7757     global hoverx hovery hoverid hovertimer
7758     global commitinfo canv
7760     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7761     set hoverx $x
7762     set hovery $y
7763     set hoverid $id
7764     if {[info exists hovertimer]} {
7765         after cancel $hovertimer
7766     }
7767     set hovertimer [after 500 linehover]
7768     $canv delete hover
7771 proc linemotion {x y id} {
7772     global hoverx hovery hoverid hovertimer
7774     if {[info exists hoverid] && $id == $hoverid} {
7775         set hoverx $x
7776         set hovery $y
7777         if {[info exists hovertimer]} {
7778             after cancel $hovertimer
7779         }
7780         set hovertimer [after 500 linehover]
7781     }
7784 proc lineleave {id} {
7785     global hoverid hovertimer canv
7787     if {[info exists hoverid] && $id == $hoverid} {
7788         $canv delete hover
7789         if {[info exists hovertimer]} {
7790             after cancel $hovertimer
7791             unset hovertimer
7792         }
7793         unset hoverid
7794     }
7797 proc linehover {} {
7798     global hoverx hovery hoverid hovertimer
7799     global canv linespc lthickness
7800     global commitinfo
7802     set text [lindex $commitinfo($hoverid) 0]
7803     set ymax [lindex [$canv cget -scrollregion] 3]
7804     if {$ymax == {}} return
7805     set yfrac [lindex [$canv yview] 0]
7806     set x [expr {$hoverx + 2 * $linespc}]
7807     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7808     set x0 [expr {$x - 2 * $lthickness}]
7809     set y0 [expr {$y - 2 * $lthickness}]
7810     set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7811     set y1 [expr {$y + $linespc + 2 * $lthickness}]
7812     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7813                -fill \#ffff80 -outline black -width 1 -tags hover]
7814     $canv raise $t
7815     set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7816                -font mainfont]
7817     $canv raise $t
7820 proc clickisonarrow {id y} {
7821     global lthickness
7823     set ranges [rowranges $id]
7824     set thresh [expr {2 * $lthickness + 6}]
7825     set n [expr {[llength $ranges] - 1}]
7826     for {set i 1} {$i < $n} {incr i} {
7827         set row [lindex $ranges $i]
7828         if {abs([yc $row] - $y) < $thresh} {
7829             return $i
7830         }
7831     }
7832     return {}
7835 proc arrowjump {id n y} {
7836     global canv
7838     # 1 <-> 2, 3 <-> 4, etc...
7839     set n [expr {(($n - 1) ^ 1) + 1}]
7840     set row [lindex [rowranges $id] $n]
7841     set yt [yc $row]
7842     set ymax [lindex [$canv cget -scrollregion] 3]
7843     if {$ymax eq {} || $ymax <= 0} return
7844     set view [$canv yview]
7845     set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7846     set yfrac [expr {$yt / $ymax - $yspan / 2}]
7847     if {$yfrac < 0} {
7848         set yfrac 0
7849     }
7850     allcanvs yview moveto $yfrac
7853 proc lineclick {x y id isnew} {
7854     global ctext commitinfo children canv thickerline curview
7856     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7857     unmarkmatches
7858     unselectline
7859     normalline
7860     $canv delete hover
7861     # draw this line thicker than normal
7862     set thickerline $id
7863     drawlines $id
7864     if {$isnew} {
7865         set ymax [lindex [$canv cget -scrollregion] 3]
7866         if {$ymax eq {}} return
7867         set yfrac [lindex [$canv yview] 0]
7868         set y [expr {$y + $yfrac * $ymax}]
7869     }
7870     set dirn [clickisonarrow $id $y]
7871     if {$dirn ne {}} {
7872         arrowjump $id $dirn $y
7873         return
7874     }
7876     if {$isnew} {
7877         addtohistory [list lineclick $x $y $id 0]
7878     }
7879     # fill the details pane with info about this line
7880     $ctext conf -state normal
7881     clear_ctext
7882     settabs 0
7883     $ctext insert end "[mc "Parent"]:\t"
7884     $ctext insert end $id link0
7885     setlink $id link0
7886     set info $commitinfo($id)
7887     $ctext insert end "\n\t[lindex $info 0]\n"
7888     $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7889     set date [formatdate [lindex $info 2]]
7890     $ctext insert end "\t[mc "Date"]:\t$date\n"
7891     set kids $children($curview,$id)
7892     if {$kids ne {}} {
7893         $ctext insert end "\n[mc "Children"]:"
7894         set i 0
7895         foreach child $kids {
7896             incr i
7897             if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7898             set info $commitinfo($child)
7899             $ctext insert end "\n\t"
7900             $ctext insert end $child link$i
7901             setlink $child link$i
7902             $ctext insert end "\n\t[lindex $info 0]"
7903             $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7904             set date [formatdate [lindex $info 2]]
7905             $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7906         }
7907     }
7908     $ctext conf -state disabled
7909     init_flist {}
7912 proc normalline {} {
7913     global thickerline
7914     if {[info exists thickerline]} {
7915         set id $thickerline
7916         unset thickerline
7917         drawlines $id
7918     }
7921 proc selbyid {id} {
7922     global curview
7923     if {[commitinview $id $curview]} {
7924         selectline [rowofcommit $id] 1
7925     }
7928 proc mstime {} {
7929     global startmstime
7930     if {![info exists startmstime]} {
7931         set startmstime [clock clicks -milliseconds]
7932     }
7933     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7936 proc rowmenu {x y id} {
7937     global rowctxmenu selectedline rowmenuid curview
7938     global nullid nullid2 fakerowmenu mainhead
7940     stopfinding
7941     set rowmenuid $id
7942     if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7943         set state disabled
7944     } else {
7945         set state normal
7946     }
7947     if {$id ne $nullid && $id ne $nullid2} {
7948         set menu $rowctxmenu
7949         if {$mainhead ne {}} {
7950             $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7951         } else {
7952             $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7953         }
7954     } else {
7955         set menu $fakerowmenu
7956     }
7957     $menu entryconfigure [mca "Diff this -> selected"] -state $state
7958     $menu entryconfigure [mca "Diff selected -> this"] -state $state
7959     $menu entryconfigure [mca "Make patch"] -state $state
7960     tk_popup $menu $x $y
7963 proc diffvssel {dirn} {
7964     global rowmenuid selectedline
7966     if {$selectedline eq {}} return
7967     if {$dirn} {
7968         set oldid [commitonrow $selectedline]
7969         set newid $rowmenuid
7970     } else {
7971         set oldid $rowmenuid
7972         set newid [commitonrow $selectedline]
7973     }
7974     addtohistory [list doseldiff $oldid $newid]
7975     doseldiff $oldid $newid
7978 proc doseldiff {oldid newid} {
7979     global ctext
7980     global commitinfo
7982     $ctext conf -state normal
7983     clear_ctext
7984     init_flist [mc "Top"]
7985     $ctext insert end "[mc "From"] "
7986     $ctext insert end $oldid link0
7987     setlink $oldid link0
7988     $ctext insert end "\n     "
7989     $ctext insert end [lindex $commitinfo($oldid) 0]
7990     $ctext insert end "\n\n[mc "To"]   "
7991     $ctext insert end $newid link1
7992     setlink $newid link1
7993     $ctext insert end "\n     "
7994     $ctext insert end [lindex $commitinfo($newid) 0]
7995     $ctext insert end "\n"
7996     $ctext conf -state disabled
7997     $ctext tag remove found 1.0 end
7998     startdiff [list $oldid $newid]
8001 proc mkpatch {} {
8002     global rowmenuid currentid commitinfo patchtop patchnum
8004     if {![info exists currentid]} return
8005     set oldid $currentid
8006     set oldhead [lindex $commitinfo($oldid) 0]
8007     set newid $rowmenuid
8008     set newhead [lindex $commitinfo($newid) 0]
8009     set top .patch
8010     set patchtop $top
8011     catch {destroy $top}
8012     toplevel $top
8013     make_transient $top .
8014     label $top.title -text [mc "Generate patch"]
8015     grid $top.title - -pady 10
8016     label $top.from -text [mc "From:"]
8017     entry $top.fromsha1 -width 40 -relief flat
8018     $top.fromsha1 insert 0 $oldid
8019     $top.fromsha1 conf -state readonly
8020     grid $top.from $top.fromsha1 -sticky w
8021     entry $top.fromhead -width 60 -relief flat
8022     $top.fromhead insert 0 $oldhead
8023     $top.fromhead conf -state readonly
8024     grid x $top.fromhead -sticky w
8025     label $top.to -text [mc "To:"]
8026     entry $top.tosha1 -width 40 -relief flat
8027     $top.tosha1 insert 0 $newid
8028     $top.tosha1 conf -state readonly
8029     grid $top.to $top.tosha1 -sticky w
8030     entry $top.tohead -width 60 -relief flat
8031     $top.tohead insert 0 $newhead
8032     $top.tohead conf -state readonly
8033     grid x $top.tohead -sticky w
8034     button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8035     grid $top.rev x -pady 10
8036     label $top.flab -text [mc "Output file:"]
8037     entry $top.fname -width 60
8038     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8039     incr patchnum
8040     grid $top.flab $top.fname -sticky w
8041     frame $top.buts
8042     button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8043     button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8044     bind $top <Key-Return> mkpatchgo
8045     bind $top <Key-Escape> mkpatchcan
8046     grid $top.buts.gen $top.buts.can
8047     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8048     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8049     grid $top.buts - -pady 10 -sticky ew
8050     focus $top.fname
8053 proc mkpatchrev {} {
8054     global patchtop
8056     set oldid [$patchtop.fromsha1 get]
8057     set oldhead [$patchtop.fromhead get]
8058     set newid [$patchtop.tosha1 get]
8059     set newhead [$patchtop.tohead get]
8060     foreach e [list fromsha1 fromhead tosha1 tohead] \
8061             v [list $newid $newhead $oldid $oldhead] {
8062         $patchtop.$e conf -state normal
8063         $patchtop.$e delete 0 end
8064         $patchtop.$e insert 0 $v
8065         $patchtop.$e conf -state readonly
8066     }
8069 proc mkpatchgo {} {
8070     global patchtop nullid nullid2
8072     set oldid [$patchtop.fromsha1 get]
8073     set newid [$patchtop.tosha1 get]
8074     set fname [$patchtop.fname get]
8075     set cmd [diffcmd [list $oldid $newid] -p]
8076     # trim off the initial "|"
8077     set cmd [lrange $cmd 1 end]
8078     lappend cmd >$fname &
8079     if {[catch {eval exec $cmd} err]} {
8080         error_popup "[mc "Error creating patch:"] $err" $patchtop
8081     }
8082     catch {destroy $patchtop}
8083     unset patchtop
8086 proc mkpatchcan {} {
8087     global patchtop
8089     catch {destroy $patchtop}
8090     unset patchtop
8093 proc mktag {} {
8094     global rowmenuid mktagtop commitinfo
8096     set top .maketag
8097     set mktagtop $top
8098     catch {destroy $top}
8099     toplevel $top
8100     make_transient $top .
8101     label $top.title -text [mc "Create tag"]
8102     grid $top.title - -pady 10
8103     label $top.id -text [mc "ID:"]
8104     entry $top.sha1 -width 40 -relief flat
8105     $top.sha1 insert 0 $rowmenuid
8106     $top.sha1 conf -state readonly
8107     grid $top.id $top.sha1 -sticky w
8108     entry $top.head -width 60 -relief flat
8109     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8110     $top.head conf -state readonly
8111     grid x $top.head -sticky w
8112     label $top.tlab -text [mc "Tag name:"]
8113     entry $top.tag -width 60
8114     grid $top.tlab $top.tag -sticky w
8115     frame $top.buts
8116     button $top.buts.gen -text [mc "Create"] -command mktaggo
8117     button $top.buts.can -text [mc "Cancel"] -command mktagcan
8118     bind $top <Key-Return> mktaggo
8119     bind $top <Key-Escape> mktagcan
8120     grid $top.buts.gen $top.buts.can
8121     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8122     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8123     grid $top.buts - -pady 10 -sticky ew
8124     focus $top.tag
8127 proc domktag {} {
8128     global mktagtop env tagids idtags
8130     set id [$mktagtop.sha1 get]
8131     set tag [$mktagtop.tag get]
8132     if {$tag == {}} {
8133         error_popup [mc "No tag name specified"] $mktagtop
8134         return 0
8135     }
8136     if {[info exists tagids($tag)]} {
8137         error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8138         return 0
8139     }
8140     if {[catch {
8141         exec git tag $tag $id
8142     } err]} {
8143         error_popup "[mc "Error creating tag:"] $err" $mktagtop
8144         return 0
8145     }
8147     set tagids($tag) $id
8148     lappend idtags($id) $tag
8149     redrawtags $id
8150     addedtag $id
8151     dispneartags 0
8152     run refill_reflist
8153     return 1
8156 proc redrawtags {id} {
8157     global canv linehtag idpos currentid curview cmitlisted
8158     global canvxmax iddrawn circleitem mainheadid circlecolors
8160     if {![commitinview $id $curview]} return
8161     if {![info exists iddrawn($id)]} return
8162     set row [rowofcommit $id]
8163     if {$id eq $mainheadid} {
8164         set ofill yellow
8165     } else {
8166         set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8167     }
8168     $canv itemconf $circleitem($row) -fill $ofill
8169     $canv delete tag.$id
8170     set xt [eval drawtags $id $idpos($id)]
8171     $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8172     set text [$canv itemcget $linehtag($id) -text]
8173     set font [$canv itemcget $linehtag($id) -font]
8174     set xr [expr {$xt + [font measure $font $text]}]
8175     if {$xr > $canvxmax} {
8176         set canvxmax $xr
8177         setcanvscroll
8178     }
8179     if {[info exists currentid] && $currentid == $id} {
8180         make_secsel $id
8181     }
8184 proc mktagcan {} {
8185     global mktagtop
8187     catch {destroy $mktagtop}
8188     unset mktagtop
8191 proc mktaggo {} {
8192     if {![domktag]} return
8193     mktagcan
8196 proc writecommit {} {
8197     global rowmenuid wrcomtop commitinfo wrcomcmd
8199     set top .writecommit
8200     set wrcomtop $top
8201     catch {destroy $top}
8202     toplevel $top
8203     make_transient $top .
8204     label $top.title -text [mc "Write commit to file"]
8205     grid $top.title - -pady 10
8206     label $top.id -text [mc "ID:"]
8207     entry $top.sha1 -width 40 -relief flat
8208     $top.sha1 insert 0 $rowmenuid
8209     $top.sha1 conf -state readonly
8210     grid $top.id $top.sha1 -sticky w
8211     entry $top.head -width 60 -relief flat
8212     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8213     $top.head conf -state readonly
8214     grid x $top.head -sticky w
8215     label $top.clab -text [mc "Command:"]
8216     entry $top.cmd -width 60 -textvariable wrcomcmd
8217     grid $top.clab $top.cmd -sticky w -pady 10
8218     label $top.flab -text [mc "Output file:"]
8219     entry $top.fname -width 60
8220     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8221     grid $top.flab $top.fname -sticky w
8222     frame $top.buts
8223     button $top.buts.gen -text [mc "Write"] -command wrcomgo
8224     button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8225     bind $top <Key-Return> wrcomgo
8226     bind $top <Key-Escape> wrcomcan
8227     grid $top.buts.gen $top.buts.can
8228     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8229     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8230     grid $top.buts - -pady 10 -sticky ew
8231     focus $top.fname
8234 proc wrcomgo {} {
8235     global wrcomtop
8237     set id [$wrcomtop.sha1 get]
8238     set cmd "echo $id | [$wrcomtop.cmd get]"
8239     set fname [$wrcomtop.fname get]
8240     if {[catch {exec sh -c $cmd >$fname &} err]} {
8241         error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8242     }
8243     catch {destroy $wrcomtop}
8244     unset wrcomtop
8247 proc wrcomcan {} {
8248     global wrcomtop
8250     catch {destroy $wrcomtop}
8251     unset wrcomtop
8254 proc mkbranch {} {
8255     global rowmenuid mkbrtop
8257     set top .makebranch
8258     catch {destroy $top}
8259     toplevel $top
8260     make_transient $top .
8261     label $top.title -text [mc "Create new branch"]
8262     grid $top.title - -pady 10
8263     label $top.id -text [mc "ID:"]
8264     entry $top.sha1 -width 40 -relief flat
8265     $top.sha1 insert 0 $rowmenuid
8266     $top.sha1 conf -state readonly
8267     grid $top.id $top.sha1 -sticky w
8268     label $top.nlab -text [mc "Name:"]
8269     entry $top.name -width 40
8270     grid $top.nlab $top.name -sticky w
8271     frame $top.buts
8272     button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8273     button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8274     bind $top <Key-Return> [list mkbrgo $top]
8275     bind $top <Key-Escape> "catch {destroy $top}"
8276     grid $top.buts.go $top.buts.can
8277     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8278     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8279     grid $top.buts - -pady 10 -sticky ew
8280     focus $top.name
8283 proc mkbrgo {top} {
8284     global headids idheads
8286     set name [$top.name get]
8287     set id [$top.sha1 get]
8288     set cmdargs {}
8289     set old_id {}
8290     if {$name eq {}} {
8291         error_popup [mc "Please specify a name for the new branch"] $top
8292         return
8293     }
8294     if {[info exists headids($name)]} {
8295         if {![confirm_popup [mc \
8296                 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8297             return
8298         }
8299         set old_id $headids($name)
8300         lappend cmdargs -f
8301     }
8302     catch {destroy $top}
8303     lappend cmdargs $name $id
8304     nowbusy newbranch
8305     update
8306     if {[catch {
8307         eval exec git branch $cmdargs
8308     } err]} {
8309         notbusy newbranch
8310         error_popup $err
8311     } else {
8312         notbusy newbranch
8313         if {$old_id ne {}} {
8314             movehead $id $name
8315             movedhead $id $name
8316             redrawtags $old_id
8317             redrawtags $id
8318         } else {
8319             set headids($name) $id
8320             lappend idheads($id) $name
8321             addedhead $id $name
8322             redrawtags $id
8323         }
8324         dispneartags 0
8325         run refill_reflist
8326     }
8329 proc exec_citool {tool_args {baseid {}}} {
8330     global commitinfo env
8332     set save_env [array get env GIT_AUTHOR_*]
8334     if {$baseid ne {}} {
8335         if {![info exists commitinfo($baseid)]} {
8336             getcommit $baseid
8337         }
8338         set author [lindex $commitinfo($baseid) 1]
8339         set date [lindex $commitinfo($baseid) 2]
8340         if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8341                     $author author name email]
8342             && $date ne {}} {
8343             set env(GIT_AUTHOR_NAME) $name
8344             set env(GIT_AUTHOR_EMAIL) $email
8345             set env(GIT_AUTHOR_DATE) $date
8346         }
8347     }
8349     eval exec git citool $tool_args &
8351     array unset env GIT_AUTHOR_*
8352     array set env $save_env
8355 proc cherrypick {} {
8356     global rowmenuid curview
8357     global mainhead mainheadid
8359     set oldhead [exec git rev-parse HEAD]
8360     set dheads [descheads $rowmenuid]
8361     if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8362         set ok [confirm_popup [mc "Commit %s is already\
8363                 included in branch %s -- really re-apply it?" \
8364                                    [string range $rowmenuid 0 7] $mainhead]]
8365         if {!$ok} return
8366     }
8367     nowbusy cherrypick [mc "Cherry-picking"]
8368     update
8369     # Unfortunately git-cherry-pick writes stuff to stderr even when
8370     # no error occurs, and exec takes that as an indication of error...
8371     if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8372         notbusy cherrypick
8373         if {[regexp -line \
8374                  {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8375                  $err msg fname]} {
8376             error_popup [mc "Cherry-pick failed because of local changes\
8377                         to file '%s'.\nPlease commit, reset or stash\
8378                         your changes and try again." $fname]
8379         } elseif {[regexp -line \
8380                        {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8381                        $err]} {
8382             if {[confirm_popup [mc "Cherry-pick failed because of merge\
8383                         conflict.\nDo you wish to run git citool to\
8384                         resolve it?"]]} {
8385                 # Force citool to read MERGE_MSG
8386                 file delete [file join [gitdir] "GITGUI_MSG"]
8387                 exec_citool {} $rowmenuid
8388             }
8389         } else {
8390             error_popup $err
8391         }
8392         run updatecommits
8393         return
8394     }
8395     set newhead [exec git rev-parse HEAD]
8396     if {$newhead eq $oldhead} {
8397         notbusy cherrypick
8398         error_popup [mc "No changes committed"]
8399         return
8400     }
8401     addnewchild $newhead $oldhead
8402     if {[commitinview $oldhead $curview]} {
8403         # XXX this isn't right if we have a path limit...
8404         insertrow $newhead $oldhead $curview
8405         if {$mainhead ne {}} {
8406             movehead $newhead $mainhead
8407             movedhead $newhead $mainhead
8408         }
8409         set mainheadid $newhead
8410         redrawtags $oldhead
8411         redrawtags $newhead
8412         selbyid $newhead
8413     }
8414     notbusy cherrypick
8417 proc resethead {} {
8418     global mainhead rowmenuid confirm_ok resettype
8420     set confirm_ok 0
8421     set w ".confirmreset"
8422     toplevel $w
8423     make_transient $w .
8424     wm title $w [mc "Confirm reset"]
8425     message $w.m -text \
8426         [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8427         -justify center -aspect 1000
8428     pack $w.m -side top -fill x -padx 20 -pady 20
8429     frame $w.f -relief sunken -border 2
8430     message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8431     grid $w.f.rt -sticky w
8432     set resettype mixed
8433     radiobutton $w.f.soft -value soft -variable resettype -justify left \
8434         -text [mc "Soft: Leave working tree and index untouched"]
8435     grid $w.f.soft -sticky w
8436     radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8437         -text [mc "Mixed: Leave working tree untouched, reset index"]
8438     grid $w.f.mixed -sticky w
8439     radiobutton $w.f.hard -value hard -variable resettype -justify left \
8440         -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8441     grid $w.f.hard -sticky w
8442     pack $w.f -side top -fill x
8443     button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8444     pack $w.ok -side left -fill x -padx 20 -pady 20
8445     button $w.cancel -text [mc Cancel] -command "destroy $w"
8446     bind $w <Key-Escape> [list destroy $w]
8447     pack $w.cancel -side right -fill x -padx 20 -pady 20
8448     bind $w <Visibility> "grab $w; focus $w"
8449     tkwait window $w
8450     if {!$confirm_ok} return
8451     if {[catch {set fd [open \
8452             [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8453         error_popup $err
8454     } else {
8455         dohidelocalchanges
8456         filerun $fd [list readresetstat $fd]
8457         nowbusy reset [mc "Resetting"]
8458         selbyid $rowmenuid
8459     }
8462 proc readresetstat {fd} {
8463     global mainhead mainheadid showlocalchanges rprogcoord
8465     if {[gets $fd line] >= 0} {
8466         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8467             set rprogcoord [expr {1.0 * $m / $n}]
8468             adjustprogress
8469         }
8470         return 1
8471     }
8472     set rprogcoord 0
8473     adjustprogress
8474     notbusy reset
8475     if {[catch {close $fd} err]} {
8476         error_popup $err
8477     }
8478     set oldhead $mainheadid
8479     set newhead [exec git rev-parse HEAD]
8480     if {$newhead ne $oldhead} {
8481         movehead $newhead $mainhead
8482         movedhead $newhead $mainhead
8483         set mainheadid $newhead
8484         redrawtags $oldhead
8485         redrawtags $newhead
8486     }
8487     if {$showlocalchanges} {
8488         doshowlocalchanges
8489     }
8490     return 0
8493 # context menu for a head
8494 proc headmenu {x y id head} {
8495     global headmenuid headmenuhead headctxmenu mainhead
8497     stopfinding
8498     set headmenuid $id
8499     set headmenuhead $head
8500     set state normal
8501     if {$head eq $mainhead} {
8502         set state disabled
8503     }
8504     $headctxmenu entryconfigure 0 -state $state
8505     $headctxmenu entryconfigure 1 -state $state
8506     tk_popup $headctxmenu $x $y
8509 proc cobranch {} {
8510     global headmenuid headmenuhead headids
8511     global showlocalchanges
8513     # check the tree is clean first??
8514     nowbusy checkout [mc "Checking out"]
8515     update
8516     dohidelocalchanges
8517     if {[catch {
8518         set fd [open [list | git checkout $headmenuhead 2>@1] r]
8519     } err]} {
8520         notbusy checkout
8521         error_popup $err
8522         if {$showlocalchanges} {
8523             dodiffindex
8524         }
8525     } else {
8526         filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8527     }
8530 proc readcheckoutstat {fd newhead newheadid} {
8531     global mainhead mainheadid headids showlocalchanges progresscoords
8532     global viewmainheadid curview
8534     if {[gets $fd line] >= 0} {
8535         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8536             set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8537             adjustprogress
8538         }
8539         return 1
8540     }
8541     set progresscoords {0 0}
8542     adjustprogress
8543     notbusy checkout
8544     if {[catch {close $fd} err]} {
8545         error_popup $err
8546     }
8547     set oldmainid $mainheadid
8548     set mainhead $newhead
8549     set mainheadid $newheadid
8550     set viewmainheadid($curview) $newheadid
8551     redrawtags $oldmainid
8552     redrawtags $newheadid
8553     selbyid $newheadid
8554     if {$showlocalchanges} {
8555         dodiffindex
8556     }
8559 proc rmbranch {} {
8560     global headmenuid headmenuhead mainhead
8561     global idheads
8563     set head $headmenuhead
8564     set id $headmenuid
8565     # this check shouldn't be needed any more...
8566     if {$head eq $mainhead} {
8567         error_popup [mc "Cannot delete the currently checked-out branch"]
8568         return
8569     }
8570     set dheads [descheads $id]
8571     if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8572         # the stuff on this branch isn't on any other branch
8573         if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8574                         branch.\nReally delete branch %s?" $head $head]]} return
8575     }
8576     nowbusy rmbranch
8577     update
8578     if {[catch {exec git branch -D $head} err]} {
8579         notbusy rmbranch
8580         error_popup $err
8581         return
8582     }
8583     removehead $id $head
8584     removedhead $id $head
8585     redrawtags $id
8586     notbusy rmbranch
8587     dispneartags 0
8588     run refill_reflist
8591 # Display a list of tags and heads
8592 proc showrefs {} {
8593     global showrefstop bgcolor fgcolor selectbgcolor
8594     global bglist fglist reflistfilter reflist maincursor
8596     set top .showrefs
8597     set showrefstop $top
8598     if {[winfo exists $top]} {
8599         raise $top
8600         refill_reflist
8601         return
8602     }
8603     toplevel $top
8604     wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8605     make_transient $top .
8606     text $top.list -background $bgcolor -foreground $fgcolor \
8607         -selectbackground $selectbgcolor -font mainfont \
8608         -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8609         -width 30 -height 20 -cursor $maincursor \
8610         -spacing1 1 -spacing3 1 -state disabled
8611     $top.list tag configure highlight -background $selectbgcolor
8612     lappend bglist $top.list
8613     lappend fglist $top.list
8614     scrollbar $top.ysb -command "$top.list yview" -orient vertical
8615     scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8616     grid $top.list $top.ysb -sticky nsew
8617     grid $top.xsb x -sticky ew
8618     frame $top.f
8619     label $top.f.l -text "[mc "Filter"]: "
8620     entry $top.f.e -width 20 -textvariable reflistfilter
8621     set reflistfilter "*"
8622     trace add variable reflistfilter write reflistfilter_change
8623     pack $top.f.e -side right -fill x -expand 1
8624     pack $top.f.l -side left
8625     grid $top.f - -sticky ew -pady 2
8626     button $top.close -command [list destroy $top] -text [mc "Close"]
8627     bind $top <Key-Escape> [list destroy $top]
8628     grid $top.close -
8629     grid columnconfigure $top 0 -weight 1
8630     grid rowconfigure $top 0 -weight 1
8631     bind $top.list <1> {break}
8632     bind $top.list <B1-Motion> {break}
8633     bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8634     set reflist {}
8635     refill_reflist
8638 proc sel_reflist {w x y} {
8639     global showrefstop reflist headids tagids otherrefids
8641     if {![winfo exists $showrefstop]} return
8642     set l [lindex [split [$w index "@$x,$y"] "."] 0]
8643     set ref [lindex $reflist [expr {$l-1}]]
8644     set n [lindex $ref 0]
8645     switch -- [lindex $ref 1] {
8646         "H" {selbyid $headids($n)}
8647         "T" {selbyid $tagids($n)}
8648         "o" {selbyid $otherrefids($n)}
8649     }
8650     $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8653 proc unsel_reflist {} {
8654     global showrefstop
8656     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8657     $showrefstop.list tag remove highlight 0.0 end
8660 proc reflistfilter_change {n1 n2 op} {
8661     global reflistfilter
8663     after cancel refill_reflist
8664     after 200 refill_reflist
8667 proc refill_reflist {} {
8668     global reflist reflistfilter showrefstop headids tagids otherrefids
8669     global curview
8671     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8672     set refs {}
8673     foreach n [array names headids] {
8674         if {[string match $reflistfilter $n]} {
8675             if {[commitinview $headids($n) $curview]} {
8676                 lappend refs [list $n H]
8677             } else {
8678                 interestedin $headids($n) {run refill_reflist}
8679             }
8680         }
8681     }
8682     foreach n [array names tagids] {
8683         if {[string match $reflistfilter $n]} {
8684             if {[commitinview $tagids($n) $curview]} {
8685                 lappend refs [list $n T]
8686             } else {
8687                 interestedin $tagids($n) {run refill_reflist}
8688             }
8689         }
8690     }
8691     foreach n [array names otherrefids] {
8692         if {[string match $reflistfilter $n]} {
8693             if {[commitinview $otherrefids($n) $curview]} {
8694                 lappend refs [list $n o]
8695             } else {
8696                 interestedin $otherrefids($n) {run refill_reflist}
8697             }
8698         }
8699     }
8700     set refs [lsort -index 0 $refs]
8701     if {$refs eq $reflist} return
8703     # Update the contents of $showrefstop.list according to the
8704     # differences between $reflist (old) and $refs (new)
8705     $showrefstop.list conf -state normal
8706     $showrefstop.list insert end "\n"
8707     set i 0
8708     set j 0
8709     while {$i < [llength $reflist] || $j < [llength $refs]} {
8710         if {$i < [llength $reflist]} {
8711             if {$j < [llength $refs]} {
8712                 set cmp [string compare [lindex $reflist $i 0] \
8713                              [lindex $refs $j 0]]
8714                 if {$cmp == 0} {
8715                     set cmp [string compare [lindex $reflist $i 1] \
8716                                  [lindex $refs $j 1]]
8717                 }
8718             } else {
8719                 set cmp -1
8720             }
8721         } else {
8722             set cmp 1
8723         }
8724         switch -- $cmp {
8725             -1 {
8726                 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8727                 incr i
8728             }
8729             0 {
8730                 incr i
8731                 incr j
8732             }
8733             1 {
8734                 set l [expr {$j + 1}]
8735                 $showrefstop.list image create $l.0 -align baseline \
8736                     -image reficon-[lindex $refs $j 1] -padx 2
8737                 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8738                 incr j
8739             }
8740         }
8741     }
8742     set reflist $refs
8743     # delete last newline
8744     $showrefstop.list delete end-2c end-1c
8745     $showrefstop.list conf -state disabled
8748 # Stuff for finding nearby tags
8749 proc getallcommits {} {
8750     global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8751     global idheads idtags idotherrefs allparents tagobjid
8753     if {![info exists allcommits]} {
8754         set nextarc 0
8755         set allcommits 0
8756         set seeds {}
8757         set allcwait 0
8758         set cachedarcs 0
8759         set allccache [file join [gitdir] "gitk.cache"]
8760         if {![catch {
8761             set f [open $allccache r]
8762             set allcwait 1
8763             getcache $f
8764         }]} return
8765     }
8767     if {$allcwait} {
8768         return
8769     }
8770     set cmd [list | git rev-list --parents]
8771     set allcupdate [expr {$seeds ne {}}]
8772     if {!$allcupdate} {
8773         set ids "--all"
8774     } else {
8775         set refs [concat [array names idheads] [array names idtags] \
8776                       [array names idotherrefs]]
8777         set ids {}
8778         set tagobjs {}
8779         foreach name [array names tagobjid] {
8780             lappend tagobjs $tagobjid($name)
8781         }
8782         foreach id [lsort -unique $refs] {
8783             if {![info exists allparents($id)] &&
8784                 [lsearch -exact $tagobjs $id] < 0} {
8785                 lappend ids $id
8786             }
8787         }
8788         if {$ids ne {}} {
8789             foreach id $seeds {
8790                 lappend ids "^$id"
8791             }
8792         }
8793     }
8794     if {$ids ne {}} {
8795         set fd [open [concat $cmd $ids] r]
8796         fconfigure $fd -blocking 0
8797         incr allcommits
8798         nowbusy allcommits
8799         filerun $fd [list getallclines $fd]
8800     } else {
8801         dispneartags 0
8802     }
8805 # Since most commits have 1 parent and 1 child, we group strings of
8806 # such commits into "arcs" joining branch/merge points (BMPs), which
8807 # are commits that either don't have 1 parent or don't have 1 child.
8809 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8810 # arcout(id) - outgoing arcs for BMP
8811 # arcids(a) - list of IDs on arc including end but not start
8812 # arcstart(a) - BMP ID at start of arc
8813 # arcend(a) - BMP ID at end of arc
8814 # growing(a) - arc a is still growing
8815 # arctags(a) - IDs out of arcids (excluding end) that have tags
8816 # archeads(a) - IDs out of arcids (excluding end) that have heads
8817 # The start of an arc is at the descendent end, so "incoming" means
8818 # coming from descendents, and "outgoing" means going towards ancestors.
8820 proc getallclines {fd} {
8821     global allparents allchildren idtags idheads nextarc
8822     global arcnos arcids arctags arcout arcend arcstart archeads growing
8823     global seeds allcommits cachedarcs allcupdate
8824     
8825     set nid 0
8826     while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8827         set id [lindex $line 0]
8828         if {[info exists allparents($id)]} {
8829             # seen it already
8830             continue
8831         }
8832         set cachedarcs 0
8833         set olds [lrange $line 1 end]
8834         set allparents($id) $olds
8835         if {![info exists allchildren($id)]} {
8836             set allchildren($id) {}
8837             set arcnos($id) {}
8838             lappend seeds $id
8839         } else {
8840             set a $arcnos($id)
8841             if {[llength $olds] == 1 && [llength $a] == 1} {
8842                 lappend arcids($a) $id
8843                 if {[info exists idtags($id)]} {
8844                     lappend arctags($a) $id
8845                 }
8846                 if {[info exists idheads($id)]} {
8847                     lappend archeads($a) $id
8848                 }
8849                 if {[info exists allparents($olds)]} {
8850                     # seen parent already
8851                     if {![info exists arcout($olds)]} {
8852                         splitarc $olds
8853                     }
8854                     lappend arcids($a) $olds
8855                     set arcend($a) $olds
8856                     unset growing($a)
8857                 }
8858                 lappend allchildren($olds) $id
8859                 lappend arcnos($olds) $a
8860                 continue
8861             }
8862         }
8863         foreach a $arcnos($id) {
8864             lappend arcids($a) $id
8865             set arcend($a) $id
8866             unset growing($a)
8867         }
8869         set ao {}
8870         foreach p $olds {
8871             lappend allchildren($p) $id
8872             set a [incr nextarc]
8873             set arcstart($a) $id
8874             set archeads($a) {}
8875             set arctags($a) {}
8876             set archeads($a) {}
8877             set arcids($a) {}
8878             lappend ao $a
8879             set growing($a) 1
8880             if {[info exists allparents($p)]} {
8881                 # seen it already, may need to make a new branch
8882                 if {![info exists arcout($p)]} {
8883                     splitarc $p
8884                 }
8885                 lappend arcids($a) $p
8886                 set arcend($a) $p
8887                 unset growing($a)
8888             }
8889             lappend arcnos($p) $a
8890         }
8891         set arcout($id) $ao
8892     }
8893     if {$nid > 0} {
8894         global cached_dheads cached_dtags cached_atags
8895         catch {unset cached_dheads}
8896         catch {unset cached_dtags}
8897         catch {unset cached_atags}
8898     }
8899     if {![eof $fd]} {
8900         return [expr {$nid >= 1000? 2: 1}]
8901     }
8902     set cacheok 1
8903     if {[catch {
8904         fconfigure $fd -blocking 1
8905         close $fd
8906     } err]} {
8907         # got an error reading the list of commits
8908         # if we were updating, try rereading the whole thing again
8909         if {$allcupdate} {
8910             incr allcommits -1
8911             dropcache $err
8912             return
8913         }
8914         error_popup "[mc "Error reading commit topology information;\
8915                 branch and preceding/following tag information\
8916                 will be incomplete."]\n($err)"
8917         set cacheok 0
8918     }
8919     if {[incr allcommits -1] == 0} {
8920         notbusy allcommits
8921         if {$cacheok} {
8922             run savecache
8923         }
8924     }
8925     dispneartags 0
8926     return 0
8929 proc recalcarc {a} {
8930     global arctags archeads arcids idtags idheads
8932     set at {}
8933     set ah {}
8934     foreach id [lrange $arcids($a) 0 end-1] {
8935         if {[info exists idtags($id)]} {
8936             lappend at $id
8937         }
8938         if {[info exists idheads($id)]} {
8939             lappend ah $id
8940         }
8941     }
8942     set arctags($a) $at
8943     set archeads($a) $ah
8946 proc splitarc {p} {
8947     global arcnos arcids nextarc arctags archeads idtags idheads
8948     global arcstart arcend arcout allparents growing
8950     set a $arcnos($p)
8951     if {[llength $a] != 1} {
8952         puts "oops splitarc called but [llength $a] arcs already"
8953         return
8954     }
8955     set a [lindex $a 0]
8956     set i [lsearch -exact $arcids($a) $p]
8957     if {$i < 0} {
8958         puts "oops splitarc $p not in arc $a"
8959         return
8960     }
8961     set na [incr nextarc]
8962     if {[info exists arcend($a)]} {
8963         set arcend($na) $arcend($a)
8964     } else {
8965         set l [lindex $allparents([lindex $arcids($a) end]) 0]
8966         set j [lsearch -exact $arcnos($l) $a]
8967         set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8968     }
8969     set tail [lrange $arcids($a) [expr {$i+1}] end]
8970     set arcids($a) [lrange $arcids($a) 0 $i]
8971     set arcend($a) $p
8972     set arcstart($na) $p
8973     set arcout($p) $na
8974     set arcids($na) $tail
8975     if {[info exists growing($a)]} {
8976         set growing($na) 1
8977         unset growing($a)
8978     }
8980     foreach id $tail {
8981         if {[llength $arcnos($id)] == 1} {
8982             set arcnos($id) $na
8983         } else {
8984             set j [lsearch -exact $arcnos($id) $a]
8985             set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8986         }
8987     }
8989     # reconstruct tags and heads lists
8990     if {$arctags($a) ne {} || $archeads($a) ne {}} {
8991         recalcarc $a
8992         recalcarc $na
8993     } else {
8994         set arctags($na) {}
8995         set archeads($na) {}
8996     }
8999 # Update things for a new commit added that is a child of one
9000 # existing commit.  Used when cherry-picking.
9001 proc addnewchild {id p} {
9002     global allparents allchildren idtags nextarc
9003     global arcnos arcids arctags arcout arcend arcstart archeads growing
9004     global seeds allcommits
9006     if {![info exists allcommits] || ![info exists arcnos($p)]} return
9007     set allparents($id) [list $p]
9008     set allchildren($id) {}
9009     set arcnos($id) {}
9010     lappend seeds $id
9011     lappend allchildren($p) $id
9012     set a [incr nextarc]
9013     set arcstart($a) $id
9014     set archeads($a) {}
9015     set arctags($a) {}
9016     set arcids($a) [list $p]
9017     set arcend($a) $p
9018     if {![info exists arcout($p)]} {
9019         splitarc $p
9020     }
9021     lappend arcnos($p) $a
9022     set arcout($id) [list $a]
9025 # This implements a cache for the topology information.
9026 # The cache saves, for each arc, the start and end of the arc,
9027 # the ids on the arc, and the outgoing arcs from the end.
9028 proc readcache {f} {
9029     global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9030     global idtags idheads allparents cachedarcs possible_seeds seeds growing
9031     global allcwait
9033     set a $nextarc
9034     set lim $cachedarcs
9035     if {$lim - $a > 500} {
9036         set lim [expr {$a + 500}]
9037     }
9038     if {[catch {
9039         if {$a == $lim} {
9040             # finish reading the cache and setting up arctags, etc.
9041             set line [gets $f]
9042             if {$line ne "1"} {error "bad final version"}
9043             close $f
9044             foreach id [array names idtags] {
9045                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9046                     [llength $allparents($id)] == 1} {
9047                     set a [lindex $arcnos($id) 0]
9048                     if {$arctags($a) eq {}} {
9049                         recalcarc $a
9050                     }
9051                 }
9052             }
9053             foreach id [array names idheads] {
9054                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9055                     [llength $allparents($id)] == 1} {
9056                     set a [lindex $arcnos($id) 0]
9057                     if {$archeads($a) eq {}} {
9058                         recalcarc $a
9059                     }
9060                 }
9061             }
9062             foreach id [lsort -unique $possible_seeds] {
9063                 if {$arcnos($id) eq {}} {
9064                     lappend seeds $id
9065                 }
9066             }
9067             set allcwait 0
9068         } else {
9069             while {[incr a] <= $lim} {
9070                 set line [gets $f]
9071                 if {[llength $line] != 3} {error "bad line"}
9072                 set s [lindex $line 0]
9073                 set arcstart($a) $s
9074                 lappend arcout($s) $a
9075                 if {![info exists arcnos($s)]} {
9076                     lappend possible_seeds $s
9077                     set arcnos($s) {}
9078                 }
9079                 set e [lindex $line 1]
9080                 if {$e eq {}} {
9081                     set growing($a) 1
9082                 } else {
9083                     set arcend($a) $e
9084                     if {![info exists arcout($e)]} {
9085                         set arcout($e) {}
9086                     }
9087                 }
9088                 set arcids($a) [lindex $line 2]
9089                 foreach id $arcids($a) {
9090                     lappend allparents($s) $id
9091                     set s $id
9092                     lappend arcnos($id) $a
9093                 }
9094                 if {![info exists allparents($s)]} {
9095                     set allparents($s) {}
9096                 }
9097                 set arctags($a) {}
9098                 set archeads($a) {}
9099             }
9100             set nextarc [expr {$a - 1}]
9101         }
9102     } err]} {
9103         dropcache $err
9104         return 0
9105     }
9106     if {!$allcwait} {
9107         getallcommits
9108     }
9109     return $allcwait
9112 proc getcache {f} {
9113     global nextarc cachedarcs possible_seeds
9115     if {[catch {
9116         set line [gets $f]
9117         if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9118         # make sure it's an integer
9119         set cachedarcs [expr {int([lindex $line 1])}]
9120         if {$cachedarcs < 0} {error "bad number of arcs"}
9121         set nextarc 0
9122         set possible_seeds {}
9123         run readcache $f
9124     } err]} {
9125         dropcache $err
9126     }
9127     return 0
9130 proc dropcache {err} {
9131     global allcwait nextarc cachedarcs seeds
9133     #puts "dropping cache ($err)"
9134     foreach v {arcnos arcout arcids arcstart arcend growing \
9135                    arctags archeads allparents allchildren} {
9136         global $v
9137         catch {unset $v}
9138     }
9139     set allcwait 0
9140     set nextarc 0
9141     set cachedarcs 0
9142     set seeds {}
9143     getallcommits
9146 proc writecache {f} {
9147     global cachearc cachedarcs allccache
9148     global arcstart arcend arcnos arcids arcout
9150     set a $cachearc
9151     set lim $cachedarcs
9152     if {$lim - $a > 1000} {
9153         set lim [expr {$a + 1000}]
9154     }
9155     if {[catch {
9156         while {[incr a] <= $lim} {
9157             if {[info exists arcend($a)]} {
9158                 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9159             } else {
9160                 puts $f [list $arcstart($a) {} $arcids($a)]
9161             }
9162         }
9163     } err]} {
9164         catch {close $f}
9165         catch {file delete $allccache}
9166         #puts "writing cache failed ($err)"
9167         return 0
9168     }
9169     set cachearc [expr {$a - 1}]
9170     if {$a > $cachedarcs} {
9171         puts $f "1"
9172         close $f
9173         return 0
9174     }
9175     return 1
9178 proc savecache {} {
9179     global nextarc cachedarcs cachearc allccache
9181     if {$nextarc == $cachedarcs} return
9182     set cachearc 0
9183     set cachedarcs $nextarc
9184     catch {
9185         set f [open $allccache w]
9186         puts $f [list 1 $cachedarcs]
9187         run writecache $f
9188     }
9191 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9192 # or 0 if neither is true.
9193 proc anc_or_desc {a b} {
9194     global arcout arcstart arcend arcnos cached_isanc
9196     if {$arcnos($a) eq $arcnos($b)} {
9197         # Both are on the same arc(s); either both are the same BMP,
9198         # or if one is not a BMP, the other is also not a BMP or is
9199         # the BMP at end of the arc (and it only has 1 incoming arc).
9200         # Or both can be BMPs with no incoming arcs.
9201         if {$a eq $b || $arcnos($a) eq {}} {
9202             return 0
9203         }
9204         # assert {[llength $arcnos($a)] == 1}
9205         set arc [lindex $arcnos($a) 0]
9206         set i [lsearch -exact $arcids($arc) $a]
9207         set j [lsearch -exact $arcids($arc) $b]
9208         if {$i < 0 || $i > $j} {
9209             return 1
9210         } else {
9211             return -1
9212         }
9213     }
9215     if {![info exists arcout($a)]} {
9216         set arc [lindex $arcnos($a) 0]
9217         if {[info exists arcend($arc)]} {
9218             set aend $arcend($arc)
9219         } else {
9220             set aend {}
9221         }
9222         set a $arcstart($arc)
9223     } else {
9224         set aend $a
9225     }
9226     if {![info exists arcout($b)]} {
9227         set arc [lindex $arcnos($b) 0]
9228         if {[info exists arcend($arc)]} {
9229             set bend $arcend($arc)
9230         } else {
9231             set bend {}
9232         }
9233         set b $arcstart($arc)
9234     } else {
9235         set bend $b
9236     }
9237     if {$a eq $bend} {
9238         return 1
9239     }
9240     if {$b eq $aend} {
9241         return -1
9242     }
9243     if {[info exists cached_isanc($a,$bend)]} {
9244         if {$cached_isanc($a,$bend)} {
9245             return 1
9246         }
9247     }
9248     if {[info exists cached_isanc($b,$aend)]} {
9249         if {$cached_isanc($b,$aend)} {
9250             return -1
9251         }
9252         if {[info exists cached_isanc($a,$bend)]} {
9253             return 0
9254         }
9255     }
9257     set todo [list $a $b]
9258     set anc($a) a
9259     set anc($b) b
9260     for {set i 0} {$i < [llength $todo]} {incr i} {
9261         set x [lindex $todo $i]
9262         if {$anc($x) eq {}} {
9263             continue
9264         }
9265         foreach arc $arcnos($x) {
9266             set xd $arcstart($arc)
9267             if {$xd eq $bend} {
9268                 set cached_isanc($a,$bend) 1
9269                 set cached_isanc($b,$aend) 0
9270                 return 1
9271             } elseif {$xd eq $aend} {
9272                 set cached_isanc($b,$aend) 1
9273                 set cached_isanc($a,$bend) 0
9274                 return -1
9275             }
9276             if {![info exists anc($xd)]} {
9277                 set anc($xd) $anc($x)
9278                 lappend todo $xd
9279             } elseif {$anc($xd) ne $anc($x)} {
9280                 set anc($xd) {}
9281             }
9282         }
9283     }
9284     set cached_isanc($a,$bend) 0
9285     set cached_isanc($b,$aend) 0
9286     return 0
9289 # This identifies whether $desc has an ancestor that is
9290 # a growing tip of the graph and which is not an ancestor of $anc
9291 # and returns 0 if so and 1 if not.
9292 # If we subsequently discover a tag on such a growing tip, and that
9293 # turns out to be a descendent of $anc (which it could, since we
9294 # don't necessarily see children before parents), then $desc
9295 # isn't a good choice to display as a descendent tag of
9296 # $anc (since it is the descendent of another tag which is
9297 # a descendent of $anc).  Similarly, $anc isn't a good choice to
9298 # display as a ancestor tag of $desc.
9300 proc is_certain {desc anc} {
9301     global arcnos arcout arcstart arcend growing problems
9303     set certain {}
9304     if {[llength $arcnos($anc)] == 1} {
9305         # tags on the same arc are certain
9306         if {$arcnos($desc) eq $arcnos($anc)} {
9307             return 1
9308         }
9309         if {![info exists arcout($anc)]} {
9310             # if $anc is partway along an arc, use the start of the arc instead
9311             set a [lindex $arcnos($anc) 0]
9312             set anc $arcstart($a)
9313         }
9314     }
9315     if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9316         set x $desc
9317     } else {
9318         set a [lindex $arcnos($desc) 0]
9319         set x $arcend($a)
9320     }
9321     if {$x == $anc} {
9322         return 1
9323     }
9324     set anclist [list $x]
9325     set dl($x) 1
9326     set nnh 1
9327     set ngrowanc 0
9328     for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9329         set x [lindex $anclist $i]
9330         if {$dl($x)} {
9331             incr nnh -1
9332         }
9333         set done($x) 1
9334         foreach a $arcout($x) {
9335             if {[info exists growing($a)]} {
9336                 if {![info exists growanc($x)] && $dl($x)} {
9337                     set growanc($x) 1
9338                     incr ngrowanc
9339                 }
9340             } else {
9341                 set y $arcend($a)
9342                 if {[info exists dl($y)]} {
9343                     if {$dl($y)} {
9344                         if {!$dl($x)} {
9345                             set dl($y) 0
9346                             if {![info exists done($y)]} {
9347                                 incr nnh -1
9348                             }
9349                             if {[info exists growanc($x)]} {
9350                                 incr ngrowanc -1
9351                             }
9352                             set xl [list $y]
9353                             for {set k 0} {$k < [llength $xl]} {incr k} {
9354                                 set z [lindex $xl $k]
9355                                 foreach c $arcout($z) {
9356                                     if {[info exists arcend($c)]} {
9357                                         set v $arcend($c)
9358                                         if {[info exists dl($v)] && $dl($v)} {
9359                                             set dl($v) 0
9360                                             if {![info exists done($v)]} {
9361                                                 incr nnh -1
9362                                             }
9363                                             if {[info exists growanc($v)]} {
9364                                                 incr ngrowanc -1
9365                                             }
9366                                             lappend xl $v
9367                                         }
9368                                     }
9369                                 }
9370                             }
9371                         }
9372                     }
9373                 } elseif {$y eq $anc || !$dl($x)} {
9374                     set dl($y) 0
9375                     lappend anclist $y
9376                 } else {
9377                     set dl($y) 1
9378                     lappend anclist $y
9379                     incr nnh
9380                 }
9381             }
9382         }
9383     }
9384     foreach x [array names growanc] {
9385         if {$dl($x)} {
9386             return 0
9387         }
9388         return 0
9389     }
9390     return 1
9393 proc validate_arctags {a} {
9394     global arctags idtags
9396     set i -1
9397     set na $arctags($a)
9398     foreach id $arctags($a) {
9399         incr i
9400         if {![info exists idtags($id)]} {
9401             set na [lreplace $na $i $i]
9402             incr i -1
9403         }
9404     }
9405     set arctags($a) $na
9408 proc validate_archeads {a} {
9409     global archeads idheads
9411     set i -1
9412     set na $archeads($a)
9413     foreach id $archeads($a) {
9414         incr i
9415         if {![info exists idheads($id)]} {
9416             set na [lreplace $na $i $i]
9417             incr i -1
9418         }
9419     }
9420     set archeads($a) $na
9423 # Return the list of IDs that have tags that are descendents of id,
9424 # ignoring IDs that are descendents of IDs already reported.
9425 proc desctags {id} {
9426     global arcnos arcstart arcids arctags idtags allparents
9427     global growing cached_dtags
9429     if {![info exists allparents($id)]} {
9430         return {}
9431     }
9432     set t1 [clock clicks -milliseconds]
9433     set argid $id
9434     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9435         # part-way along an arc; check that arc first
9436         set a [lindex $arcnos($id) 0]
9437         if {$arctags($a) ne {}} {
9438             validate_arctags $a
9439             set i [lsearch -exact $arcids($a) $id]
9440             set tid {}
9441             foreach t $arctags($a) {
9442                 set j [lsearch -exact $arcids($a) $t]
9443                 if {$j >= $i} break
9444                 set tid $t
9445             }
9446             if {$tid ne {}} {
9447                 return $tid
9448             }
9449         }
9450         set id $arcstart($a)
9451         if {[info exists idtags($id)]} {
9452             return $id
9453         }
9454     }
9455     if {[info exists cached_dtags($id)]} {
9456         return $cached_dtags($id)
9457     }
9459     set origid $id
9460     set todo [list $id]
9461     set queued($id) 1
9462     set nc 1
9463     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9464         set id [lindex $todo $i]
9465         set done($id) 1
9466         set ta [info exists hastaggedancestor($id)]
9467         if {!$ta} {
9468             incr nc -1
9469         }
9470         # ignore tags on starting node
9471         if {!$ta && $i > 0} {
9472             if {[info exists idtags($id)]} {
9473                 set tagloc($id) $id
9474                 set ta 1
9475             } elseif {[info exists cached_dtags($id)]} {
9476                 set tagloc($id) $cached_dtags($id)
9477                 set ta 1
9478             }
9479         }
9480         foreach a $arcnos($id) {
9481             set d $arcstart($a)
9482             if {!$ta && $arctags($a) ne {}} {
9483                 validate_arctags $a
9484                 if {$arctags($a) ne {}} {
9485                     lappend tagloc($id) [lindex $arctags($a) end]
9486                 }
9487             }
9488             if {$ta || $arctags($a) ne {}} {
9489                 set tomark [list $d]
9490                 for {set j 0} {$j < [llength $tomark]} {incr j} {
9491                     set dd [lindex $tomark $j]
9492                     if {![info exists hastaggedancestor($dd)]} {
9493                         if {[info exists done($dd)]} {
9494                             foreach b $arcnos($dd) {
9495                                 lappend tomark $arcstart($b)
9496                             }
9497                             if {[info exists tagloc($dd)]} {
9498                                 unset tagloc($dd)
9499                             }
9500                         } elseif {[info exists queued($dd)]} {
9501                             incr nc -1
9502                         }
9503                         set hastaggedancestor($dd) 1
9504                     }
9505                 }
9506             }
9507             if {![info exists queued($d)]} {
9508                 lappend todo $d
9509                 set queued($d) 1
9510                 if {![info exists hastaggedancestor($d)]} {
9511                     incr nc
9512                 }
9513             }
9514         }
9515     }
9516     set tags {}
9517     foreach id [array names tagloc] {
9518         if {![info exists hastaggedancestor($id)]} {
9519             foreach t $tagloc($id) {
9520                 if {[lsearch -exact $tags $t] < 0} {
9521                     lappend tags $t
9522                 }
9523             }
9524         }
9525     }
9526     set t2 [clock clicks -milliseconds]
9527     set loopix $i
9529     # remove tags that are descendents of other tags
9530     for {set i 0} {$i < [llength $tags]} {incr i} {
9531         set a [lindex $tags $i]
9532         for {set j 0} {$j < $i} {incr j} {
9533             set b [lindex $tags $j]
9534             set r [anc_or_desc $a $b]
9535             if {$r == 1} {
9536                 set tags [lreplace $tags $j $j]
9537                 incr j -1
9538                 incr i -1
9539             } elseif {$r == -1} {
9540                 set tags [lreplace $tags $i $i]
9541                 incr i -1
9542                 break
9543             }
9544         }
9545     }
9547     if {[array names growing] ne {}} {
9548         # graph isn't finished, need to check if any tag could get
9549         # eclipsed by another tag coming later.  Simply ignore any
9550         # tags that could later get eclipsed.
9551         set ctags {}
9552         foreach t $tags {
9553             if {[is_certain $t $origid]} {
9554                 lappend ctags $t
9555             }
9556         }
9557         if {$tags eq $ctags} {
9558             set cached_dtags($origid) $tags
9559         } else {
9560             set tags $ctags
9561         }
9562     } else {
9563         set cached_dtags($origid) $tags
9564     }
9565     set t3 [clock clicks -milliseconds]
9566     if {0 && $t3 - $t1 >= 100} {
9567         puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9568             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9569     }
9570     return $tags
9573 proc anctags {id} {
9574     global arcnos arcids arcout arcend arctags idtags allparents
9575     global growing cached_atags
9577     if {![info exists allparents($id)]} {
9578         return {}
9579     }
9580     set t1 [clock clicks -milliseconds]
9581     set argid $id
9582     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9583         # part-way along an arc; check that arc first
9584         set a [lindex $arcnos($id) 0]
9585         if {$arctags($a) ne {}} {
9586             validate_arctags $a
9587             set i [lsearch -exact $arcids($a) $id]
9588             foreach t $arctags($a) {
9589                 set j [lsearch -exact $arcids($a) $t]
9590                 if {$j > $i} {
9591                     return $t
9592                 }
9593             }
9594         }
9595         if {![info exists arcend($a)]} {
9596             return {}
9597         }
9598         set id $arcend($a)
9599         if {[info exists idtags($id)]} {
9600             return $id
9601         }
9602     }
9603     if {[info exists cached_atags($id)]} {
9604         return $cached_atags($id)
9605     }
9607     set origid $id
9608     set todo [list $id]
9609     set queued($id) 1
9610     set taglist {}
9611     set nc 1
9612     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9613         set id [lindex $todo $i]
9614         set done($id) 1
9615         set td [info exists hastaggeddescendent($id)]
9616         if {!$td} {
9617             incr nc -1
9618         }
9619         # ignore tags on starting node
9620         if {!$td && $i > 0} {
9621             if {[info exists idtags($id)]} {
9622                 set tagloc($id) $id
9623                 set td 1
9624             } elseif {[info exists cached_atags($id)]} {
9625                 set tagloc($id) $cached_atags($id)
9626                 set td 1
9627             }
9628         }
9629         foreach a $arcout($id) {
9630             if {!$td && $arctags($a) ne {}} {
9631                 validate_arctags $a
9632                 if {$arctags($a) ne {}} {
9633                     lappend tagloc($id) [lindex $arctags($a) 0]
9634                 }
9635             }
9636             if {![info exists arcend($a)]} continue
9637             set d $arcend($a)
9638             if {$td || $arctags($a) ne {}} {
9639                 set tomark [list $d]
9640                 for {set j 0} {$j < [llength $tomark]} {incr j} {
9641                     set dd [lindex $tomark $j]
9642                     if {![info exists hastaggeddescendent($dd)]} {
9643                         if {[info exists done($dd)]} {
9644                             foreach b $arcout($dd) {
9645                                 if {[info exists arcend($b)]} {
9646                                     lappend tomark $arcend($b)
9647                                 }
9648                             }
9649                             if {[info exists tagloc($dd)]} {
9650                                 unset tagloc($dd)
9651                             }
9652                         } elseif {[info exists queued($dd)]} {
9653                             incr nc -1
9654                         }
9655                         set hastaggeddescendent($dd) 1
9656                     }
9657                 }
9658             }
9659             if {![info exists queued($d)]} {
9660                 lappend todo $d
9661                 set queued($d) 1
9662                 if {![info exists hastaggeddescendent($d)]} {
9663                     incr nc
9664                 }
9665             }
9666         }
9667     }
9668     set t2 [clock clicks -milliseconds]
9669     set loopix $i
9670     set tags {}
9671     foreach id [array names tagloc] {
9672         if {![info exists hastaggeddescendent($id)]} {
9673             foreach t $tagloc($id) {
9674                 if {[lsearch -exact $tags $t] < 0} {
9675                     lappend tags $t
9676                 }
9677             }
9678         }
9679     }
9681     # remove tags that are ancestors of other tags
9682     for {set i 0} {$i < [llength $tags]} {incr i} {
9683         set a [lindex $tags $i]
9684         for {set j 0} {$j < $i} {incr j} {
9685             set b [lindex $tags $j]
9686             set r [anc_or_desc $a $b]
9687             if {$r == -1} {
9688                 set tags [lreplace $tags $j $j]
9689                 incr j -1
9690                 incr i -1
9691             } elseif {$r == 1} {
9692                 set tags [lreplace $tags $i $i]
9693                 incr i -1
9694                 break
9695             }
9696         }
9697     }
9699     if {[array names growing] ne {}} {
9700         # graph isn't finished, need to check if any tag could get
9701         # eclipsed by another tag coming later.  Simply ignore any
9702         # tags that could later get eclipsed.
9703         set ctags {}
9704         foreach t $tags {
9705             if {[is_certain $origid $t]} {
9706                 lappend ctags $t
9707             }
9708         }
9709         if {$tags eq $ctags} {
9710             set cached_atags($origid) $tags
9711         } else {
9712             set tags $ctags
9713         }
9714     } else {
9715         set cached_atags($origid) $tags
9716     }
9717     set t3 [clock clicks -milliseconds]
9718     if {0 && $t3 - $t1 >= 100} {
9719         puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9720             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9721     }
9722     return $tags
9725 # Return the list of IDs that have heads that are descendents of id,
9726 # including id itself if it has a head.
9727 proc descheads {id} {
9728     global arcnos arcstart arcids archeads idheads cached_dheads
9729     global allparents
9731     if {![info exists allparents($id)]} {
9732         return {}
9733     }
9734     set aret {}
9735     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9736         # part-way along an arc; check it first
9737         set a [lindex $arcnos($id) 0]
9738         if {$archeads($a) ne {}} {
9739             validate_archeads $a
9740             set i [lsearch -exact $arcids($a) $id]
9741             foreach t $archeads($a) {
9742                 set j [lsearch -exact $arcids($a) $t]
9743                 if {$j > $i} break
9744                 lappend aret $t
9745             }
9746         }
9747         set id $arcstart($a)
9748     }
9749     set origid $id
9750     set todo [list $id]
9751     set seen($id) 1
9752     set ret {}
9753     for {set i 0} {$i < [llength $todo]} {incr i} {
9754         set id [lindex $todo $i]
9755         if {[info exists cached_dheads($id)]} {
9756             set ret [concat $ret $cached_dheads($id)]
9757         } else {
9758             if {[info exists idheads($id)]} {
9759                 lappend ret $id
9760             }
9761             foreach a $arcnos($id) {
9762                 if {$archeads($a) ne {}} {
9763                     validate_archeads $a
9764                     if {$archeads($a) ne {}} {
9765                         set ret [concat $ret $archeads($a)]
9766                     }
9767                 }
9768                 set d $arcstart($a)
9769                 if {![info exists seen($d)]} {
9770                     lappend todo $d
9771                     set seen($d) 1
9772                 }
9773             }
9774         }
9775     }
9776     set ret [lsort -unique $ret]
9777     set cached_dheads($origid) $ret
9778     return [concat $ret $aret]
9781 proc addedtag {id} {
9782     global arcnos arcout cached_dtags cached_atags
9784     if {![info exists arcnos($id)]} return
9785     if {![info exists arcout($id)]} {
9786         recalcarc [lindex $arcnos($id) 0]
9787     }
9788     catch {unset cached_dtags}
9789     catch {unset cached_atags}
9792 proc addedhead {hid head} {
9793     global arcnos arcout cached_dheads
9795     if {![info exists arcnos($hid)]} return
9796     if {![info exists arcout($hid)]} {
9797         recalcarc [lindex $arcnos($hid) 0]
9798     }
9799     catch {unset cached_dheads}
9802 proc removedhead {hid head} {
9803     global cached_dheads
9805     catch {unset cached_dheads}
9808 proc movedhead {hid head} {
9809     global arcnos arcout cached_dheads
9811     if {![info exists arcnos($hid)]} return
9812     if {![info exists arcout($hid)]} {
9813         recalcarc [lindex $arcnos($hid) 0]
9814     }
9815     catch {unset cached_dheads}
9818 proc changedrefs {} {
9819     global cached_dheads cached_dtags cached_atags
9820     global arctags archeads arcnos arcout idheads idtags
9822     foreach id [concat [array names idheads] [array names idtags]] {
9823         if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9824             set a [lindex $arcnos($id) 0]
9825             if {![info exists donearc($a)]} {
9826                 recalcarc $a
9827                 set donearc($a) 1
9828             }
9829         }
9830     }
9831     catch {unset cached_dtags}
9832     catch {unset cached_atags}
9833     catch {unset cached_dheads}
9836 proc rereadrefs {} {
9837     global idtags idheads idotherrefs mainheadid
9839     set refids [concat [array names idtags] \
9840                     [array names idheads] [array names idotherrefs]]
9841     foreach id $refids {
9842         if {![info exists ref($id)]} {
9843             set ref($id) [listrefs $id]
9844         }
9845     }
9846     set oldmainhead $mainheadid
9847     readrefs
9848     changedrefs
9849     set refids [lsort -unique [concat $refids [array names idtags] \
9850                         [array names idheads] [array names idotherrefs]]]
9851     foreach id $refids {
9852         set v [listrefs $id]
9853         if {![info exists ref($id)] || $ref($id) != $v} {
9854             redrawtags $id
9855         }
9856     }
9857     if {$oldmainhead ne $mainheadid} {
9858         redrawtags $oldmainhead
9859         redrawtags $mainheadid
9860     }
9861     run refill_reflist
9864 proc listrefs {id} {
9865     global idtags idheads idotherrefs
9867     set x {}
9868     if {[info exists idtags($id)]} {
9869         set x $idtags($id)
9870     }
9871     set y {}
9872     if {[info exists idheads($id)]} {
9873         set y $idheads($id)
9874     }
9875     set z {}
9876     if {[info exists idotherrefs($id)]} {
9877         set z $idotherrefs($id)
9878     }
9879     return [list $x $y $z]
9882 proc showtag {tag isnew} {
9883     global ctext tagcontents tagids linknum tagobjid
9885     if {$isnew} {
9886         addtohistory [list showtag $tag 0]
9887     }
9888     $ctext conf -state normal
9889     clear_ctext
9890     settabs 0
9891     set linknum 0
9892     if {![info exists tagcontents($tag)]} {
9893         catch {
9894             set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9895         }
9896     }
9897     if {[info exists tagcontents($tag)]} {
9898         set text $tagcontents($tag)
9899     } else {
9900         set text "[mc "Tag"]: $tag\n[mc "Id"]:  $tagids($tag)"
9901     }
9902     appendwithlinks $text {}
9903     $ctext conf -state disabled
9904     init_flist {}
9907 proc doquit {} {
9908     global stopped
9909     global gitktmpdir
9911     set stopped 100
9912     savestuff .
9913     destroy .
9915     if {[info exists gitktmpdir]} {
9916         catch {file delete -force $gitktmpdir}
9917     }
9920 proc mkfontdisp {font top which} {
9921     global fontattr fontpref $font
9923     set fontpref($font) [set $font]
9924     button $top.${font}but -text $which -font optionfont \
9925         -command [list choosefont $font $which]
9926     label $top.$font -relief flat -font $font \
9927         -text $fontattr($font,family) -justify left
9928     grid x $top.${font}but $top.$font -sticky w
9931 proc choosefont {font which} {
9932     global fontparam fontlist fonttop fontattr
9933     global prefstop
9935     set fontparam(which) $which
9936     set fontparam(font) $font
9937     set fontparam(family) [font actual $font -family]
9938     set fontparam(size) $fontattr($font,size)
9939     set fontparam(weight) $fontattr($font,weight)
9940     set fontparam(slant) $fontattr($font,slant)
9941     set top .gitkfont
9942     set fonttop $top
9943     if {![winfo exists $top]} {
9944         font create sample
9945         eval font config sample [font actual $font]
9946         toplevel $top
9947         make_transient $top $prefstop
9948         wm title $top [mc "Gitk font chooser"]
9949         label $top.l -textvariable fontparam(which)
9950         pack $top.l -side top
9951         set fontlist [lsort [font families]]
9952         frame $top.f
9953         listbox $top.f.fam -listvariable fontlist \
9954             -yscrollcommand [list $top.f.sb set]
9955         bind $top.f.fam <<ListboxSelect>> selfontfam
9956         scrollbar $top.f.sb -command [list $top.f.fam yview]
9957         pack $top.f.sb -side right -fill y
9958         pack $top.f.fam -side left -fill both -expand 1
9959         pack $top.f -side top -fill both -expand 1
9960         frame $top.g
9961         spinbox $top.g.size -from 4 -to 40 -width 4 \
9962             -textvariable fontparam(size) \
9963             -validatecommand {string is integer -strict %s}
9964         checkbutton $top.g.bold -padx 5 \
9965             -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9966             -variable fontparam(weight) -onvalue bold -offvalue normal
9967         checkbutton $top.g.ital -padx 5 \
9968             -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0  \
9969             -variable fontparam(slant) -onvalue italic -offvalue roman
9970         pack $top.g.size $top.g.bold $top.g.ital -side left
9971         pack $top.g -side top
9972         canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9973             -background white
9974         $top.c create text 100 25 -anchor center -text $which -font sample \
9975             -fill black -tags text
9976         bind $top.c <Configure> [list centertext $top.c]
9977         pack $top.c -side top -fill x
9978         frame $top.buts
9979         button $top.buts.ok -text [mc "OK"] -command fontok -default active
9980         button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9981         bind $top <Key-Return> fontok
9982         bind $top <Key-Escape> fontcan
9983         grid $top.buts.ok $top.buts.can
9984         grid columnconfigure $top.buts 0 -weight 1 -uniform a
9985         grid columnconfigure $top.buts 1 -weight 1 -uniform a
9986         pack $top.buts -side bottom -fill x
9987         trace add variable fontparam write chg_fontparam
9988     } else {
9989         raise $top
9990         $top.c itemconf text -text $which
9991     }
9992     set i [lsearch -exact $fontlist $fontparam(family)]
9993     if {$i >= 0} {
9994         $top.f.fam selection set $i
9995         $top.f.fam see $i
9996     }
9999 proc centertext {w} {
10000     $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10003 proc fontok {} {
10004     global fontparam fontpref prefstop
10006     set f $fontparam(font)
10007     set fontpref($f) [list $fontparam(family) $fontparam(size)]
10008     if {$fontparam(weight) eq "bold"} {
10009         lappend fontpref($f) "bold"
10010     }
10011     if {$fontparam(slant) eq "italic"} {
10012         lappend fontpref($f) "italic"
10013     }
10014     set w $prefstop.$f
10015     $w conf -text $fontparam(family) -font $fontpref($f)
10016         
10017     fontcan
10020 proc fontcan {} {
10021     global fonttop fontparam
10023     if {[info exists fonttop]} {
10024         catch {destroy $fonttop}
10025         catch {font delete sample}
10026         unset fonttop
10027         unset fontparam
10028     }
10031 proc selfontfam {} {
10032     global fonttop fontparam
10034     set i [$fonttop.f.fam curselection]
10035     if {$i ne {}} {
10036         set fontparam(family) [$fonttop.f.fam get $i]
10037     }
10040 proc chg_fontparam {v sub op} {
10041     global fontparam
10043     font config sample -$sub $fontparam($sub)
10046 proc doprefs {} {
10047     global maxwidth maxgraphpct
10048     global oldprefs prefstop showneartags showlocalchanges
10049     global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10050     global tabstop limitdiffs autoselect extdifftool perfile_attrs
10052     set top .gitkprefs
10053     set prefstop $top
10054     if {[winfo exists $top]} {
10055         raise $top
10056         return
10057     }
10058     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10059                    limitdiffs tabstop perfile_attrs} {
10060         set oldprefs($v) [set $v]
10061     }
10062     toplevel $top
10063     wm title $top [mc "Gitk preferences"]
10064     make_transient $top .
10065     label $top.ldisp -text [mc "Commit list display options"]
10066     grid $top.ldisp - -sticky w -pady 10
10067     label $top.spacer -text " "
10068     label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10069         -font optionfont
10070     spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10071     grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10072     label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10073         -font optionfont
10074     spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10075     grid x $top.maxpctl $top.maxpct -sticky w
10076     frame $top.showlocal
10077     label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
10078     checkbutton $top.showlocal.b -variable showlocalchanges
10079     pack $top.showlocal.b $top.showlocal.l -side left
10080     grid x $top.showlocal -sticky w
10081     frame $top.autoselect
10082     label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
10083     checkbutton $top.autoselect.b -variable autoselect
10084     pack $top.autoselect.b $top.autoselect.l -side left
10085     grid x $top.autoselect -sticky w
10087     label $top.ddisp -text [mc "Diff display options"]
10088     grid $top.ddisp - -sticky w -pady 10
10089     label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10090     spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10091     grid x $top.tabstopl $top.tabstop -sticky w
10092     frame $top.ntag
10093     label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
10094     checkbutton $top.ntag.b -variable showneartags
10095     pack $top.ntag.b $top.ntag.l -side left
10096     grid x $top.ntag -sticky w
10097     frame $top.ldiff
10098     label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
10099     checkbutton $top.ldiff.b -variable limitdiffs
10100     pack $top.ldiff.b $top.ldiff.l -side left
10101     grid x $top.ldiff -sticky w
10102     frame $top.lattr
10103     label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
10104     checkbutton $top.lattr.b -variable perfile_attrs
10105     pack $top.lattr.b $top.lattr.l -side left
10106     grid x $top.lattr -sticky w
10108     entry $top.extdifft -textvariable extdifftool
10109     frame $top.extdifff
10110     label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10111         -padx 10
10112     button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10113         -command choose_extdiff
10114     pack $top.extdifff.l $top.extdifff.b -side left
10115     grid x $top.extdifff $top.extdifft -sticky w
10117     label $top.cdisp -text [mc "Colors: press to choose"]
10118     grid $top.cdisp - -sticky w -pady 10
10119     label $top.bg -padx 40 -relief sunk -background $bgcolor
10120     button $top.bgbut -text [mc "Background"] -font optionfont \
10121         -command [list choosecolor bgcolor {} $top.bg background setbg]
10122     grid x $top.bgbut $top.bg -sticky w
10123     label $top.fg -padx 40 -relief sunk -background $fgcolor
10124     button $top.fgbut -text [mc "Foreground"] -font optionfont \
10125         -command [list choosecolor fgcolor {} $top.fg foreground setfg]
10126     grid x $top.fgbut $top.fg -sticky w
10127     label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10128     button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10129         -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
10130                       [list $ctext tag conf d0 -foreground]]
10131     grid x $top.diffoldbut $top.diffold -sticky w
10132     label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10133     button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10134         -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
10135                       [list $ctext tag conf dresult -foreground]]
10136     grid x $top.diffnewbut $top.diffnew -sticky w
10137     label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10138     button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10139         -command [list choosecolor diffcolors 2 $top.hunksep \
10140                       "diff hunk header" \
10141                       [list $ctext tag conf hunksep -foreground]]
10142     grid x $top.hunksepbut $top.hunksep -sticky w
10143     label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10144     button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10145         -command [list choosecolor markbgcolor {} $top.markbgsep \
10146                       [mc "marked line background"] \
10147                       [list $ctext tag conf omark -background]]
10148     grid x $top.markbgbut $top.markbgsep -sticky w
10149     label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10150     button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10151         -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
10152     grid x $top.selbgbut $top.selbgsep -sticky w
10154     label $top.cfont -text [mc "Fonts: press to choose"]
10155     grid $top.cfont - -sticky w -pady 10
10156     mkfontdisp mainfont $top [mc "Main font"]
10157     mkfontdisp textfont $top [mc "Diff display font"]
10158     mkfontdisp uifont $top [mc "User interface font"]
10160     frame $top.buts
10161     button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10162     button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10163     bind $top <Key-Return> prefsok
10164     bind $top <Key-Escape> prefscan
10165     grid $top.buts.ok $top.buts.can
10166     grid columnconfigure $top.buts 0 -weight 1 -uniform a
10167     grid columnconfigure $top.buts 1 -weight 1 -uniform a
10168     grid $top.buts - - -pady 10 -sticky ew
10169     bind $top <Visibility> "focus $top.buts.ok"
10172 proc choose_extdiff {} {
10173     global extdifftool
10175     set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10176     if {$prog ne {}} {
10177         set extdifftool $prog
10178     }
10181 proc choosecolor {v vi w x cmd} {
10182     global $v
10184     set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10185                -title [mc "Gitk: choose color for %s" $x]]
10186     if {$c eq {}} return
10187     $w conf -background $c
10188     lset $v $vi $c
10189     eval $cmd $c
10192 proc setselbg {c} {
10193     global bglist cflist
10194     foreach w $bglist {
10195         $w configure -selectbackground $c
10196     }
10197     $cflist tag configure highlight \
10198         -background [$cflist cget -selectbackground]
10199     allcanvs itemconf secsel -fill $c
10202 proc setbg {c} {
10203     global bglist
10205     foreach w $bglist {
10206         $w conf -background $c
10207     }
10210 proc setfg {c} {
10211     global fglist canv
10213     foreach w $fglist {
10214         $w conf -foreground $c
10215     }
10216     allcanvs itemconf text -fill $c
10217     $canv itemconf circle -outline $c
10220 proc prefscan {} {
10221     global oldprefs prefstop
10223     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10224                    limitdiffs tabstop perfile_attrs} {
10225         global $v
10226         set $v $oldprefs($v)
10227     }
10228     catch {destroy $prefstop}
10229     unset prefstop
10230     fontcan
10233 proc prefsok {} {
10234     global maxwidth maxgraphpct
10235     global oldprefs prefstop showneartags showlocalchanges
10236     global fontpref mainfont textfont uifont
10237     global limitdiffs treediffs perfile_attrs
10239     catch {destroy $prefstop}
10240     unset prefstop
10241     fontcan
10242     set fontchanged 0
10243     if {$mainfont ne $fontpref(mainfont)} {
10244         set mainfont $fontpref(mainfont)
10245         parsefont mainfont $mainfont
10246         eval font configure mainfont [fontflags mainfont]
10247         eval font configure mainfontbold [fontflags mainfont 1]
10248         setcoords
10249         set fontchanged 1
10250     }
10251     if {$textfont ne $fontpref(textfont)} {
10252         set textfont $fontpref(textfont)
10253         parsefont textfont $textfont
10254         eval font configure textfont [fontflags textfont]
10255         eval font configure textfontbold [fontflags textfont 1]
10256     }
10257     if {$uifont ne $fontpref(uifont)} {
10258         set uifont $fontpref(uifont)
10259         parsefont uifont $uifont
10260         eval font configure uifont [fontflags uifont]
10261     }
10262     settabs
10263     if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10264         if {$showlocalchanges} {
10265             doshowlocalchanges
10266         } else {
10267             dohidelocalchanges
10268         }
10269     }
10270     if {$limitdiffs != $oldprefs(limitdiffs) ||
10271         ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10272         # treediffs elements are limited by path;
10273         # won't have encodings cached if perfile_attrs was just turned on
10274         catch {unset treediffs}
10275     }
10276     if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10277         || $maxgraphpct != $oldprefs(maxgraphpct)} {
10278         redisplay
10279     } elseif {$showneartags != $oldprefs(showneartags) ||
10280           $limitdiffs != $oldprefs(limitdiffs)} {
10281         reselectline
10282     }
10285 proc formatdate {d} {
10286     global datetimeformat
10287     if {$d ne {}} {
10288         set d [clock format $d -format $datetimeformat]
10289     }
10290     return $d
10293 # This list of encoding names and aliases is distilled from
10294 # http://www.iana.org/assignments/character-sets.
10295 # Not all of them are supported by Tcl.
10296 set encoding_aliases {
10297     { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10298       ISO646-US US-ASCII us IBM367 cp367 csASCII }
10299     { ISO-10646-UTF-1 csISO10646UTF1 }
10300     { ISO_646.basic:1983 ref csISO646basic1983 }
10301     { INVARIANT csINVARIANT }
10302     { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10303     { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10304     { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10305     { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10306     { NATS-DANO iso-ir-9-1 csNATSDANO }
10307     { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10308     { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10309     { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10310     { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10311     { ISO-2022-KR csISO2022KR }
10312     { EUC-KR csEUCKR }
10313     { ISO-2022-JP csISO2022JP }
10314     { ISO-2022-JP-2 csISO2022JP2 }
10315     { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10316       csISO13JISC6220jp }
10317     { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10318     { IT iso-ir-15 ISO646-IT csISO15Italian }
10319     { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10320     { ES iso-ir-17 ISO646-ES csISO17Spanish }
10321     { greek7-old iso-ir-18 csISO18Greek7Old }
10322     { latin-greek iso-ir-19 csISO19LatinGreek }
10323     { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10324     { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10325     { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10326     { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10327     { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10328     { BS_viewdata iso-ir-47 csISO47BSViewdata }
10329     { INIS iso-ir-49 csISO49INIS }
10330     { INIS-8 iso-ir-50 csISO50INIS8 }
10331     { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10332     { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10333     { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10334     { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10335     { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10336     { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10337       csISO60Norwegian1 }
10338     { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10339     { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10340     { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10341     { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10342     { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10343     { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10344     { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10345     { greek7 iso-ir-88 csISO88Greek7 }
10346     { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10347     { iso-ir-90 csISO90 }
10348     { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10349     { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10350       csISO92JISC62991984b }
10351     { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10352     { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10353     { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10354       csISO95JIS62291984handadd }
10355     { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10356     { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10357     { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10358     { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10359       CP819 csISOLatin1 }
10360     { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10361     { T.61-7bit iso-ir-102 csISO102T617bit }
10362     { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10363     { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10364     { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10365     { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10366     { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10367     { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10368     { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10369     { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10370       arabic csISOLatinArabic }
10371     { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10372     { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10373     { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10374       greek greek8 csISOLatinGreek }
10375     { T.101-G2 iso-ir-128 csISO128T101G2 }
10376     { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10377       csISOLatinHebrew }
10378     { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10379     { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10380     { CSN_369103 iso-ir-139 csISO139CSN369103 }
10381     { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10382     { ISO_6937-2-add iso-ir-142 csISOTextComm }
10383     { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10384     { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10385       csISOLatinCyrillic }
10386     { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10387     { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10388     { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10389     { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10390     { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10391     { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10392     { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10393     { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10394     { ISO_10367-box iso-ir-155 csISO10367Box }
10395     { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10396     { latin-lap lap iso-ir-158 csISO158Lap }
10397     { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10398     { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10399     { us-dk csUSDK }
10400     { dk-us csDKUS }
10401     { JIS_X0201 X0201 csHalfWidthKatakana }
10402     { KSC5636 ISO646-KR csKSC5636 }
10403     { ISO-10646-UCS-2 csUnicode }
10404     { ISO-10646-UCS-4 csUCS4 }
10405     { DEC-MCS dec csDECMCS }
10406     { hp-roman8 roman8 r8 csHPRoman8 }
10407     { macintosh mac csMacintosh }
10408     { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10409       csIBM037 }
10410     { IBM038 EBCDIC-INT cp038 csIBM038 }
10411     { IBM273 CP273 csIBM273 }
10412     { IBM274 EBCDIC-BE CP274 csIBM274 }
10413     { IBM275 EBCDIC-BR cp275 csIBM275 }
10414     { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10415     { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10416     { IBM280 CP280 ebcdic-cp-it csIBM280 }
10417     { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10418     { IBM284 CP284 ebcdic-cp-es csIBM284 }
10419     { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10420     { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10421     { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10422     { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10423     { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10424     { IBM424 cp424 ebcdic-cp-he csIBM424 }
10425     { IBM437 cp437 437 csPC8CodePage437 }
10426     { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10427     { IBM775 cp775 csPC775Baltic }
10428     { IBM850 cp850 850 csPC850Multilingual }
10429     { IBM851 cp851 851 csIBM851 }
10430     { IBM852 cp852 852 csPCp852 }
10431     { IBM855 cp855 855 csIBM855 }
10432     { IBM857 cp857 857 csIBM857 }
10433     { IBM860 cp860 860 csIBM860 }
10434     { IBM861 cp861 861 cp-is csIBM861 }
10435     { IBM862 cp862 862 csPC862LatinHebrew }
10436     { IBM863 cp863 863 csIBM863 }
10437     { IBM864 cp864 csIBM864 }
10438     { IBM865 cp865 865 csIBM865 }
10439     { IBM866 cp866 866 csIBM866 }
10440     { IBM868 CP868 cp-ar csIBM868 }
10441     { IBM869 cp869 869 cp-gr csIBM869 }
10442     { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10443     { IBM871 CP871 ebcdic-cp-is csIBM871 }
10444     { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10445     { IBM891 cp891 csIBM891 }
10446     { IBM903 cp903 csIBM903 }
10447     { IBM904 cp904 904 csIBBM904 }
10448     { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10449     { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10450     { IBM1026 CP1026 csIBM1026 }
10451     { EBCDIC-AT-DE csIBMEBCDICATDE }
10452     { EBCDIC-AT-DE-A csEBCDICATDEA }
10453     { EBCDIC-CA-FR csEBCDICCAFR }
10454     { EBCDIC-DK-NO csEBCDICDKNO }
10455     { EBCDIC-DK-NO-A csEBCDICDKNOA }
10456     { EBCDIC-FI-SE csEBCDICFISE }
10457     { EBCDIC-FI-SE-A csEBCDICFISEA }
10458     { EBCDIC-FR csEBCDICFR }
10459     { EBCDIC-IT csEBCDICIT }
10460     { EBCDIC-PT csEBCDICPT }
10461     { EBCDIC-ES csEBCDICES }
10462     { EBCDIC-ES-A csEBCDICESA }
10463     { EBCDIC-ES-S csEBCDICESS }
10464     { EBCDIC-UK csEBCDICUK }
10465     { EBCDIC-US csEBCDICUS }
10466     { UNKNOWN-8BIT csUnknown8BiT }
10467     { MNEMONIC csMnemonic }
10468     { MNEM csMnem }
10469     { VISCII csVISCII }
10470     { VIQR csVIQR }
10471     { KOI8-R csKOI8R }
10472     { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10473     { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10474     { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10475     { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10476     { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10477     { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10478     { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10479     { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10480     { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10481     { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10482     { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10483     { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10484     { IBM1047 IBM-1047 }
10485     { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10486     { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10487     { UNICODE-1-1 csUnicode11 }
10488     { CESU-8 csCESU-8 }
10489     { BOCU-1 csBOCU-1 }
10490     { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10491     { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10492       l8 }
10493     { ISO-8859-15 ISO_8859-15 Latin-9 }
10494     { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10495     { GBK CP936 MS936 windows-936 }
10496     { JIS_Encoding csJISEncoding }
10497     { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10498     { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10499       EUC-JP }
10500     { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10501     { ISO-10646-UCS-Basic csUnicodeASCII }
10502     { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10503     { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10504     { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10505     { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10506     { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10507     { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10508     { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10509     { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10510     { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10511     { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10512     { Adobe-Standard-Encoding csAdobeStandardEncoding }
10513     { Ventura-US csVenturaUS }
10514     { Ventura-International csVenturaInternational }
10515     { PC8-Danish-Norwegian csPC8DanishNorwegian }
10516     { PC8-Turkish csPC8Turkish }
10517     { IBM-Symbols csIBMSymbols }
10518     { IBM-Thai csIBMThai }
10519     { HP-Legal csHPLegal }
10520     { HP-Pi-font csHPPiFont }
10521     { HP-Math8 csHPMath8 }
10522     { Adobe-Symbol-Encoding csHPPSMath }
10523     { HP-DeskTop csHPDesktop }
10524     { Ventura-Math csVenturaMath }
10525     { Microsoft-Publishing csMicrosoftPublishing }
10526     { Windows-31J csWindows31J }
10527     { GB2312 csGB2312 }
10528     { Big5 csBig5 }
10531 proc tcl_encoding {enc} {
10532     global encoding_aliases tcl_encoding_cache
10533     if {[info exists tcl_encoding_cache($enc)]} {
10534         return $tcl_encoding_cache($enc)
10535     }
10536     set names [encoding names]
10537     set lcnames [string tolower $names]
10538     set enc [string tolower $enc]
10539     set i [lsearch -exact $lcnames $enc]
10540     if {$i < 0} {
10541         # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10542         if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10543             set i [lsearch -exact $lcnames $encx]
10544         }
10545     }
10546     if {$i < 0} {
10547         foreach l $encoding_aliases {
10548             set ll [string tolower $l]
10549             if {[lsearch -exact $ll $enc] < 0} continue
10550             # look through the aliases for one that tcl knows about
10551             foreach e $ll {
10552                 set i [lsearch -exact $lcnames $e]
10553                 if {$i < 0} {
10554                     if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10555                         set i [lsearch -exact $lcnames $ex]
10556                     }
10557                 }
10558                 if {$i >= 0} break
10559             }
10560             break
10561         }
10562     }
10563     set tclenc {}
10564     if {$i >= 0} {
10565         set tclenc [lindex $names $i]
10566     }
10567     set tcl_encoding_cache($enc) $tclenc
10568     return $tclenc
10571 proc gitattr {path attr default} {
10572     global path_attr_cache
10573     if {[info exists path_attr_cache($attr,$path)]} {
10574         set r $path_attr_cache($attr,$path)
10575     } else {
10576         set r "unspecified"
10577         if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10578             regexp "(.*): encoding: (.*)" $line m f r
10579         }
10580         set path_attr_cache($attr,$path) $r
10581     }
10582     if {$r eq "unspecified"} {
10583         return $default
10584     }
10585     return $r
10588 proc cache_gitattr {attr pathlist} {
10589     global path_attr_cache
10590     set newlist {}
10591     foreach path $pathlist {
10592         if {![info exists path_attr_cache($attr,$path)]} {
10593             lappend newlist $path
10594         }
10595     }
10596     set lim 1000
10597     if {[tk windowingsystem] == "win32"} {
10598         # windows has a 32k limit on the arguments to a command...
10599         set lim 30
10600     }
10601     while {$newlist ne {}} {
10602         set head [lrange $newlist 0 [expr {$lim - 1}]]
10603         set newlist [lrange $newlist $lim end]
10604         if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10605             foreach row [split $rlist "\n"] {
10606                 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10607                     if {[string index $path 0] eq "\""} {
10608                         set path [encoding convertfrom [lindex $path 0]]
10609                     }
10610                     set path_attr_cache($attr,$path) $value
10611                 }
10612             }
10613         }
10614     }
10617 proc get_path_encoding {path} {
10618     global gui_encoding perfile_attrs
10619     set tcl_enc $gui_encoding
10620     if {$path ne {} && $perfile_attrs} {
10621         set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10622         if {$enc2 ne {}} {
10623             set tcl_enc $enc2
10624         }
10625     }
10626     return $tcl_enc
10629 # First check that Tcl/Tk is recent enough
10630 if {[catch {package require Tk 8.4} err]} {
10631     show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10632                      Gitk requires at least Tcl/Tk 8.4."]
10633     exit 1
10636 # defaults...
10637 set wrcomcmd "git diff-tree --stdin -p --pretty"
10639 set gitencoding {}
10640 catch {
10641     set gitencoding [exec git config --get i18n.commitencoding]
10643 catch {
10644     set gitencoding [exec git config --get i18n.logoutputencoding]
10646 if {$gitencoding == ""} {
10647     set gitencoding "utf-8"
10649 set tclencoding [tcl_encoding $gitencoding]
10650 if {$tclencoding == {}} {
10651     puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10654 set gui_encoding [encoding system]
10655 catch {
10656     set enc [exec git config --get gui.encoding]
10657     if {$enc ne {}} {
10658         set tclenc [tcl_encoding $enc]
10659         if {$tclenc ne {}} {
10660             set gui_encoding $tclenc
10661         } else {
10662             puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10663         }
10664     }
10667 set mainfont {Helvetica 9}
10668 set textfont {Courier 9}
10669 set uifont {Helvetica 9 bold}
10670 set tabstop 8
10671 set findmergefiles 0
10672 set maxgraphpct 50
10673 set maxwidth 16
10674 set revlistorder 0
10675 set fastdate 0
10676 set uparrowlen 5
10677 set downarrowlen 5
10678 set mingaplen 100
10679 set cmitmode "patch"
10680 set wrapcomment "none"
10681 set showneartags 1
10682 set maxrefs 20
10683 set maxlinelen 200
10684 set showlocalchanges 1
10685 set limitdiffs 1
10686 set datetimeformat "%Y-%m-%d %H:%M:%S"
10687 set autoselect 1
10688 set perfile_attrs 0
10690 set extdifftool "meld"
10692 set colors {green red blue magenta darkgrey brown orange}
10693 set bgcolor white
10694 set fgcolor black
10695 set diffcolors {red "#00a000" blue}
10696 set diffcontext 3
10697 set ignorespace 0
10698 set selectbgcolor gray85
10699 set markbgcolor "#e0e0ff"
10701 set circlecolors {white blue gray blue blue}
10703 # button for popping up context menus
10704 if {[tk windowingsystem] eq "aqua"} {
10705     set ctxbut <Button-2>
10706 } else {
10707     set ctxbut <Button-3>
10710 ## For msgcat loading, first locate the installation location.
10711 if { [info exists ::env(GITK_MSGSDIR)] } {
10712     ## Msgsdir was manually set in the environment.
10713     set gitk_msgsdir $::env(GITK_MSGSDIR)
10714 } else {
10715     ## Let's guess the prefix from argv0.
10716     set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10717     set gitk_libdir [file join $gitk_prefix share gitk lib]
10718     set gitk_msgsdir [file join $gitk_libdir msgs]
10719     unset gitk_prefix
10722 ## Internationalization (i18n) through msgcat and gettext. See
10723 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10724 package require msgcat
10725 namespace import ::msgcat::mc
10726 ## And eventually load the actual message catalog
10727 ::msgcat::mcload $gitk_msgsdir
10729 catch {source ~/.gitk}
10731 font create optionfont -family sans-serif -size -12
10733 parsefont mainfont $mainfont
10734 eval font create mainfont [fontflags mainfont]
10735 eval font create mainfontbold [fontflags mainfont 1]
10737 parsefont textfont $textfont
10738 eval font create textfont [fontflags textfont]
10739 eval font create textfontbold [fontflags textfont 1]
10741 parsefont uifont $uifont
10742 eval font create uifont [fontflags uifont]
10744 setoptions
10746 # check that we can find a .git directory somewhere...
10747 if {[catch {set gitdir [gitdir]}]} {
10748     show_error {} . [mc "Cannot find a git repository here."]
10749     exit 1
10751 if {![file isdirectory $gitdir]} {
10752     show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10753     exit 1
10756 set selecthead {}
10757 set selectheadid {}
10759 set revtreeargs {}
10760 set cmdline_files {}
10761 set i 0
10762 set revtreeargscmd {}
10763 foreach arg $argv {
10764     switch -glob -- $arg {
10765         "" { }
10766         "--" {
10767             set cmdline_files [lrange $argv [expr {$i + 1}] end]
10768             break
10769         }
10770         "--select-commit=*" {
10771             set selecthead [string range $arg 16 end]
10772         }
10773         "--argscmd=*" {
10774             set revtreeargscmd [string range $arg 10 end]
10775         }
10776         default {
10777             lappend revtreeargs $arg
10778         }
10779     }
10780     incr i
10783 if {$selecthead eq "HEAD"} {
10784     set selecthead {}
10787 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10788     # no -- on command line, but some arguments (other than --argscmd)
10789     if {[catch {
10790         set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10791         set cmdline_files [split $f "\n"]
10792         set n [llength $cmdline_files]
10793         set revtreeargs [lrange $revtreeargs 0 end-$n]
10794         # Unfortunately git rev-parse doesn't produce an error when
10795         # something is both a revision and a filename.  To be consistent
10796         # with git log and git rev-list, check revtreeargs for filenames.
10797         foreach arg $revtreeargs {
10798             if {[file exists $arg]} {
10799                 show_error {} . [mc "Ambiguous argument '%s': both revision\
10800                                  and filename" $arg]
10801                 exit 1
10802             }
10803         }
10804     } err]} {
10805         # unfortunately we get both stdout and stderr in $err,
10806         # so look for "fatal:".
10807         set i [string first "fatal:" $err]
10808         if {$i > 0} {
10809             set err [string range $err [expr {$i + 6}] end]
10810         }
10811         show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10812         exit 1
10813     }
10816 set nullid "0000000000000000000000000000000000000000"
10817 set nullid2 "0000000000000000000000000000000000000001"
10818 set nullfile "/dev/null"
10820 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10822 set runq {}
10823 set history {}
10824 set historyindex 0
10825 set fh_serial 0
10826 set nhl_names {}
10827 set highlight_paths {}
10828 set findpattern {}
10829 set searchdirn -forwards
10830 set boldids {}
10831 set boldnameids {}
10832 set diffelide {0 0}
10833 set markingmatches 0
10834 set linkentercount 0
10835 set need_redisplay 0
10836 set nrows_drawn 0
10837 set firsttabstop 0
10839 set nextviewnum 1
10840 set curview 0
10841 set selectedview 0
10842 set selectedhlview [mc "None"]
10843 set highlight_related [mc "None"]
10844 set highlight_files {}
10845 set viewfiles(0) {}
10846 set viewperm(0) 0
10847 set viewargs(0) {}
10848 set viewargscmd(0) {}
10850 set selectedline {}
10851 set numcommits 0
10852 set loginstance 0
10853 set cmdlineok 0
10854 set stopped 0
10855 set stuffsaved 0
10856 set patchnum 0
10857 set lserial 0
10858 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10859 setcoords
10860 makewindow
10861 # wait for the window to become visible
10862 tkwait visibility .
10863 wm title . "[file tail $argv0]: [file tail [pwd]]"
10864 readrefs
10866 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10867     # create a view for the files/dirs specified on the command line
10868     set curview 1
10869     set selectedview 1
10870     set nextviewnum 2
10871     set viewname(1) [mc "Command line"]
10872     set viewfiles(1) $cmdline_files
10873     set viewargs(1) $revtreeargs
10874     set viewargscmd(1) $revtreeargscmd
10875     set viewperm(1) 0
10876     set vdatemode(1) 0
10877     addviewmenu 1
10878     .bar.view entryconf [mca "Edit view..."] -state normal
10879     .bar.view entryconf [mca "Delete view"] -state normal
10882 if {[info exists permviews]} {
10883     foreach v $permviews {
10884         set n $nextviewnum
10885         incr nextviewnum
10886         set viewname($n) [lindex $v 0]
10887         set viewfiles($n) [lindex $v 1]
10888         set viewargs($n) [lindex $v 2]
10889         set viewargscmd($n) [lindex $v 3]
10890         set viewperm($n) 1
10891         addviewmenu $n
10892     }
10894 getcommits {}