Code

b8b5e80927102cc75e27fddc65b31585d3e67a45
[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     nowbusy blaming [mc "Searching"]
3406     fconfigure $f -blocking 0
3407     set i [reg_instance $f]
3408     set blamestuff($i) {}
3409     set blameinst $i
3410     filerun $f [list read_line_source $f $i]
3413 proc stopblaming {} {
3414     global blameinst
3416     if {[info exists blameinst]} {
3417         stop_instance $blameinst
3418         unset blameinst
3419         notbusy blaming
3420     }
3423 proc read_line_source {fd inst} {
3424     global blamestuff curview commfd blameinst nullid nullid2
3426     while {[gets $fd line] >= 0} {
3427         lappend blamestuff($inst) $line
3428     }
3429     if {![eof $fd]} {
3430         return 1
3431     }
3432     unset commfd($inst)
3433     unset blameinst
3434     notbusy blaming
3435     fconfigure $fd -blocking 1
3436     if {[catch {close $fd} err]} {
3437         error_popup [mc "Error running git blame: %s" $err]
3438         return 0
3439     }
3441     set fname {}
3442     set line [split [lindex $blamestuff($inst) 0] " "]
3443     set id [lindex $line 0]
3444     set lnum [lindex $line 1]
3445     if {[string length $id] == 40 && [string is xdigit $id] &&
3446         [string is digit -strict $lnum]} {
3447         # look for "filename" line
3448         foreach l $blamestuff($inst) {
3449             if {[string match "filename *" $l]} {
3450                 set fname [string range $l 9 end]
3451                 break
3452             }
3453         }
3454     }
3455     if {$fname ne {}} {
3456         # all looks good, select it
3457         if {$id eq $nullid} {
3458             # blame uses all-zeroes to mean not committed,
3459             # which would mean a change in the index
3460             set id $nullid2
3461         }
3462         if {[commitinview $id $curview]} {
3463             selectline [rowofcommit $id] 1 [list $fname $lnum]
3464         } else {
3465             error_popup [mc "That line comes from commit %s, \
3466                              which is not in this view" [shortids $id]]
3467         }
3468     } else {
3469         puts "oops couldn't parse git blame output"
3470     }
3471     return 0
3474 # delete $dir when we see eof on $f (presumably because the child has exited)
3475 proc delete_at_eof {f dir} {
3476     while {[gets $f line] >= 0} {}
3477     if {[eof $f]} {
3478         if {[catch {close $f} err]} {
3479             error_popup "[mc "External diff viewer failed:"] $err"
3480         }
3481         file delete -force $dir
3482         return 0
3483     }
3484     return 1
3487 # Functions for adding and removing shell-type quoting
3489 proc shellquote {str} {
3490     if {![string match "*\['\"\\ \t]*" $str]} {
3491         return $str
3492     }
3493     if {![string match "*\['\"\\]*" $str]} {
3494         return "\"$str\""
3495     }
3496     if {![string match "*'*" $str]} {
3497         return "'$str'"
3498     }
3499     return "\"[string map {\" \\\" \\ \\\\} $str]\""
3502 proc shellarglist {l} {
3503     set str {}
3504     foreach a $l {
3505         if {$str ne {}} {
3506             append str " "
3507         }
3508         append str [shellquote $a]
3509     }
3510     return $str
3513 proc shelldequote {str} {
3514     set ret {}
3515     set used -1
3516     while {1} {
3517         incr used
3518         if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3519             append ret [string range $str $used end]
3520             set used [string length $str]
3521             break
3522         }
3523         set first [lindex $first 0]
3524         set ch [string index $str $first]
3525         if {$first > $used} {
3526             append ret [string range $str $used [expr {$first - 1}]]
3527             set used $first
3528         }
3529         if {$ch eq " " || $ch eq "\t"} break
3530         incr used
3531         if {$ch eq "'"} {
3532             set first [string first "'" $str $used]
3533             if {$first < 0} {
3534                 error "unmatched single-quote"
3535             }
3536             append ret [string range $str $used [expr {$first - 1}]]
3537             set used $first
3538             continue
3539         }
3540         if {$ch eq "\\"} {
3541             if {$used >= [string length $str]} {
3542                 error "trailing backslash"
3543             }
3544             append ret [string index $str $used]
3545             continue
3546         }
3547         # here ch == "\""
3548         while {1} {
3549             if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3550                 error "unmatched double-quote"
3551             }
3552             set first [lindex $first 0]
3553             set ch [string index $str $first]
3554             if {$first > $used} {
3555                 append ret [string range $str $used [expr {$first - 1}]]
3556                 set used $first
3557             }
3558             if {$ch eq "\""} break
3559             incr used
3560             append ret [string index $str $used]
3561             incr used
3562         }
3563     }
3564     return [list $used $ret]
3567 proc shellsplit {str} {
3568     set l {}
3569     while {1} {
3570         set str [string trimleft $str]
3571         if {$str eq {}} break
3572         set dq [shelldequote $str]
3573         set n [lindex $dq 0]
3574         set word [lindex $dq 1]
3575         set str [string range $str $n end]
3576         lappend l $word
3577     }
3578     return $l
3581 # Code to implement multiple views
3583 proc newview {ishighlight} {
3584     global nextviewnum newviewname newishighlight
3585     global revtreeargs viewargscmd newviewopts curview
3587     set newishighlight $ishighlight
3588     set top .gitkview
3589     if {[winfo exists $top]} {
3590         raise $top
3591         return
3592     }
3593     set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3594     set newviewopts($nextviewnum,perm) 0
3595     set newviewopts($nextviewnum,cmd)  $viewargscmd($curview)
3596     decode_view_opts $nextviewnum $revtreeargs
3597     vieweditor $top $nextviewnum [mc "Gitk view definition"]
3600 set known_view_options {
3601     {perm    b    . {}               {mc "Remember this view"}}
3602     {args    t50= + {}               {mc "Commits to include (arguments to git log):"}}
3603     {all     b    * "--all"          {mc "Use all refs"}}
3604     {dorder  b    . {"--date-order" "-d"}      {mc "Strictly sort by date"}}
3605     {lright  b    . "--left-right"   {mc "Mark branch sides"}}
3606     {since   t15  + {"--since=*" "--after=*"}  {mc "Since date:"}}
3607     {until   t15  . {"--until=*" "--before=*"} {mc "Until date:"}}
3608     {limit   t10  + "--max-count=*"  {mc "Max count:"}}
3609     {skip    t10  . "--skip=*"       {mc "Skip:"}}
3610     {first   b    . "--first-parent" {mc "Limit to first parent"}}
3611     {cmd     t50= + {}               {mc "Command to generate more commits to include:"}}
3612     }
3614 proc encode_view_opts {n} {
3615     global known_view_options newviewopts
3617     set rargs [list]
3618     foreach opt $known_view_options {
3619         set patterns [lindex $opt 3]
3620         if {$patterns eq {}} continue
3621         set pattern [lindex $patterns 0]
3623         set val $newviewopts($n,[lindex $opt 0])
3624         
3625         if {[lindex $opt 1] eq "b"} {
3626             if {$val} {
3627                 lappend rargs $pattern
3628             }
3629         } else {
3630             set val [string trim $val]
3631             if {$val ne {}} {
3632                 set pfix [string range $pattern 0 end-1]
3633                 lappend rargs $pfix$val
3634             }
3635         }
3636     }
3637     return [concat $rargs [shellsplit $newviewopts($n,args)]]
3640 proc decode_view_opts {n view_args} {
3641     global known_view_options newviewopts
3643     foreach opt $known_view_options {
3644         if {[lindex $opt 1] eq "b"} {
3645             set val 0
3646         } else {
3647             set val {}
3648         }
3649         set newviewopts($n,[lindex $opt 0]) $val
3650     }
3651     set oargs [list]
3652     foreach arg $view_args {
3653         if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3654             && ![info exists found(limit)]} {
3655             set newviewopts($n,limit) $cnt
3656             set found(limit) 1
3657             continue
3658         }
3659         catch { unset val }
3660         foreach opt $known_view_options {
3661             set id [lindex $opt 0]
3662             if {[info exists found($id)]} continue
3663             foreach pattern [lindex $opt 3] {
3664                 if {![string match $pattern $arg]} continue
3665                 if {[lindex $opt 1] ne "b"} {
3666                     set size [string length $pattern]
3667                     set val [string range $arg [expr {$size-1}] end]
3668                 } else {
3669                     set val 1
3670                 }
3671                 set newviewopts($n,$id) $val
3672                 set found($id) 1
3673                 break
3674             }
3675             if {[info exists val]} break
3676         }
3677         if {[info exists val]} continue
3678         lappend oargs $arg
3679     }
3680     set newviewopts($n,args) [shellarglist $oargs]
3683 proc edit_or_newview {} {
3684     global curview
3686     if {$curview > 0} {
3687         editview
3688     } else {
3689         newview 0
3690     }
3693 proc editview {} {
3694     global curview
3695     global viewname viewperm newviewname newviewopts
3696     global viewargs viewargscmd
3698     set top .gitkvedit-$curview
3699     if {[winfo exists $top]} {
3700         raise $top
3701         return
3702     }
3703     set newviewname($curview)      $viewname($curview)
3704     set newviewopts($curview,perm) $viewperm($curview)
3705     set newviewopts($curview,cmd)  $viewargscmd($curview)
3706     decode_view_opts $curview $viewargs($curview)
3707     vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3710 proc vieweditor {top n title} {
3711     global newviewname newviewopts viewfiles bgcolor
3712     global known_view_options
3714     toplevel $top
3715     wm title $top $title
3716     make_transient $top .
3718     # View name
3719     frame $top.nfr
3720     label $top.nl -text [mc "Name"]
3721     entry $top.name -width 20 -textvariable newviewname($n)
3722     pack $top.nfr -in $top -fill x -pady 5 -padx 3
3723     pack $top.nl -in $top.nfr -side left -padx {0 30}
3724     pack $top.name -in $top.nfr -side left
3726     # View options
3727     set cframe $top.nfr
3728     set cexpand 0
3729     set cnt 0
3730     foreach opt $known_view_options {
3731         set id [lindex $opt 0]
3732         set type [lindex $opt 1]
3733         set flags [lindex $opt 2]
3734         set title [eval [lindex $opt 4]]
3735         set lxpad 0
3737         if {$flags eq "+" || $flags eq "*"} {
3738             set cframe $top.fr$cnt
3739             incr cnt
3740             frame $cframe
3741             pack $cframe -in $top -fill x -pady 3 -padx 3
3742             set cexpand [expr {$flags eq "*"}]
3743         } else {
3744             set lxpad 5
3745         }
3747         if {$type eq "b"} {
3748             checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3749             pack $cframe.c_$id -in $cframe -side left \
3750                 -padx [list $lxpad 0] -expand $cexpand -anchor w
3751         } elseif {[regexp {^t(\d+)$} $type type sz]} {
3752             message $cframe.l_$id -aspect 1500 -text $title
3753             entry $cframe.e_$id -width $sz -background $bgcolor \
3754                 -textvariable newviewopts($n,$id)
3755             pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3756             pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3757         } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3758             message $cframe.l_$id -aspect 1500 -text $title
3759             entry $cframe.e_$id -width $sz -background $bgcolor \
3760                 -textvariable newviewopts($n,$id)
3761             pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3762             pack $cframe.e_$id -in $cframe -side top -fill x
3763         }
3764     }
3766     # Path list
3767     message $top.l -aspect 1500 \
3768         -text [mc "Enter files and directories to include, one per line:"]
3769     pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3770     text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3771     if {[info exists viewfiles($n)]} {
3772         foreach f $viewfiles($n) {
3773             $top.t insert end $f
3774             $top.t insert end "\n"
3775         }
3776         $top.t delete {end - 1c} end
3777         $top.t mark set insert 0.0
3778     }
3779     pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3780     frame $top.buts
3781     button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3782     button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3783     button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3784     bind $top <Control-Return> [list newviewok $top $n]
3785     bind $top <F5> [list newviewok $top $n 1]
3786     bind $top <Escape> [list destroy $top]
3787     grid $top.buts.ok $top.buts.apply $top.buts.can
3788     grid columnconfigure $top.buts 0 -weight 1 -uniform a
3789     grid columnconfigure $top.buts 1 -weight 1 -uniform a
3790     grid columnconfigure $top.buts 2 -weight 1 -uniform a
3791     pack $top.buts -in $top -side top -fill x
3792     focus $top.t
3795 proc doviewmenu {m first cmd op argv} {
3796     set nmenu [$m index end]
3797     for {set i $first} {$i <= $nmenu} {incr i} {
3798         if {[$m entrycget $i -command] eq $cmd} {
3799             eval $m $op $i $argv
3800             break
3801         }
3802     }
3805 proc allviewmenus {n op args} {
3806     # global viewhlmenu
3808     doviewmenu .bar.view 5 [list showview $n] $op $args
3809     # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3812 proc newviewok {top n {apply 0}} {
3813     global nextviewnum newviewperm newviewname newishighlight
3814     global viewname viewfiles viewperm selectedview curview
3815     global viewargs viewargscmd newviewopts viewhlmenu
3817     if {[catch {
3818         set newargs [encode_view_opts $n]
3819     } err]} {
3820         error_popup "[mc "Error in commit selection arguments:"] $err" $top
3821         return
3822     }
3823     set files {}
3824     foreach f [split [$top.t get 0.0 end] "\n"] {
3825         set ft [string trim $f]
3826         if {$ft ne {}} {
3827             lappend files $ft
3828         }
3829     }
3830     if {![info exists viewfiles($n)]} {
3831         # creating a new view
3832         incr nextviewnum
3833         set viewname($n) $newviewname($n)
3834         set viewperm($n) $newviewopts($n,perm)
3835         set viewfiles($n) $files
3836         set viewargs($n) $newargs
3837         set viewargscmd($n) $newviewopts($n,cmd)
3838         addviewmenu $n
3839         if {!$newishighlight} {
3840             run showview $n
3841         } else {
3842             run addvhighlight $n
3843         }
3844     } else {
3845         # editing an existing view
3846         set viewperm($n) $newviewopts($n,perm)
3847         if {$newviewname($n) ne $viewname($n)} {
3848             set viewname($n) $newviewname($n)
3849             doviewmenu .bar.view 5 [list showview $n] \
3850                 entryconf [list -label $viewname($n)]
3851             # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3852                 # entryconf [list -label $viewname($n) -value $viewname($n)]
3853         }
3854         if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3855                 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3856             set viewfiles($n) $files
3857             set viewargs($n) $newargs
3858             set viewargscmd($n) $newviewopts($n,cmd)
3859             if {$curview == $n} {
3860                 run reloadcommits
3861             }
3862         }
3863     }
3864     if {$apply} return
3865     catch {destroy $top}
3868 proc delview {} {
3869     global curview viewperm hlview selectedhlview
3871     if {$curview == 0} return
3872     if {[info exists hlview] && $hlview == $curview} {
3873         set selectedhlview [mc "None"]
3874         unset hlview
3875     }
3876     allviewmenus $curview delete
3877     set viewperm($curview) 0
3878     showview 0
3881 proc addviewmenu {n} {
3882     global viewname viewhlmenu
3884     .bar.view add radiobutton -label $viewname($n) \
3885         -command [list showview $n] -variable selectedview -value $n
3886     #$viewhlmenu add radiobutton -label $viewname($n) \
3887     #   -command [list addvhighlight $n] -variable selectedhlview
3890 proc showview {n} {
3891     global curview cached_commitrow ordertok
3892     global displayorder parentlist rowidlist rowisopt rowfinal
3893     global colormap rowtextx nextcolor canvxmax
3894     global numcommits viewcomplete
3895     global selectedline currentid canv canvy0
3896     global treediffs
3897     global pending_select mainheadid
3898     global commitidx
3899     global selectedview
3900     global hlview selectedhlview commitinterest
3902     if {$n == $curview} return
3903     set selid {}
3904     set ymax [lindex [$canv cget -scrollregion] 3]
3905     set span [$canv yview]
3906     set ytop [expr {[lindex $span 0] * $ymax}]
3907     set ybot [expr {[lindex $span 1] * $ymax}]
3908     set yscreen [expr {($ybot - $ytop) / 2}]
3909     if {$selectedline ne {}} {
3910         set selid $currentid
3911         set y [yc $selectedline]
3912         if {$ytop < $y && $y < $ybot} {
3913             set yscreen [expr {$y - $ytop}]
3914         }
3915     } elseif {[info exists pending_select]} {
3916         set selid $pending_select
3917         unset pending_select
3918     }
3919     unselectline
3920     normalline
3921     catch {unset treediffs}
3922     clear_display
3923     if {[info exists hlview] && $hlview == $n} {
3924         unset hlview
3925         set selectedhlview [mc "None"]
3926     }
3927     catch {unset commitinterest}
3928     catch {unset cached_commitrow}
3929     catch {unset ordertok}
3931     set curview $n
3932     set selectedview $n
3933     .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3934     .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3936     run refill_reflist
3937     if {![info exists viewcomplete($n)]} {
3938         getcommits $selid
3939         return
3940     }
3942     set displayorder {}
3943     set parentlist {}
3944     set rowidlist {}
3945     set rowisopt {}
3946     set rowfinal {}
3947     set numcommits $commitidx($n)
3949     catch {unset colormap}
3950     catch {unset rowtextx}
3951     set nextcolor 0
3952     set canvxmax [$canv cget -width]
3953     set curview $n
3954     set row 0
3955     setcanvscroll
3956     set yf 0
3957     set row {}
3958     if {$selid ne {} && [commitinview $selid $n]} {
3959         set row [rowofcommit $selid]
3960         # try to get the selected row in the same position on the screen
3961         set ymax [lindex [$canv cget -scrollregion] 3]
3962         set ytop [expr {[yc $row] - $yscreen}]
3963         if {$ytop < 0} {
3964             set ytop 0
3965         }
3966         set yf [expr {$ytop * 1.0 / $ymax}]
3967     }
3968     allcanvs yview moveto $yf
3969     drawvisible
3970     if {$row ne {}} {
3971         selectline $row 0
3972     } elseif {!$viewcomplete($n)} {
3973         reset_pending_select $selid
3974     } else {
3975         reset_pending_select {}
3977         if {[commitinview $pending_select $curview]} {
3978             selectline [rowofcommit $pending_select] 1
3979         } else {
3980             set row [first_real_row]
3981             if {$row < $numcommits} {
3982                 selectline $row 0
3983             }
3984         }
3985     }
3986     if {!$viewcomplete($n)} {
3987         if {$numcommits == 0} {
3988             show_status [mc "Reading commits..."]
3989         }
3990     } elseif {$numcommits == 0} {
3991         show_status [mc "No commits selected"]
3992     }
3995 # Stuff relating to the highlighting facility
3997 proc ishighlighted {id} {
3998     global vhighlights fhighlights nhighlights rhighlights
4000     if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4001         return $nhighlights($id)
4002     }
4003     if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4004         return $vhighlights($id)
4005     }
4006     if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4007         return $fhighlights($id)
4008     }
4009     if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4010         return $rhighlights($id)
4011     }
4012     return 0
4015 proc bolden {id font} {
4016     global canv linehtag currentid boldids need_redisplay
4018     # need_redisplay = 1 means the display is stale and about to be redrawn
4019     if {$need_redisplay} return
4020     lappend boldids $id
4021     $canv itemconf $linehtag($id) -font $font
4022     if {[info exists currentid] && $id eq $currentid} {
4023         $canv delete secsel
4024         set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4025                    -outline {{}} -tags secsel \
4026                    -fill [$canv cget -selectbackground]]
4027         $canv lower $t
4028     }
4031 proc bolden_name {id font} {
4032     global canv2 linentag currentid boldnameids need_redisplay
4034     if {$need_redisplay} return
4035     lappend boldnameids $id
4036     $canv2 itemconf $linentag($id) -font $font
4037     if {[info exists currentid] && $id eq $currentid} {
4038         $canv2 delete secsel
4039         set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4040                    -outline {{}} -tags secsel \
4041                    -fill [$canv2 cget -selectbackground]]
4042         $canv2 lower $t
4043     }
4046 proc unbolden {} {
4047     global boldids
4049     set stillbold {}
4050     foreach id $boldids {
4051         if {![ishighlighted $id]} {
4052             bolden $id mainfont
4053         } else {
4054             lappend stillbold $id
4055         }
4056     }
4057     set boldids $stillbold
4060 proc addvhighlight {n} {
4061     global hlview viewcomplete curview vhl_done commitidx
4063     if {[info exists hlview]} {
4064         delvhighlight
4065     }
4066     set hlview $n
4067     if {$n != $curview && ![info exists viewcomplete($n)]} {
4068         start_rev_list $n
4069     }
4070     set vhl_done $commitidx($hlview)
4071     if {$vhl_done > 0} {
4072         drawvisible
4073     }
4076 proc delvhighlight {} {
4077     global hlview vhighlights
4079     if {![info exists hlview]} return
4080     unset hlview
4081     catch {unset vhighlights}
4082     unbolden
4085 proc vhighlightmore {} {
4086     global hlview vhl_done commitidx vhighlights curview
4088     set max $commitidx($hlview)
4089     set vr [visiblerows]
4090     set r0 [lindex $vr 0]
4091     set r1 [lindex $vr 1]
4092     for {set i $vhl_done} {$i < $max} {incr i} {
4093         set id [commitonrow $i $hlview]
4094         if {[commitinview $id $curview]} {
4095             set row [rowofcommit $id]
4096             if {$r0 <= $row && $row <= $r1} {
4097                 if {![highlighted $row]} {
4098                     bolden $id mainfontbold
4099                 }
4100                 set vhighlights($id) 1
4101             }
4102         }
4103     }
4104     set vhl_done $max
4105     return 0
4108 proc askvhighlight {row id} {
4109     global hlview vhighlights iddrawn
4111     if {[commitinview $id $hlview]} {
4112         if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4113             bolden $id mainfontbold
4114         }
4115         set vhighlights($id) 1
4116     } else {
4117         set vhighlights($id) 0
4118     }
4121 proc hfiles_change {} {
4122     global highlight_files filehighlight fhighlights fh_serial
4123     global highlight_paths
4125     if {[info exists filehighlight]} {
4126         # delete previous highlights
4127         catch {close $filehighlight}
4128         unset filehighlight
4129         catch {unset fhighlights}
4130         unbolden
4131         unhighlight_filelist
4132     }
4133     set highlight_paths {}
4134     after cancel do_file_hl $fh_serial
4135     incr fh_serial
4136     if {$highlight_files ne {}} {
4137         after 300 do_file_hl $fh_serial
4138     }
4141 proc gdttype_change {name ix op} {
4142     global gdttype highlight_files findstring findpattern
4144     stopfinding
4145     if {$findstring ne {}} {
4146         if {$gdttype eq [mc "containing:"]} {
4147             if {$highlight_files ne {}} {
4148                 set highlight_files {}
4149                 hfiles_change
4150             }
4151             findcom_change
4152         } else {
4153             if {$findpattern ne {}} {
4154                 set findpattern {}
4155                 findcom_change
4156             }
4157             set highlight_files $findstring
4158             hfiles_change
4159         }
4160         drawvisible
4161     }
4162     # enable/disable findtype/findloc menus too
4165 proc find_change {name ix op} {
4166     global gdttype findstring highlight_files
4168     stopfinding
4169     if {$gdttype eq [mc "containing:"]} {
4170         findcom_change
4171     } else {
4172         if {$highlight_files ne $findstring} {
4173             set highlight_files $findstring
4174             hfiles_change
4175         }
4176     }
4177     drawvisible
4180 proc findcom_change args {
4181     global nhighlights boldnameids
4182     global findpattern findtype findstring gdttype
4184     stopfinding
4185     # delete previous highlights, if any
4186     foreach id $boldnameids {
4187         bolden_name $id mainfont
4188     }
4189     set boldnameids {}
4190     catch {unset nhighlights}
4191     unbolden
4192     unmarkmatches
4193     if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4194         set findpattern {}
4195     } elseif {$findtype eq [mc "Regexp"]} {
4196         set findpattern $findstring
4197     } else {
4198         set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4199                    $findstring]
4200         set findpattern "*$e*"
4201     }
4204 proc makepatterns {l} {
4205     set ret {}
4206     foreach e $l {
4207         set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4208         if {[string index $ee end] eq "/"} {
4209             lappend ret "$ee*"
4210         } else {
4211             lappend ret $ee
4212             lappend ret "$ee/*"
4213         }
4214     }
4215     return $ret
4218 proc do_file_hl {serial} {
4219     global highlight_files filehighlight highlight_paths gdttype fhl_list
4221     if {$gdttype eq [mc "touching paths:"]} {
4222         if {[catch {set paths [shellsplit $highlight_files]}]} return
4223         set highlight_paths [makepatterns $paths]
4224         highlight_filelist
4225         set gdtargs [concat -- $paths]
4226     } elseif {$gdttype eq [mc "adding/removing string:"]} {
4227         set gdtargs [list "-S$highlight_files"]
4228     } else {
4229         # must be "containing:", i.e. we're searching commit info
4230         return
4231     }
4232     set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4233     set filehighlight [open $cmd r+]
4234     fconfigure $filehighlight -blocking 0
4235     filerun $filehighlight readfhighlight
4236     set fhl_list {}
4237     drawvisible
4238     flushhighlights
4241 proc flushhighlights {} {
4242     global filehighlight fhl_list
4244     if {[info exists filehighlight]} {
4245         lappend fhl_list {}
4246         puts $filehighlight ""
4247         flush $filehighlight
4248     }
4251 proc askfilehighlight {row id} {
4252     global filehighlight fhighlights fhl_list
4254     lappend fhl_list $id
4255     set fhighlights($id) -1
4256     puts $filehighlight $id
4259 proc readfhighlight {} {
4260     global filehighlight fhighlights curview iddrawn
4261     global fhl_list find_dirn
4263     if {![info exists filehighlight]} {
4264         return 0
4265     }
4266     set nr 0
4267     while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4268         set line [string trim $line]
4269         set i [lsearch -exact $fhl_list $line]
4270         if {$i < 0} continue
4271         for {set j 0} {$j < $i} {incr j} {
4272             set id [lindex $fhl_list $j]
4273             set fhighlights($id) 0
4274         }
4275         set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4276         if {$line eq {}} continue
4277         if {![commitinview $line $curview]} continue
4278         if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4279             bolden $line mainfontbold
4280         }
4281         set fhighlights($line) 1
4282     }
4283     if {[eof $filehighlight]} {
4284         # strange...
4285         puts "oops, git diff-tree died"
4286         catch {close $filehighlight}
4287         unset filehighlight
4288         return 0
4289     }
4290     if {[info exists find_dirn]} {
4291         run findmore
4292     }
4293     return 1
4296 proc doesmatch {f} {
4297     global findtype findpattern
4299     if {$findtype eq [mc "Regexp"]} {
4300         return [regexp $findpattern $f]
4301     } elseif {$findtype eq [mc "IgnCase"]} {
4302         return [string match -nocase $findpattern $f]
4303     } else {
4304         return [string match $findpattern $f]
4305     }
4308 proc askfindhighlight {row id} {
4309     global nhighlights commitinfo iddrawn
4310     global findloc
4311     global markingmatches
4313     if {![info exists commitinfo($id)]} {
4314         getcommit $id
4315     }
4316     set info $commitinfo($id)
4317     set isbold 0
4318     set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4319     foreach f $info ty $fldtypes {
4320         if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4321             [doesmatch $f]} {
4322             if {$ty eq [mc "Author"]} {
4323                 set isbold 2
4324                 break
4325             }
4326             set isbold 1
4327         }
4328     }
4329     if {$isbold && [info exists iddrawn($id)]} {
4330         if {![ishighlighted $id]} {
4331             bolden $id mainfontbold
4332             if {$isbold > 1} {
4333                 bolden_name $id mainfontbold
4334             }
4335         }
4336         if {$markingmatches} {
4337             markrowmatches $row $id
4338         }
4339     }
4340     set nhighlights($id) $isbold
4343 proc markrowmatches {row id} {
4344     global canv canv2 linehtag linentag commitinfo findloc
4346     set headline [lindex $commitinfo($id) 0]
4347     set author [lindex $commitinfo($id) 1]
4348     $canv delete match$row
4349     $canv2 delete match$row
4350     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4351         set m [findmatches $headline]
4352         if {$m ne {}} {
4353             markmatches $canv $row $headline $linehtag($id) $m \
4354                 [$canv itemcget $linehtag($id) -font] $row
4355         }
4356     }
4357     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4358         set m [findmatches $author]
4359         if {$m ne {}} {
4360             markmatches $canv2 $row $author $linentag($id) $m \
4361                 [$canv2 itemcget $linentag($id) -font] $row
4362         }
4363     }
4366 proc vrel_change {name ix op} {
4367     global highlight_related
4369     rhighlight_none
4370     if {$highlight_related ne [mc "None"]} {
4371         run drawvisible
4372     }
4375 # prepare for testing whether commits are descendents or ancestors of a
4376 proc rhighlight_sel {a} {
4377     global descendent desc_todo ancestor anc_todo
4378     global highlight_related
4380     catch {unset descendent}
4381     set desc_todo [list $a]
4382     catch {unset ancestor}
4383     set anc_todo [list $a]
4384     if {$highlight_related ne [mc "None"]} {
4385         rhighlight_none
4386         run drawvisible
4387     }
4390 proc rhighlight_none {} {
4391     global rhighlights
4393     catch {unset rhighlights}
4394     unbolden
4397 proc is_descendent {a} {
4398     global curview children descendent desc_todo
4400     set v $curview
4401     set la [rowofcommit $a]
4402     set todo $desc_todo
4403     set leftover {}
4404     set done 0
4405     for {set i 0} {$i < [llength $todo]} {incr i} {
4406         set do [lindex $todo $i]
4407         if {[rowofcommit $do] < $la} {
4408             lappend leftover $do
4409             continue
4410         }
4411         foreach nk $children($v,$do) {
4412             if {![info exists descendent($nk)]} {
4413                 set descendent($nk) 1
4414                 lappend todo $nk
4415                 if {$nk eq $a} {
4416                     set done 1
4417                 }
4418             }
4419         }
4420         if {$done} {
4421             set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4422             return
4423         }
4424     }
4425     set descendent($a) 0
4426     set desc_todo $leftover
4429 proc is_ancestor {a} {
4430     global curview parents ancestor anc_todo
4432     set v $curview
4433     set la [rowofcommit $a]
4434     set todo $anc_todo
4435     set leftover {}
4436     set done 0
4437     for {set i 0} {$i < [llength $todo]} {incr i} {
4438         set do [lindex $todo $i]
4439         if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4440             lappend leftover $do
4441             continue
4442         }
4443         foreach np $parents($v,$do) {
4444             if {![info exists ancestor($np)]} {
4445                 set ancestor($np) 1
4446                 lappend todo $np
4447                 if {$np eq $a} {
4448                     set done 1
4449                 }
4450             }
4451         }
4452         if {$done} {
4453             set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4454             return
4455         }
4456     }
4457     set ancestor($a) 0
4458     set anc_todo $leftover
4461 proc askrelhighlight {row id} {
4462     global descendent highlight_related iddrawn rhighlights
4463     global selectedline ancestor
4465     if {$selectedline eq {}} return
4466     set isbold 0
4467     if {$highlight_related eq [mc "Descendant"] ||
4468         $highlight_related eq [mc "Not descendant"]} {
4469         if {![info exists descendent($id)]} {
4470             is_descendent $id
4471         }
4472         if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4473             set isbold 1
4474         }
4475     } elseif {$highlight_related eq [mc "Ancestor"] ||
4476               $highlight_related eq [mc "Not ancestor"]} {
4477         if {![info exists ancestor($id)]} {
4478             is_ancestor $id
4479         }
4480         if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4481             set isbold 1
4482         }
4483     }
4484     if {[info exists iddrawn($id)]} {
4485         if {$isbold && ![ishighlighted $id]} {
4486             bolden $id mainfontbold
4487         }
4488     }
4489     set rhighlights($id) $isbold
4492 # Graph layout functions
4494 proc shortids {ids} {
4495     set res {}
4496     foreach id $ids {
4497         if {[llength $id] > 1} {
4498             lappend res [shortids $id]
4499         } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4500             lappend res [string range $id 0 7]
4501         } else {
4502             lappend res $id
4503         }
4504     }
4505     return $res
4508 proc ntimes {n o} {
4509     set ret {}
4510     set o [list $o]
4511     for {set mask 1} {$mask <= $n} {incr mask $mask} {
4512         if {($n & $mask) != 0} {
4513             set ret [concat $ret $o]
4514         }
4515         set o [concat $o $o]
4516     }
4517     return $ret
4520 proc ordertoken {id} {
4521     global ordertok curview varcid varcstart varctok curview parents children
4522     global nullid nullid2
4524     if {[info exists ordertok($id)]} {
4525         return $ordertok($id)
4526     }
4527     set origid $id
4528     set todo {}
4529     while {1} {
4530         if {[info exists varcid($curview,$id)]} {
4531             set a $varcid($curview,$id)
4532             set p [lindex $varcstart($curview) $a]
4533         } else {
4534             set p [lindex $children($curview,$id) 0]
4535         }
4536         if {[info exists ordertok($p)]} {
4537             set tok $ordertok($p)
4538             break
4539         }
4540         set id [first_real_child $curview,$p]
4541         if {$id eq {}} {
4542             # it's a root
4543             set tok [lindex $varctok($curview) $varcid($curview,$p)]
4544             break
4545         }
4546         if {[llength $parents($curview,$id)] == 1} {
4547             lappend todo [list $p {}]
4548         } else {
4549             set j [lsearch -exact $parents($curview,$id) $p]
4550             if {$j < 0} {
4551                 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4552             }
4553             lappend todo [list $p [strrep $j]]
4554         }
4555     }
4556     for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4557         set p [lindex $todo $i 0]
4558         append tok [lindex $todo $i 1]
4559         set ordertok($p) $tok
4560     }
4561     set ordertok($origid) $tok
4562     return $tok
4565 # Work out where id should go in idlist so that order-token
4566 # values increase from left to right
4567 proc idcol {idlist id {i 0}} {
4568     set t [ordertoken $id]
4569     if {$i < 0} {
4570         set i 0
4571     }
4572     if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4573         if {$i > [llength $idlist]} {
4574             set i [llength $idlist]
4575         }
4576         while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4577         incr i
4578     } else {
4579         if {$t > [ordertoken [lindex $idlist $i]]} {
4580             while {[incr i] < [llength $idlist] &&
4581                    $t >= [ordertoken [lindex $idlist $i]]} {}
4582         }
4583     }
4584     return $i
4587 proc initlayout {} {
4588     global rowidlist rowisopt rowfinal displayorder parentlist
4589     global numcommits canvxmax canv
4590     global nextcolor
4591     global colormap rowtextx
4593     set numcommits 0
4594     set displayorder {}
4595     set parentlist {}
4596     set nextcolor 0
4597     set rowidlist {}
4598     set rowisopt {}
4599     set rowfinal {}
4600     set canvxmax [$canv cget -width]
4601     catch {unset colormap}
4602     catch {unset rowtextx}
4603     setcanvscroll
4606 proc setcanvscroll {} {
4607     global canv canv2 canv3 numcommits linespc canvxmax canvy0
4608     global lastscrollset lastscrollrows
4610     set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4611     $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4612     $canv2 conf -scrollregion [list 0 0 0 $ymax]
4613     $canv3 conf -scrollregion [list 0 0 0 $ymax]
4614     set lastscrollset [clock clicks -milliseconds]
4615     set lastscrollrows $numcommits
4618 proc visiblerows {} {
4619     global canv numcommits linespc
4621     set ymax [lindex [$canv cget -scrollregion] 3]
4622     if {$ymax eq {} || $ymax == 0} return
4623     set f [$canv yview]
4624     set y0 [expr {int([lindex $f 0] * $ymax)}]
4625     set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4626     if {$r0 < 0} {
4627         set r0 0
4628     }
4629     set y1 [expr {int([lindex $f 1] * $ymax)}]
4630     set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4631     if {$r1 >= $numcommits} {
4632         set r1 [expr {$numcommits - 1}]
4633     }
4634     return [list $r0 $r1]
4637 proc layoutmore {} {
4638     global commitidx viewcomplete curview
4639     global numcommits pending_select curview
4640     global lastscrollset lastscrollrows
4642     if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4643         [clock clicks -milliseconds] - $lastscrollset > 500} {
4644         setcanvscroll
4645     }
4646     if {[info exists pending_select] &&
4647         [commitinview $pending_select $curview]} {
4648         update
4649         selectline [rowofcommit $pending_select] 1
4650     }
4651     drawvisible
4654 # With path limiting, we mightn't get the actual HEAD commit,
4655 # so ask git rev-list what is the first ancestor of HEAD that
4656 # touches a file in the path limit.
4657 proc get_viewmainhead {view} {
4658     global viewmainheadid vfilelimit viewinstances mainheadid
4660     catch {
4661         set rfd [open [concat | git rev-list -1 $mainheadid \
4662                            -- $vfilelimit($view)] r]
4663         set j [reg_instance $rfd]
4664         lappend viewinstances($view) $j
4665         fconfigure $rfd -blocking 0
4666         filerun $rfd [list getviewhead $rfd $j $view]
4667         set viewmainheadid($curview) {}
4668     }
4671 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4672 proc getviewhead {fd inst view} {
4673     global viewmainheadid commfd curview viewinstances showlocalchanges
4675     set id {}
4676     if {[gets $fd line] < 0} {
4677         if {![eof $fd]} {
4678             return 1
4679         }
4680     } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4681         set id $line
4682     }
4683     set viewmainheadid($view) $id
4684     close $fd
4685     unset commfd($inst)
4686     set i [lsearch -exact $viewinstances($view) $inst]
4687     if {$i >= 0} {
4688         set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4689     }
4690     if {$showlocalchanges && $id ne {} && $view == $curview} {
4691         doshowlocalchanges
4692     }
4693     return 0
4696 proc doshowlocalchanges {} {
4697     global curview viewmainheadid
4699     if {$viewmainheadid($curview) eq {}} return
4700     if {[commitinview $viewmainheadid($curview) $curview]} {
4701         dodiffindex
4702     } else {
4703         interestedin $viewmainheadid($curview) dodiffindex
4704     }
4707 proc dohidelocalchanges {} {
4708     global nullid nullid2 lserial curview
4710     if {[commitinview $nullid $curview]} {
4711         removefakerow $nullid
4712     }
4713     if {[commitinview $nullid2 $curview]} {
4714         removefakerow $nullid2
4715     }
4716     incr lserial
4719 # spawn off a process to do git diff-index --cached HEAD
4720 proc dodiffindex {} {
4721     global lserial showlocalchanges vfilelimit curview
4722     global isworktree
4724     if {!$showlocalchanges || !$isworktree} return
4725     incr lserial
4726     set cmd "|git diff-index --cached HEAD"
4727     if {$vfilelimit($curview) ne {}} {
4728         set cmd [concat $cmd -- $vfilelimit($curview)]
4729     }
4730     set fd [open $cmd r]
4731     fconfigure $fd -blocking 0
4732     set i [reg_instance $fd]
4733     filerun $fd [list readdiffindex $fd $lserial $i]
4736 proc readdiffindex {fd serial inst} {
4737     global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4738     global vfilelimit
4740     set isdiff 1
4741     if {[gets $fd line] < 0} {
4742         if {![eof $fd]} {
4743             return 1
4744         }
4745         set isdiff 0
4746     }
4747     # we only need to see one line and we don't really care what it says...
4748     stop_instance $inst
4750     if {$serial != $lserial} {
4751         return 0
4752     }
4754     # now see if there are any local changes not checked in to the index
4755     set cmd "|git diff-files"
4756     if {$vfilelimit($curview) ne {}} {
4757         set cmd [concat $cmd -- $vfilelimit($curview)]
4758     }
4759     set fd [open $cmd r]
4760     fconfigure $fd -blocking 0
4761     set i [reg_instance $fd]
4762     filerun $fd [list readdifffiles $fd $serial $i]
4764     if {$isdiff && ![commitinview $nullid2 $curview]} {
4765         # add the line for the changes in the index to the graph
4766         set hl [mc "Local changes checked in to index but not committed"]
4767         set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
4768         set commitdata($nullid2) "\n    $hl\n"
4769         if {[commitinview $nullid $curview]} {
4770             removefakerow $nullid
4771         }
4772         insertfakerow $nullid2 $viewmainheadid($curview)
4773     } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4774         if {[commitinview $nullid $curview]} {
4775             removefakerow $nullid
4776         }
4777         removefakerow $nullid2
4778     }
4779     return 0
4782 proc readdifffiles {fd serial inst} {
4783     global viewmainheadid nullid nullid2 curview
4784     global commitinfo commitdata lserial
4786     set isdiff 1
4787     if {[gets $fd line] < 0} {
4788         if {![eof $fd]} {
4789             return 1
4790         }
4791         set isdiff 0
4792     }
4793     # we only need to see one line and we don't really care what it says...
4794     stop_instance $inst
4796     if {$serial != $lserial} {
4797         return 0
4798     }
4800     if {$isdiff && ![commitinview $nullid $curview]} {
4801         # add the line for the local diff to the graph
4802         set hl [mc "Local uncommitted changes, not checked in to index"]
4803         set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
4804         set commitdata($nullid) "\n    $hl\n"
4805         if {[commitinview $nullid2 $curview]} {
4806             set p $nullid2
4807         } else {
4808             set p $viewmainheadid($curview)
4809         }
4810         insertfakerow $nullid $p
4811     } elseif {!$isdiff && [commitinview $nullid $curview]} {
4812         removefakerow $nullid
4813     }
4814     return 0
4817 proc nextuse {id row} {
4818     global curview children
4820     if {[info exists children($curview,$id)]} {
4821         foreach kid $children($curview,$id) {
4822             if {![commitinview $kid $curview]} {
4823                 return -1
4824             }
4825             if {[rowofcommit $kid] > $row} {
4826                 return [rowofcommit $kid]
4827             }
4828         }
4829     }
4830     if {[commitinview $id $curview]} {
4831         return [rowofcommit $id]
4832     }
4833     return -1
4836 proc prevuse {id row} {
4837     global curview children
4839     set ret -1
4840     if {[info exists children($curview,$id)]} {
4841         foreach kid $children($curview,$id) {
4842             if {![commitinview $kid $curview]} break
4843             if {[rowofcommit $kid] < $row} {
4844                 set ret [rowofcommit $kid]
4845             }
4846         }
4847     }
4848     return $ret
4851 proc make_idlist {row} {
4852     global displayorder parentlist uparrowlen downarrowlen mingaplen
4853     global commitidx curview children
4855     set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4856     if {$r < 0} {
4857         set r 0
4858     }
4859     set ra [expr {$row - $downarrowlen}]
4860     if {$ra < 0} {
4861         set ra 0
4862     }
4863     set rb [expr {$row + $uparrowlen}]
4864     if {$rb > $commitidx($curview)} {
4865         set rb $commitidx($curview)
4866     }
4867     make_disporder $r [expr {$rb + 1}]
4868     set ids {}
4869     for {} {$r < $ra} {incr r} {
4870         set nextid [lindex $displayorder [expr {$r + 1}]]
4871         foreach p [lindex $parentlist $r] {
4872             if {$p eq $nextid} continue
4873             set rn [nextuse $p $r]
4874             if {$rn >= $row &&
4875                 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4876                 lappend ids [list [ordertoken $p] $p]
4877             }
4878         }
4879     }
4880     for {} {$r < $row} {incr r} {
4881         set nextid [lindex $displayorder [expr {$r + 1}]]
4882         foreach p [lindex $parentlist $r] {
4883             if {$p eq $nextid} continue
4884             set rn [nextuse $p $r]
4885             if {$rn < 0 || $rn >= $row} {
4886                 lappend ids [list [ordertoken $p] $p]
4887             }
4888         }
4889     }
4890     set id [lindex $displayorder $row]
4891     lappend ids [list [ordertoken $id] $id]
4892     while {$r < $rb} {
4893         foreach p [lindex $parentlist $r] {
4894             set firstkid [lindex $children($curview,$p) 0]
4895             if {[rowofcommit $firstkid] < $row} {
4896                 lappend ids [list [ordertoken $p] $p]
4897             }
4898         }
4899         incr r
4900         set id [lindex $displayorder $r]
4901         if {$id ne {}} {
4902             set firstkid [lindex $children($curview,$id) 0]
4903             if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4904                 lappend ids [list [ordertoken $id] $id]
4905             }
4906         }
4907     }
4908     set idlist {}
4909     foreach idx [lsort -unique $ids] {
4910         lappend idlist [lindex $idx 1]
4911     }
4912     return $idlist
4915 proc rowsequal {a b} {
4916     while {[set i [lsearch -exact $a {}]] >= 0} {
4917         set a [lreplace $a $i $i]
4918     }
4919     while {[set i [lsearch -exact $b {}]] >= 0} {
4920         set b [lreplace $b $i $i]
4921     }
4922     return [expr {$a eq $b}]
4925 proc makeupline {id row rend col} {
4926     global rowidlist uparrowlen downarrowlen mingaplen
4928     for {set r $rend} {1} {set r $rstart} {
4929         set rstart [prevuse $id $r]
4930         if {$rstart < 0} return
4931         if {$rstart < $row} break
4932     }
4933     if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4934         set rstart [expr {$rend - $uparrowlen - 1}]
4935     }
4936     for {set r $rstart} {[incr r] <= $row} {} {
4937         set idlist [lindex $rowidlist $r]
4938         if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4939             set col [idcol $idlist $id $col]
4940             lset rowidlist $r [linsert $idlist $col $id]
4941             changedrow $r
4942         }
4943     }
4946 proc layoutrows {row endrow} {
4947     global rowidlist rowisopt rowfinal displayorder
4948     global uparrowlen downarrowlen maxwidth mingaplen
4949     global children parentlist
4950     global commitidx viewcomplete curview
4952     make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4953     set idlist {}
4954     if {$row > 0} {
4955         set rm1 [expr {$row - 1}]
4956         foreach id [lindex $rowidlist $rm1] {
4957             if {$id ne {}} {
4958                 lappend idlist $id
4959             }
4960         }
4961         set final [lindex $rowfinal $rm1]
4962     }
4963     for {} {$row < $endrow} {incr row} {
4964         set rm1 [expr {$row - 1}]
4965         if {$rm1 < 0 || $idlist eq {}} {
4966             set idlist [make_idlist $row]
4967             set final 1
4968         } else {
4969             set id [lindex $displayorder $rm1]
4970             set col [lsearch -exact $idlist $id]
4971             set idlist [lreplace $idlist $col $col]
4972             foreach p [lindex $parentlist $rm1] {
4973                 if {[lsearch -exact $idlist $p] < 0} {
4974                     set col [idcol $idlist $p $col]
4975                     set idlist [linsert $idlist $col $p]
4976                     # if not the first child, we have to insert a line going up
4977                     if {$id ne [lindex $children($curview,$p) 0]} {
4978                         makeupline $p $rm1 $row $col
4979                     }
4980                 }
4981             }
4982             set id [lindex $displayorder $row]
4983             if {$row > $downarrowlen} {
4984                 set termrow [expr {$row - $downarrowlen - 1}]
4985                 foreach p [lindex $parentlist $termrow] {
4986                     set i [lsearch -exact $idlist $p]
4987                     if {$i < 0} continue
4988                     set nr [nextuse $p $termrow]
4989                     if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
4990                         set idlist [lreplace $idlist $i $i]
4991                     }
4992                 }
4993             }
4994             set col [lsearch -exact $idlist $id]
4995             if {$col < 0} {
4996                 set col [idcol $idlist $id]
4997                 set idlist [linsert $idlist $col $id]
4998                 if {$children($curview,$id) ne {}} {
4999                     makeupline $id $rm1 $row $col
5000                 }
5001             }
5002             set r [expr {$row + $uparrowlen - 1}]
5003             if {$r < $commitidx($curview)} {
5004                 set x $col
5005                 foreach p [lindex $parentlist $r] {
5006                     if {[lsearch -exact $idlist $p] >= 0} continue
5007                     set fk [lindex $children($curview,$p) 0]
5008                     if {[rowofcommit $fk] < $row} {
5009                         set x [idcol $idlist $p $x]
5010                         set idlist [linsert $idlist $x $p]
5011                     }
5012                 }
5013                 if {[incr r] < $commitidx($curview)} {
5014                     set p [lindex $displayorder $r]
5015                     if {[lsearch -exact $idlist $p] < 0} {
5016                         set fk [lindex $children($curview,$p) 0]
5017                         if {$fk ne {} && [rowofcommit $fk] < $row} {
5018                             set x [idcol $idlist $p $x]
5019                             set idlist [linsert $idlist $x $p]
5020                         }
5021                     }
5022                 }
5023             }
5024         }
5025         if {$final && !$viewcomplete($curview) &&
5026             $row + $uparrowlen + $mingaplen + $downarrowlen
5027                 >= $commitidx($curview)} {
5028             set final 0
5029         }
5030         set l [llength $rowidlist]
5031         if {$row == $l} {
5032             lappend rowidlist $idlist
5033             lappend rowisopt 0
5034             lappend rowfinal $final
5035         } elseif {$row < $l} {
5036             if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5037                 lset rowidlist $row $idlist
5038                 changedrow $row
5039             }
5040             lset rowfinal $row $final
5041         } else {
5042             set pad [ntimes [expr {$row - $l}] {}]
5043             set rowidlist [concat $rowidlist $pad]
5044             lappend rowidlist $idlist
5045             set rowfinal [concat $rowfinal $pad]
5046             lappend rowfinal $final
5047             set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5048         }
5049     }
5050     return $row
5053 proc changedrow {row} {
5054     global displayorder iddrawn rowisopt need_redisplay
5056     set l [llength $rowisopt]
5057     if {$row < $l} {
5058         lset rowisopt $row 0
5059         if {$row + 1 < $l} {
5060             lset rowisopt [expr {$row + 1}] 0
5061             if {$row + 2 < $l} {
5062                 lset rowisopt [expr {$row + 2}] 0
5063             }
5064         }
5065     }
5066     set id [lindex $displayorder $row]
5067     if {[info exists iddrawn($id)]} {
5068         set need_redisplay 1
5069     }
5072 proc insert_pad {row col npad} {
5073     global rowidlist
5075     set pad [ntimes $npad {}]
5076     set idlist [lindex $rowidlist $row]
5077     set bef [lrange $idlist 0 [expr {$col - 1}]]
5078     set aft [lrange $idlist $col end]
5079     set i [lsearch -exact $aft {}]
5080     if {$i > 0} {
5081         set aft [lreplace $aft $i $i]
5082     }
5083     lset rowidlist $row [concat $bef $pad $aft]
5084     changedrow $row
5087 proc optimize_rows {row col endrow} {
5088     global rowidlist rowisopt displayorder curview children
5090     if {$row < 1} {
5091         set row 1
5092     }
5093     for {} {$row < $endrow} {incr row; set col 0} {
5094         if {[lindex $rowisopt $row]} continue
5095         set haspad 0
5096         set y0 [expr {$row - 1}]
5097         set ym [expr {$row - 2}]
5098         set idlist [lindex $rowidlist $row]
5099         set previdlist [lindex $rowidlist $y0]
5100         if {$idlist eq {} || $previdlist eq {}} continue
5101         if {$ym >= 0} {
5102             set pprevidlist [lindex $rowidlist $ym]
5103             if {$pprevidlist eq {}} continue
5104         } else {
5105             set pprevidlist {}
5106         }
5107         set x0 -1
5108         set xm -1
5109         for {} {$col < [llength $idlist]} {incr col} {
5110             set id [lindex $idlist $col]
5111             if {[lindex $previdlist $col] eq $id} continue
5112             if {$id eq {}} {
5113                 set haspad 1
5114                 continue
5115             }
5116             set x0 [lsearch -exact $previdlist $id]
5117             if {$x0 < 0} continue
5118             set z [expr {$x0 - $col}]
5119             set isarrow 0
5120             set z0 {}
5121             if {$ym >= 0} {
5122                 set xm [lsearch -exact $pprevidlist $id]
5123                 if {$xm >= 0} {
5124                     set z0 [expr {$xm - $x0}]
5125                 }
5126             }
5127             if {$z0 eq {}} {
5128                 # if row y0 is the first child of $id then it's not an arrow
5129                 if {[lindex $children($curview,$id) 0] ne
5130                     [lindex $displayorder $y0]} {
5131                     set isarrow 1
5132                 }
5133             }
5134             if {!$isarrow && $id ne [lindex $displayorder $row] &&
5135                 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5136                 set isarrow 1
5137             }
5138             # Looking at lines from this row to the previous row,
5139             # make them go straight up if they end in an arrow on
5140             # the previous row; otherwise make them go straight up
5141             # or at 45 degrees.
5142             if {$z < -1 || ($z < 0 && $isarrow)} {
5143                 # Line currently goes left too much;
5144                 # insert pads in the previous row, then optimize it
5145                 set npad [expr {-1 - $z + $isarrow}]
5146                 insert_pad $y0 $x0 $npad
5147                 if {$y0 > 0} {
5148                     optimize_rows $y0 $x0 $row
5149                 }
5150                 set previdlist [lindex $rowidlist $y0]
5151                 set x0 [lsearch -exact $previdlist $id]
5152                 set z [expr {$x0 - $col}]
5153                 if {$z0 ne {}} {
5154                     set pprevidlist [lindex $rowidlist $ym]
5155                     set xm [lsearch -exact $pprevidlist $id]
5156                     set z0 [expr {$xm - $x0}]
5157                 }
5158             } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5159                 # Line currently goes right too much;
5160                 # insert pads in this line
5161                 set npad [expr {$z - 1 + $isarrow}]
5162                 insert_pad $row $col $npad
5163                 set idlist [lindex $rowidlist $row]
5164                 incr col $npad
5165                 set z [expr {$x0 - $col}]
5166                 set haspad 1
5167             }
5168             if {$z0 eq {} && !$isarrow && $ym >= 0} {
5169                 # this line links to its first child on row $row-2
5170                 set id [lindex $displayorder $ym]
5171                 set xc [lsearch -exact $pprevidlist $id]
5172                 if {$xc >= 0} {
5173                     set z0 [expr {$xc - $x0}]
5174                 }
5175             }
5176             # avoid lines jigging left then immediately right
5177             if {$z0 ne {} && $z < 0 && $z0 > 0} {
5178                 insert_pad $y0 $x0 1
5179                 incr x0
5180                 optimize_rows $y0 $x0 $row
5181                 set previdlist [lindex $rowidlist $y0]
5182             }
5183         }
5184         if {!$haspad} {
5185             # Find the first column that doesn't have a line going right
5186             for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5187                 set id [lindex $idlist $col]
5188                 if {$id eq {}} break
5189                 set x0 [lsearch -exact $previdlist $id]
5190                 if {$x0 < 0} {
5191                     # check if this is the link to the first child
5192                     set kid [lindex $displayorder $y0]
5193                     if {[lindex $children($curview,$id) 0] eq $kid} {
5194                         # it is, work out offset to child
5195                         set x0 [lsearch -exact $previdlist $kid]
5196                     }
5197                 }
5198                 if {$x0 <= $col} break
5199             }
5200             # Insert a pad at that column as long as it has a line and
5201             # isn't the last column
5202             if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5203                 set idlist [linsert $idlist $col {}]
5204                 lset rowidlist $row $idlist
5205                 changedrow $row
5206             }
5207         }
5208     }
5211 proc xc {row col} {
5212     global canvx0 linespc
5213     return [expr {$canvx0 + $col * $linespc}]
5216 proc yc {row} {
5217     global canvy0 linespc
5218     return [expr {$canvy0 + $row * $linespc}]
5221 proc linewidth {id} {
5222     global thickerline lthickness
5224     set wid $lthickness
5225     if {[info exists thickerline] && $id eq $thickerline} {
5226         set wid [expr {2 * $lthickness}]
5227     }
5228     return $wid
5231 proc rowranges {id} {
5232     global curview children uparrowlen downarrowlen
5233     global rowidlist
5235     set kids $children($curview,$id)
5236     if {$kids eq {}} {
5237         return {}
5238     }
5239     set ret {}
5240     lappend kids $id
5241     foreach child $kids {
5242         if {![commitinview $child $curview]} break
5243         set row [rowofcommit $child]
5244         if {![info exists prev]} {
5245             lappend ret [expr {$row + 1}]
5246         } else {
5247             if {$row <= $prevrow} {
5248                 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5249             }
5250             # see if the line extends the whole way from prevrow to row
5251             if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5252                 [lsearch -exact [lindex $rowidlist \
5253                             [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5254                 # it doesn't, see where it ends
5255                 set r [expr {$prevrow + $downarrowlen}]
5256                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5257                     while {[incr r -1] > $prevrow &&
5258                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5259                 } else {
5260                     while {[incr r] <= $row &&
5261                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5262                     incr r -1
5263                 }
5264                 lappend ret $r
5265                 # see where it starts up again
5266                 set r [expr {$row - $uparrowlen}]
5267                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5268                     while {[incr r] < $row &&
5269                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5270                 } else {
5271                     while {[incr r -1] >= $prevrow &&
5272                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5273                     incr r
5274                 }
5275                 lappend ret $r
5276             }
5277         }
5278         if {$child eq $id} {
5279             lappend ret $row
5280         }
5281         set prev $child
5282         set prevrow $row
5283     }
5284     return $ret
5287 proc drawlineseg {id row endrow arrowlow} {
5288     global rowidlist displayorder iddrawn linesegs
5289     global canv colormap linespc curview maxlinelen parentlist
5291     set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5292     set le [expr {$row + 1}]
5293     set arrowhigh 1
5294     while {1} {
5295         set c [lsearch -exact [lindex $rowidlist $le] $id]
5296         if {$c < 0} {
5297             incr le -1
5298             break
5299         }
5300         lappend cols $c
5301         set x [lindex $displayorder $le]
5302         if {$x eq $id} {
5303             set arrowhigh 0
5304             break
5305         }
5306         if {[info exists iddrawn($x)] || $le == $endrow} {
5307             set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5308             if {$c >= 0} {
5309                 lappend cols $c
5310                 set arrowhigh 0
5311             }
5312             break
5313         }
5314         incr le
5315     }
5316     if {$le <= $row} {
5317         return $row
5318     }
5320     set lines {}
5321     set i 0
5322     set joinhigh 0
5323     if {[info exists linesegs($id)]} {
5324         set lines $linesegs($id)
5325         foreach li $lines {
5326             set r0 [lindex $li 0]
5327             if {$r0 > $row} {
5328                 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5329                     set joinhigh 1
5330                 }
5331                 break
5332             }
5333             incr i
5334         }
5335     }
5336     set joinlow 0
5337     if {$i > 0} {
5338         set li [lindex $lines [expr {$i-1}]]
5339         set r1 [lindex $li 1]
5340         if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5341             set joinlow 1
5342         }
5343     }
5345     set x [lindex $cols [expr {$le - $row}]]
5346     set xp [lindex $cols [expr {$le - 1 - $row}]]
5347     set dir [expr {$xp - $x}]
5348     if {$joinhigh} {
5349         set ith [lindex $lines $i 2]
5350         set coords [$canv coords $ith]
5351         set ah [$canv itemcget $ith -arrow]
5352         set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5353         set x2 [lindex $cols [expr {$le + 1 - $row}]]
5354         if {$x2 ne {} && $x - $x2 == $dir} {
5355             set coords [lrange $coords 0 end-2]
5356         }
5357     } else {
5358         set coords [list [xc $le $x] [yc $le]]
5359     }
5360     if {$joinlow} {
5361         set itl [lindex $lines [expr {$i-1}] 2]
5362         set al [$canv itemcget $itl -arrow]
5363         set arrowlow [expr {$al eq "last" || $al eq "both"}]
5364     } elseif {$arrowlow} {
5365         if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5366             [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5367             set arrowlow 0
5368         }
5369     }
5370     set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5371     for {set y $le} {[incr y -1] > $row} {} {
5372         set x $xp
5373         set xp [lindex $cols [expr {$y - 1 - $row}]]
5374         set ndir [expr {$xp - $x}]
5375         if {$dir != $ndir || $xp < 0} {
5376             lappend coords [xc $y $x] [yc $y]
5377         }
5378         set dir $ndir
5379     }
5380     if {!$joinlow} {
5381         if {$xp < 0} {
5382             # join parent line to first child
5383             set ch [lindex $displayorder $row]
5384             set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5385             if {$xc < 0} {
5386                 puts "oops: drawlineseg: child $ch not on row $row"
5387             } elseif {$xc != $x} {
5388                 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5389                     set d [expr {int(0.5 * $linespc)}]
5390                     set x1 [xc $row $x]
5391                     if {$xc < $x} {
5392                         set x2 [expr {$x1 - $d}]
5393                     } else {
5394                         set x2 [expr {$x1 + $d}]
5395                     }
5396                     set y2 [yc $row]
5397                     set y1 [expr {$y2 + $d}]
5398                     lappend coords $x1 $y1 $x2 $y2
5399                 } elseif {$xc < $x - 1} {
5400                     lappend coords [xc $row [expr {$x-1}]] [yc $row]
5401                 } elseif {$xc > $x + 1} {
5402                     lappend coords [xc $row [expr {$x+1}]] [yc $row]
5403                 }
5404                 set x $xc
5405             }
5406             lappend coords [xc $row $x] [yc $row]
5407         } else {
5408             set xn [xc $row $xp]
5409             set yn [yc $row]
5410             lappend coords $xn $yn
5411         }
5412         if {!$joinhigh} {
5413             assigncolor $id
5414             set t [$canv create line $coords -width [linewidth $id] \
5415                        -fill $colormap($id) -tags lines.$id -arrow $arrow]
5416             $canv lower $t
5417             bindline $t $id
5418             set lines [linsert $lines $i [list $row $le $t]]
5419         } else {
5420             $canv coords $ith $coords
5421             if {$arrow ne $ah} {
5422                 $canv itemconf $ith -arrow $arrow
5423             }
5424             lset lines $i 0 $row
5425         }
5426     } else {
5427         set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5428         set ndir [expr {$xo - $xp}]
5429         set clow [$canv coords $itl]
5430         if {$dir == $ndir} {
5431             set clow [lrange $clow 2 end]
5432         }
5433         set coords [concat $coords $clow]
5434         if {!$joinhigh} {
5435             lset lines [expr {$i-1}] 1 $le
5436         } else {
5437             # coalesce two pieces
5438             $canv delete $ith
5439             set b [lindex $lines [expr {$i-1}] 0]
5440             set e [lindex $lines $i 1]
5441             set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5442         }
5443         $canv coords $itl $coords
5444         if {$arrow ne $al} {
5445             $canv itemconf $itl -arrow $arrow
5446         }
5447     }
5449     set linesegs($id) $lines
5450     return $le
5453 proc drawparentlinks {id row} {
5454     global rowidlist canv colormap curview parentlist
5455     global idpos linespc
5457     set rowids [lindex $rowidlist $row]
5458     set col [lsearch -exact $rowids $id]
5459     if {$col < 0} return
5460     set olds [lindex $parentlist $row]
5461     set row2 [expr {$row + 1}]
5462     set x [xc $row $col]
5463     set y [yc $row]
5464     set y2 [yc $row2]
5465     set d [expr {int(0.5 * $linespc)}]
5466     set ymid [expr {$y + $d}]
5467     set ids [lindex $rowidlist $row2]
5468     # rmx = right-most X coord used
5469     set rmx 0
5470     foreach p $olds {
5471         set i [lsearch -exact $ids $p]
5472         if {$i < 0} {
5473             puts "oops, parent $p of $id not in list"
5474             continue
5475         }
5476         set x2 [xc $row2 $i]
5477         if {$x2 > $rmx} {
5478             set rmx $x2
5479         }
5480         set j [lsearch -exact $rowids $p]
5481         if {$j < 0} {
5482             # drawlineseg will do this one for us
5483             continue
5484         }
5485         assigncolor $p
5486         # should handle duplicated parents here...
5487         set coords [list $x $y]
5488         if {$i != $col} {
5489             # if attaching to a vertical segment, draw a smaller
5490             # slant for visual distinctness
5491             if {$i == $j} {
5492                 if {$i < $col} {
5493                     lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5494                 } else {
5495                     lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5496                 }
5497             } elseif {$i < $col && $i < $j} {
5498                 # segment slants towards us already
5499                 lappend coords [xc $row $j] $y
5500             } else {
5501                 if {$i < $col - 1} {
5502                     lappend coords [expr {$x2 + $linespc}] $y
5503                 } elseif {$i > $col + 1} {
5504                     lappend coords [expr {$x2 - $linespc}] $y
5505                 }
5506                 lappend coords $x2 $y2
5507             }
5508         } else {
5509             lappend coords $x2 $y2
5510         }
5511         set t [$canv create line $coords -width [linewidth $p] \
5512                    -fill $colormap($p) -tags lines.$p]
5513         $canv lower $t
5514         bindline $t $p
5515     }
5516     if {$rmx > [lindex $idpos($id) 1]} {
5517         lset idpos($id) 1 $rmx
5518         redrawtags $id
5519     }
5522 proc drawlines {id} {
5523     global canv
5525     $canv itemconf lines.$id -width [linewidth $id]
5528 proc drawcmittext {id row col} {
5529     global linespc canv canv2 canv3 fgcolor curview
5530     global cmitlisted commitinfo rowidlist parentlist
5531     global rowtextx idpos idtags idheads idotherrefs
5532     global linehtag linentag linedtag selectedline
5533     global canvxmax boldids boldnameids fgcolor
5534     global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5536     # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5537     set listed $cmitlisted($curview,$id)
5538     if {$id eq $nullid} {
5539         set ofill red
5540     } elseif {$id eq $nullid2} {
5541         set ofill green
5542     } elseif {$id eq $mainheadid} {
5543         set ofill yellow
5544     } else {
5545         set ofill [lindex $circlecolors $listed]
5546     }
5547     set x [xc $row $col]
5548     set y [yc $row]
5549     set orad [expr {$linespc / 3}]
5550     if {$listed <= 2} {
5551         set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5552                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5553                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
5554     } elseif {$listed == 3} {
5555         # triangle pointing left for left-side commits
5556         set t [$canv create polygon \
5557                    [expr {$x - $orad}] $y \
5558                    [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5559                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5560                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
5561     } else {
5562         # triangle pointing right for right-side commits
5563         set t [$canv create polygon \
5564                    [expr {$x + $orad - 1}] $y \
5565                    [expr {$x - $orad}] [expr {$y - $orad}] \
5566                    [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5567                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
5568     }
5569     set circleitem($row) $t
5570     $canv raise $t
5571     $canv bind $t <1> {selcanvline {} %x %y}
5572     set rmx [llength [lindex $rowidlist $row]]
5573     set olds [lindex $parentlist $row]
5574     if {$olds ne {}} {
5575         set nextids [lindex $rowidlist [expr {$row + 1}]]
5576         foreach p $olds {
5577             set i [lsearch -exact $nextids $p]
5578             if {$i > $rmx} {
5579                 set rmx $i
5580             }
5581         }
5582     }
5583     set xt [xc $row $rmx]
5584     set rowtextx($row) $xt
5585     set idpos($id) [list $x $xt $y]
5586     if {[info exists idtags($id)] || [info exists idheads($id)]
5587         || [info exists idotherrefs($id)]} {
5588         set xt [drawtags $id $x $xt $y]
5589     }
5590     set headline [lindex $commitinfo($id) 0]
5591     set name [lindex $commitinfo($id) 1]
5592     set date [lindex $commitinfo($id) 2]
5593     set date [formatdate $date]
5594     set font mainfont
5595     set nfont mainfont
5596     set isbold [ishighlighted $id]
5597     if {$isbold > 0} {
5598         lappend boldids $id
5599         set font mainfontbold
5600         if {$isbold > 1} {
5601             lappend boldnameids $id
5602             set nfont mainfontbold
5603         }
5604     }
5605     set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5606                            -text $headline -font $font -tags text]
5607     $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5608     set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5609                            -text $name -font $nfont -tags text]
5610     set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5611                            -text $date -font mainfont -tags text]
5612     if {$selectedline == $row} {
5613         make_secsel $id
5614     }
5615     set xr [expr {$xt + [font measure $font $headline]}]
5616     if {$xr > $canvxmax} {
5617         set canvxmax $xr
5618         setcanvscroll
5619     }
5622 proc drawcmitrow {row} {
5623     global displayorder rowidlist nrows_drawn
5624     global iddrawn markingmatches
5625     global commitinfo numcommits
5626     global filehighlight fhighlights findpattern nhighlights
5627     global hlview vhighlights
5628     global highlight_related rhighlights
5630     if {$row >= $numcommits} return
5632     set id [lindex $displayorder $row]
5633     if {[info exists hlview] && ![info exists vhighlights($id)]} {
5634         askvhighlight $row $id
5635     }
5636     if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5637         askfilehighlight $row $id
5638     }
5639     if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5640         askfindhighlight $row $id
5641     }
5642     if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5643         askrelhighlight $row $id
5644     }
5645     if {![info exists iddrawn($id)]} {
5646         set col [lsearch -exact [lindex $rowidlist $row] $id]
5647         if {$col < 0} {
5648             puts "oops, row $row id $id not in list"
5649             return
5650         }
5651         if {![info exists commitinfo($id)]} {
5652             getcommit $id
5653         }
5654         assigncolor $id
5655         drawcmittext $id $row $col
5656         set iddrawn($id) 1
5657         incr nrows_drawn
5658     }
5659     if {$markingmatches} {
5660         markrowmatches $row $id
5661     }
5664 proc drawcommits {row {endrow {}}} {
5665     global numcommits iddrawn displayorder curview need_redisplay
5666     global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5668     if {$row < 0} {
5669         set row 0
5670     }
5671     if {$endrow eq {}} {
5672         set endrow $row
5673     }
5674     if {$endrow >= $numcommits} {
5675         set endrow [expr {$numcommits - 1}]
5676     }
5678     set rl1 [expr {$row - $downarrowlen - 3}]
5679     if {$rl1 < 0} {
5680         set rl1 0
5681     }
5682     set ro1 [expr {$row - 3}]
5683     if {$ro1 < 0} {
5684         set ro1 0
5685     }
5686     set r2 [expr {$endrow + $uparrowlen + 3}]
5687     if {$r2 > $numcommits} {
5688         set r2 $numcommits
5689     }
5690     for {set r $rl1} {$r < $r2} {incr r} {
5691         if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5692             if {$rl1 < $r} {
5693                 layoutrows $rl1 $r
5694             }
5695             set rl1 [expr {$r + 1}]
5696         }
5697     }
5698     if {$rl1 < $r} {
5699         layoutrows $rl1 $r
5700     }
5701     optimize_rows $ro1 0 $r2
5702     if {$need_redisplay || $nrows_drawn > 2000} {
5703         clear_display
5704         drawvisible
5705     }
5707     # make the lines join to already-drawn rows either side
5708     set r [expr {$row - 1}]
5709     if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5710         set r $row
5711     }
5712     set er [expr {$endrow + 1}]
5713     if {$er >= $numcommits ||
5714         ![info exists iddrawn([lindex $displayorder $er])]} {
5715         set er $endrow
5716     }
5717     for {} {$r <= $er} {incr r} {
5718         set id [lindex $displayorder $r]
5719         set wasdrawn [info exists iddrawn($id)]
5720         drawcmitrow $r
5721         if {$r == $er} break
5722         set nextid [lindex $displayorder [expr {$r + 1}]]
5723         if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5724         drawparentlinks $id $r
5726         set rowids [lindex $rowidlist $r]
5727         foreach lid $rowids {
5728             if {$lid eq {}} continue
5729             if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5730             if {$lid eq $id} {
5731                 # see if this is the first child of any of its parents
5732                 foreach p [lindex $parentlist $r] {
5733                     if {[lsearch -exact $rowids $p] < 0} {
5734                         # make this line extend up to the child
5735                         set lineend($p) [drawlineseg $p $r $er 0]
5736                     }
5737                 }
5738             } else {
5739                 set lineend($lid) [drawlineseg $lid $r $er 1]
5740             }
5741         }
5742     }
5745 proc undolayout {row} {
5746     global uparrowlen mingaplen downarrowlen
5747     global rowidlist rowisopt rowfinal need_redisplay
5749     set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5750     if {$r < 0} {
5751         set r 0
5752     }
5753     if {[llength $rowidlist] > $r} {
5754         incr r -1
5755         set rowidlist [lrange $rowidlist 0 $r]
5756         set rowfinal [lrange $rowfinal 0 $r]
5757         set rowisopt [lrange $rowisopt 0 $r]
5758         set need_redisplay 1
5759         run drawvisible
5760     }
5763 proc drawvisible {} {
5764     global canv linespc curview vrowmod selectedline targetrow targetid
5765     global need_redisplay cscroll numcommits
5767     set fs [$canv yview]
5768     set ymax [lindex [$canv cget -scrollregion] 3]
5769     if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5770     set f0 [lindex $fs 0]
5771     set f1 [lindex $fs 1]
5772     set y0 [expr {int($f0 * $ymax)}]
5773     set y1 [expr {int($f1 * $ymax)}]
5775     if {[info exists targetid]} {
5776         if {[commitinview $targetid $curview]} {
5777             set r [rowofcommit $targetid]
5778             if {$r != $targetrow} {
5779                 # Fix up the scrollregion and change the scrolling position
5780                 # now that our target row has moved.
5781                 set diff [expr {($r - $targetrow) * $linespc}]
5782                 set targetrow $r
5783                 setcanvscroll
5784                 set ymax [lindex [$canv cget -scrollregion] 3]
5785                 incr y0 $diff
5786                 incr y1 $diff
5787                 set f0 [expr {$y0 / $ymax}]
5788                 set f1 [expr {$y1 / $ymax}]
5789                 allcanvs yview moveto $f0
5790                 $cscroll set $f0 $f1
5791                 set need_redisplay 1
5792             }
5793         } else {
5794             unset targetid
5795         }
5796     }
5798     set row [expr {int(($y0 - 3) / $linespc) - 1}]
5799     set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5800     if {$endrow >= $vrowmod($curview)} {
5801         update_arcrows $curview
5802     }
5803     if {$selectedline ne {} &&
5804         $row <= $selectedline && $selectedline <= $endrow} {
5805         set targetrow $selectedline
5806     } elseif {[info exists targetid]} {
5807         set targetrow [expr {int(($row + $endrow) / 2)}]
5808     }
5809     if {[info exists targetrow]} {
5810         if {$targetrow >= $numcommits} {
5811             set targetrow [expr {$numcommits - 1}]
5812         }
5813         set targetid [commitonrow $targetrow]
5814     }
5815     drawcommits $row $endrow
5818 proc clear_display {} {
5819     global iddrawn linesegs need_redisplay nrows_drawn
5820     global vhighlights fhighlights nhighlights rhighlights
5821     global linehtag linentag linedtag boldids boldnameids
5823     allcanvs delete all
5824     catch {unset iddrawn}
5825     catch {unset linesegs}
5826     catch {unset linehtag}
5827     catch {unset linentag}
5828     catch {unset linedtag}
5829     set boldids {}
5830     set boldnameids {}
5831     catch {unset vhighlights}
5832     catch {unset fhighlights}
5833     catch {unset nhighlights}
5834     catch {unset rhighlights}
5835     set need_redisplay 0
5836     set nrows_drawn 0
5839 proc findcrossings {id} {
5840     global rowidlist parentlist numcommits displayorder
5842     set cross {}
5843     set ccross {}
5844     foreach {s e} [rowranges $id] {
5845         if {$e >= $numcommits} {
5846             set e [expr {$numcommits - 1}]
5847         }
5848         if {$e <= $s} continue
5849         for {set row $e} {[incr row -1] >= $s} {} {
5850             set x [lsearch -exact [lindex $rowidlist $row] $id]
5851             if {$x < 0} break
5852             set olds [lindex $parentlist $row]
5853             set kid [lindex $displayorder $row]
5854             set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5855             if {$kidx < 0} continue
5856             set nextrow [lindex $rowidlist [expr {$row + 1}]]
5857             foreach p $olds {
5858                 set px [lsearch -exact $nextrow $p]
5859                 if {$px < 0} continue
5860                 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5861                     if {[lsearch -exact $ccross $p] >= 0} continue
5862                     if {$x == $px + ($kidx < $px? -1: 1)} {
5863                         lappend ccross $p
5864                     } elseif {[lsearch -exact $cross $p] < 0} {
5865                         lappend cross $p
5866                     }
5867                 }
5868             }
5869         }
5870     }
5871     return [concat $ccross {{}} $cross]
5874 proc assigncolor {id} {
5875     global colormap colors nextcolor
5876     global parents children children curview
5878     if {[info exists colormap($id)]} return
5879     set ncolors [llength $colors]
5880     if {[info exists children($curview,$id)]} {
5881         set kids $children($curview,$id)
5882     } else {
5883         set kids {}
5884     }
5885     if {[llength $kids] == 1} {
5886         set child [lindex $kids 0]
5887         if {[info exists colormap($child)]
5888             && [llength $parents($curview,$child)] == 1} {
5889             set colormap($id) $colormap($child)
5890             return
5891         }
5892     }
5893     set badcolors {}
5894     set origbad {}
5895     foreach x [findcrossings $id] {
5896         if {$x eq {}} {
5897             # delimiter between corner crossings and other crossings
5898             if {[llength $badcolors] >= $ncolors - 1} break
5899             set origbad $badcolors
5900         }
5901         if {[info exists colormap($x)]
5902             && [lsearch -exact $badcolors $colormap($x)] < 0} {
5903             lappend badcolors $colormap($x)
5904         }
5905     }
5906     if {[llength $badcolors] >= $ncolors} {
5907         set badcolors $origbad
5908     }
5909     set origbad $badcolors
5910     if {[llength $badcolors] < $ncolors - 1} {
5911         foreach child $kids {
5912             if {[info exists colormap($child)]
5913                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5914                 lappend badcolors $colormap($child)
5915             }
5916             foreach p $parents($curview,$child) {
5917                 if {[info exists colormap($p)]
5918                     && [lsearch -exact $badcolors $colormap($p)] < 0} {
5919                     lappend badcolors $colormap($p)
5920                 }
5921             }
5922         }
5923         if {[llength $badcolors] >= $ncolors} {
5924             set badcolors $origbad
5925         }
5926     }
5927     for {set i 0} {$i <= $ncolors} {incr i} {
5928         set c [lindex $colors $nextcolor]
5929         if {[incr nextcolor] >= $ncolors} {
5930             set nextcolor 0
5931         }
5932         if {[lsearch -exact $badcolors $c]} break
5933     }
5934     set colormap($id) $c
5937 proc bindline {t id} {
5938     global canv
5940     $canv bind $t <Enter> "lineenter %x %y $id"
5941     $canv bind $t <Motion> "linemotion %x %y $id"
5942     $canv bind $t <Leave> "lineleave $id"
5943     $canv bind $t <Button-1> "lineclick %x %y $id 1"
5946 proc drawtags {id x xt y1} {
5947     global idtags idheads idotherrefs mainhead
5948     global linespc lthickness
5949     global canv rowtextx curview fgcolor bgcolor ctxbut
5951     set marks {}
5952     set ntags 0
5953     set nheads 0
5954     if {[info exists idtags($id)]} {
5955         set marks $idtags($id)
5956         set ntags [llength $marks]
5957     }
5958     if {[info exists idheads($id)]} {
5959         set marks [concat $marks $idheads($id)]
5960         set nheads [llength $idheads($id)]
5961     }
5962     if {[info exists idotherrefs($id)]} {
5963         set marks [concat $marks $idotherrefs($id)]
5964     }
5965     if {$marks eq {}} {
5966         return $xt
5967     }
5969     set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5970     set yt [expr {$y1 - 0.5 * $linespc}]
5971     set yb [expr {$yt + $linespc - 1}]
5972     set xvals {}
5973     set wvals {}
5974     set i -1
5975     foreach tag $marks {
5976         incr i
5977         if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
5978             set wid [font measure mainfontbold $tag]
5979         } else {
5980             set wid [font measure mainfont $tag]
5981         }
5982         lappend xvals $xt
5983         lappend wvals $wid
5984         set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
5985     }
5986     set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
5987                -width $lthickness -fill black -tags tag.$id]
5988     $canv lower $t
5989     foreach tag $marks x $xvals wid $wvals {
5990         set xl [expr {$x + $delta}]
5991         set xr [expr {$x + $delta + $wid + $lthickness}]
5992         set font mainfont
5993         if {[incr ntags -1] >= 0} {
5994             # draw a tag
5995             set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
5996                        $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
5997                        -width 1 -outline black -fill yellow -tags tag.$id]
5998             $canv bind $t <1> [list showtag $tag 1]
5999             set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6000         } else {
6001             # draw a head or other ref
6002             if {[incr nheads -1] >= 0} {
6003                 set col green
6004                 if {$tag eq $mainhead} {
6005                     set font mainfontbold
6006                 }
6007             } else {
6008                 set col "#ddddff"
6009             }
6010             set xl [expr {$xl - $delta/2}]
6011             $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6012                 -width 1 -outline black -fill $col -tags tag.$id
6013             if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6014                 set rwid [font measure mainfont $remoteprefix]
6015                 set xi [expr {$x + 1}]
6016                 set yti [expr {$yt + 1}]
6017                 set xri [expr {$x + $rwid}]
6018                 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6019                         -width 0 -fill "#ffddaa" -tags tag.$id
6020             }
6021         }
6022         set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6023                    -font $font -tags [list tag.$id text]]
6024         if {$ntags >= 0} {
6025             $canv bind $t <1> [list showtag $tag 1]
6026         } elseif {$nheads >= 0} {
6027             $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6028         }
6029     }
6030     return $xt
6033 proc xcoord {i level ln} {
6034     global canvx0 xspc1 xspc2
6036     set x [expr {$canvx0 + $i * $xspc1($ln)}]
6037     if {$i > 0 && $i == $level} {
6038         set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6039     } elseif {$i > $level} {
6040         set x [expr {$x + $xspc2 - $xspc1($ln)}]
6041     }
6042     return $x
6045 proc show_status {msg} {
6046     global canv fgcolor
6048     clear_display
6049     $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6050         -tags text -fill $fgcolor
6053 # Don't change the text pane cursor if it is currently the hand cursor,
6054 # showing that we are over a sha1 ID link.
6055 proc settextcursor {c} {
6056     global ctext curtextcursor
6058     if {[$ctext cget -cursor] == $curtextcursor} {
6059         $ctext config -cursor $c
6060     }
6061     set curtextcursor $c
6064 proc nowbusy {what {name {}}} {
6065     global isbusy busyname statusw
6067     if {[array names isbusy] eq {}} {
6068         . config -cursor watch
6069         settextcursor watch
6070     }
6071     set isbusy($what) 1
6072     set busyname($what) $name
6073     if {$name ne {}} {
6074         $statusw conf -text $name
6075     }
6078 proc notbusy {what} {
6079     global isbusy maincursor textcursor busyname statusw
6081     catch {
6082         unset isbusy($what)
6083         if {$busyname($what) ne {} &&
6084             [$statusw cget -text] eq $busyname($what)} {
6085             $statusw conf -text {}
6086         }
6087     }
6088     if {[array names isbusy] eq {}} {
6089         . config -cursor $maincursor
6090         settextcursor $textcursor
6091     }
6094 proc findmatches {f} {
6095     global findtype findstring
6096     if {$findtype == [mc "Regexp"]} {
6097         set matches [regexp -indices -all -inline $findstring $f]
6098     } else {
6099         set fs $findstring
6100         if {$findtype == [mc "IgnCase"]} {
6101             set f [string tolower $f]
6102             set fs [string tolower $fs]
6103         }
6104         set matches {}
6105         set i 0
6106         set l [string length $fs]
6107         while {[set j [string first $fs $f $i]] >= 0} {
6108             lappend matches [list $j [expr {$j+$l-1}]]
6109             set i [expr {$j + $l}]
6110         }
6111     }
6112     return $matches
6115 proc dofind {{dirn 1} {wrap 1}} {
6116     global findstring findstartline findcurline selectedline numcommits
6117     global gdttype filehighlight fh_serial find_dirn findallowwrap
6119     if {[info exists find_dirn]} {
6120         if {$find_dirn == $dirn} return
6121         stopfinding
6122     }
6123     focus .
6124     if {$findstring eq {} || $numcommits == 0} return
6125     if {$selectedline eq {}} {
6126         set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6127     } else {
6128         set findstartline $selectedline
6129     }
6130     set findcurline $findstartline
6131     nowbusy finding [mc "Searching"]
6132     if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6133         after cancel do_file_hl $fh_serial
6134         do_file_hl $fh_serial
6135     }
6136     set find_dirn $dirn
6137     set findallowwrap $wrap
6138     run findmore
6141 proc stopfinding {} {
6142     global find_dirn findcurline fprogcoord
6144     if {[info exists find_dirn]} {
6145         unset find_dirn
6146         unset findcurline
6147         notbusy finding
6148         set fprogcoord 0
6149         adjustprogress
6150     }
6151     stopblaming
6154 proc findmore {} {
6155     global commitdata commitinfo numcommits findpattern findloc
6156     global findstartline findcurline findallowwrap
6157     global find_dirn gdttype fhighlights fprogcoord
6158     global curview varcorder vrownum varccommits vrowmod
6160     if {![info exists find_dirn]} {
6161         return 0
6162     }
6163     set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6164     set l $findcurline
6165     set moretodo 0
6166     if {$find_dirn > 0} {
6167         incr l
6168         if {$l >= $numcommits} {
6169             set l 0
6170         }
6171         if {$l <= $findstartline} {
6172             set lim [expr {$findstartline + 1}]
6173         } else {
6174             set lim $numcommits
6175             set moretodo $findallowwrap
6176         }
6177     } else {
6178         if {$l == 0} {
6179             set l $numcommits
6180         }
6181         incr l -1
6182         if {$l >= $findstartline} {
6183             set lim [expr {$findstartline - 1}]
6184         } else {
6185             set lim -1
6186             set moretodo $findallowwrap
6187         }
6188     }
6189     set n [expr {($lim - $l) * $find_dirn}]
6190     if {$n > 500} {
6191         set n 500
6192         set moretodo 1
6193     }
6194     if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6195         update_arcrows $curview
6196     }
6197     set found 0
6198     set domore 1
6199     set ai [bsearch $vrownum($curview) $l]
6200     set a [lindex $varcorder($curview) $ai]
6201     set arow [lindex $vrownum($curview) $ai]
6202     set ids [lindex $varccommits($curview,$a)]
6203     set arowend [expr {$arow + [llength $ids]}]
6204     if {$gdttype eq [mc "containing:"]} {
6205         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6206             if {$l < $arow || $l >= $arowend} {
6207                 incr ai $find_dirn
6208                 set a [lindex $varcorder($curview) $ai]
6209                 set arow [lindex $vrownum($curview) $ai]
6210                 set ids [lindex $varccommits($curview,$a)]
6211                 set arowend [expr {$arow + [llength $ids]}]
6212             }
6213             set id [lindex $ids [expr {$l - $arow}]]
6214             # shouldn't happen unless git log doesn't give all the commits...
6215             if {![info exists commitdata($id)] ||
6216                 ![doesmatch $commitdata($id)]} {
6217                 continue
6218             }
6219             if {![info exists commitinfo($id)]} {
6220                 getcommit $id
6221             }
6222             set info $commitinfo($id)
6223             foreach f $info ty $fldtypes {
6224                 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6225                     [doesmatch $f]} {
6226                     set found 1
6227                     break
6228                 }
6229             }
6230             if {$found} break
6231         }
6232     } else {
6233         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6234             if {$l < $arow || $l >= $arowend} {
6235                 incr ai $find_dirn
6236                 set a [lindex $varcorder($curview) $ai]
6237                 set arow [lindex $vrownum($curview) $ai]
6238                 set ids [lindex $varccommits($curview,$a)]
6239                 set arowend [expr {$arow + [llength $ids]}]
6240             }
6241             set id [lindex $ids [expr {$l - $arow}]]
6242             if {![info exists fhighlights($id)]} {
6243                 # this sets fhighlights($id) to -1
6244                 askfilehighlight $l $id
6245             }
6246             if {$fhighlights($id) > 0} {
6247                 set found $domore
6248                 break
6249             }
6250             if {$fhighlights($id) < 0} {
6251                 if {$domore} {
6252                     set domore 0
6253                     set findcurline [expr {$l - $find_dirn}]
6254                 }
6255             }
6256         }
6257     }
6258     if {$found || ($domore && !$moretodo)} {
6259         unset findcurline
6260         unset find_dirn
6261         notbusy finding
6262         set fprogcoord 0
6263         adjustprogress
6264         if {$found} {
6265             findselectline $l
6266         } else {
6267             bell
6268         }
6269         return 0
6270     }
6271     if {!$domore} {
6272         flushhighlights
6273     } else {
6274         set findcurline [expr {$l - $find_dirn}]
6275     }
6276     set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6277     if {$n < 0} {
6278         incr n $numcommits
6279     }
6280     set fprogcoord [expr {$n * 1.0 / $numcommits}]
6281     adjustprogress
6282     return $domore
6285 proc findselectline {l} {
6286     global findloc commentend ctext findcurline markingmatches gdttype
6288     set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6289     set findcurline $l
6290     selectline $l 1
6291     if {$markingmatches &&
6292         ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6293         # highlight the matches in the comments
6294         set f [$ctext get 1.0 $commentend]
6295         set matches [findmatches $f]
6296         foreach match $matches {
6297             set start [lindex $match 0]
6298             set end [expr {[lindex $match 1] + 1}]
6299             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6300         }
6301     }
6302     drawvisible
6305 # mark the bits of a headline or author that match a find string
6306 proc markmatches {canv l str tag matches font row} {
6307     global selectedline
6309     set bbox [$canv bbox $tag]
6310     set x0 [lindex $bbox 0]
6311     set y0 [lindex $bbox 1]
6312     set y1 [lindex $bbox 3]
6313     foreach match $matches {
6314         set start [lindex $match 0]
6315         set end [lindex $match 1]
6316         if {$start > $end} continue
6317         set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6318         set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6319         set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6320                    [expr {$x0+$xlen+2}] $y1 \
6321                    -outline {} -tags [list match$l matches] -fill yellow]
6322         $canv lower $t
6323         if {$row == $selectedline} {
6324             $canv raise $t secsel
6325         }
6326     }
6329 proc unmarkmatches {} {
6330     global markingmatches
6332     allcanvs delete matches
6333     set markingmatches 0
6334     stopfinding
6337 proc selcanvline {w x y} {
6338     global canv canvy0 ctext linespc
6339     global rowtextx
6340     set ymax [lindex [$canv cget -scrollregion] 3]
6341     if {$ymax == {}} return
6342     set yfrac [lindex [$canv yview] 0]
6343     set y [expr {$y + $yfrac * $ymax}]
6344     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6345     if {$l < 0} {
6346         set l 0
6347     }
6348     if {$w eq $canv} {
6349         set xmax [lindex [$canv cget -scrollregion] 2]
6350         set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6351         if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6352     }
6353     unmarkmatches
6354     selectline $l 1
6357 proc commit_descriptor {p} {
6358     global commitinfo
6359     if {![info exists commitinfo($p)]} {
6360         getcommit $p
6361     }
6362     set l "..."
6363     if {[llength $commitinfo($p)] > 1} {
6364         set l [lindex $commitinfo($p) 0]
6365     }
6366     return "$p ($l)\n"
6369 # append some text to the ctext widget, and make any SHA1 ID
6370 # that we know about be a clickable link.
6371 proc appendwithlinks {text tags} {
6372     global ctext linknum curview
6374     set start [$ctext index "end - 1c"]
6375     $ctext insert end $text $tags
6376     set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6377     foreach l $links {
6378         set s [lindex $l 0]
6379         set e [lindex $l 1]
6380         set linkid [string range $text $s $e]
6381         incr e
6382         $ctext tag delete link$linknum
6383         $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6384         setlink $linkid link$linknum
6385         incr linknum
6386     }
6389 proc setlink {id lk} {
6390     global curview ctext pendinglinks
6392     set known 0
6393     if {[string length $id] < 40} {
6394         set matches [longid $id]
6395         if {[llength $matches] > 0} {
6396             if {[llength $matches] > 1} return
6397             set known 1
6398             set id [lindex $matches 0]
6399         }
6400     } else {
6401         set known [commitinview $id $curview]
6402     }
6403     if {$known} {
6404         $ctext tag conf $lk -foreground blue -underline 1
6405         $ctext tag bind $lk <1> [list selbyid $id]
6406         $ctext tag bind $lk <Enter> {linkcursor %W 1}
6407         $ctext tag bind $lk <Leave> {linkcursor %W -1}
6408     } else {
6409         lappend pendinglinks($id) $lk
6410         interestedin $id {makelink %P}
6411     }
6414 proc makelink {id} {
6415     global pendinglinks
6417     if {![info exists pendinglinks($id)]} return
6418     foreach lk $pendinglinks($id) {
6419         setlink $id $lk
6420     }
6421     unset pendinglinks($id)
6424 proc linkcursor {w inc} {
6425     global linkentercount curtextcursor
6427     if {[incr linkentercount $inc] > 0} {
6428         $w configure -cursor hand2
6429     } else {
6430         $w configure -cursor $curtextcursor
6431         if {$linkentercount < 0} {
6432             set linkentercount 0
6433         }
6434     }
6437 proc viewnextline {dir} {
6438     global canv linespc
6440     $canv delete hover
6441     set ymax [lindex [$canv cget -scrollregion] 3]
6442     set wnow [$canv yview]
6443     set wtop [expr {[lindex $wnow 0] * $ymax}]
6444     set newtop [expr {$wtop + $dir * $linespc}]
6445     if {$newtop < 0} {
6446         set newtop 0
6447     } elseif {$newtop > $ymax} {
6448         set newtop $ymax
6449     }
6450     allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6453 # add a list of tag or branch names at position pos
6454 # returns the number of names inserted
6455 proc appendrefs {pos ids var} {
6456     global ctext linknum curview $var maxrefs
6458     if {[catch {$ctext index $pos}]} {
6459         return 0
6460     }
6461     $ctext conf -state normal
6462     $ctext delete $pos "$pos lineend"
6463     set tags {}
6464     foreach id $ids {
6465         foreach tag [set $var\($id\)] {
6466             lappend tags [list $tag $id]
6467         }
6468     }
6469     if {[llength $tags] > $maxrefs} {
6470         $ctext insert $pos "many ([llength $tags])"
6471     } else {
6472         set tags [lsort -index 0 -decreasing $tags]
6473         set sep {}
6474         foreach ti $tags {
6475             set id [lindex $ti 1]
6476             set lk link$linknum
6477             incr linknum
6478             $ctext tag delete $lk
6479             $ctext insert $pos $sep
6480             $ctext insert $pos [lindex $ti 0] $lk
6481             setlink $id $lk
6482             set sep ", "
6483         }
6484     }
6485     $ctext conf -state disabled
6486     return [llength $tags]
6489 # called when we have finished computing the nearby tags
6490 proc dispneartags {delay} {
6491     global selectedline currentid showneartags tagphase
6493     if {$selectedline eq {} || !$showneartags} return
6494     after cancel dispnexttag
6495     if {$delay} {
6496         after 200 dispnexttag
6497         set tagphase -1
6498     } else {
6499         after idle dispnexttag
6500         set tagphase 0
6501     }
6504 proc dispnexttag {} {
6505     global selectedline currentid showneartags tagphase ctext
6507     if {$selectedline eq {} || !$showneartags} return
6508     switch -- $tagphase {
6509         0 {
6510             set dtags [desctags $currentid]
6511             if {$dtags ne {}} {
6512                 appendrefs precedes $dtags idtags
6513             }
6514         }
6515         1 {
6516             set atags [anctags $currentid]
6517             if {$atags ne {}} {
6518                 appendrefs follows $atags idtags
6519             }
6520         }
6521         2 {
6522             set dheads [descheads $currentid]
6523             if {$dheads ne {}} {
6524                 if {[appendrefs branch $dheads idheads] > 1
6525                     && [$ctext get "branch -3c"] eq "h"} {
6526                     # turn "Branch" into "Branches"
6527                     $ctext conf -state normal
6528                     $ctext insert "branch -2c" "es"
6529                     $ctext conf -state disabled
6530                 }
6531             }
6532         }
6533     }
6534     if {[incr tagphase] <= 2} {
6535         after idle dispnexttag
6536     }
6539 proc make_secsel {id} {
6540     global linehtag linentag linedtag canv canv2 canv3
6542     if {![info exists linehtag($id)]} return
6543     $canv delete secsel
6544     set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6545                -tags secsel -fill [$canv cget -selectbackground]]
6546     $canv lower $t
6547     $canv2 delete secsel
6548     set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6549                -tags secsel -fill [$canv2 cget -selectbackground]]
6550     $canv2 lower $t
6551     $canv3 delete secsel
6552     set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6553                -tags secsel -fill [$canv3 cget -selectbackground]]
6554     $canv3 lower $t
6557 proc selectline {l isnew {desired_loc {}}} {
6558     global canv ctext commitinfo selectedline
6559     global canvy0 linespc parents children curview
6560     global currentid sha1entry
6561     global commentend idtags linknum
6562     global mergemax numcommits pending_select
6563     global cmitmode showneartags allcommits
6564     global targetrow targetid lastscrollrows
6565     global autoselect jump_to_here
6567     catch {unset pending_select}
6568     $canv delete hover
6569     normalline
6570     unsel_reflist
6571     stopfinding
6572     if {$l < 0 || $l >= $numcommits} return
6573     set id [commitonrow $l]
6574     set targetid $id
6575     set targetrow $l
6576     set selectedline $l
6577     set currentid $id
6578     if {$lastscrollrows < $numcommits} {
6579         setcanvscroll
6580     }
6582     set y [expr {$canvy0 + $l * $linespc}]
6583     set ymax [lindex [$canv cget -scrollregion] 3]
6584     set ytop [expr {$y - $linespc - 1}]
6585     set ybot [expr {$y + $linespc + 1}]
6586     set wnow [$canv yview]
6587     set wtop [expr {[lindex $wnow 0] * $ymax}]
6588     set wbot [expr {[lindex $wnow 1] * $ymax}]
6589     set wh [expr {$wbot - $wtop}]
6590     set newtop $wtop
6591     if {$ytop < $wtop} {
6592         if {$ybot < $wtop} {
6593             set newtop [expr {$y - $wh / 2.0}]
6594         } else {
6595             set newtop $ytop
6596             if {$newtop > $wtop - $linespc} {
6597                 set newtop [expr {$wtop - $linespc}]
6598             }
6599         }
6600     } elseif {$ybot > $wbot} {
6601         if {$ytop > $wbot} {
6602             set newtop [expr {$y - $wh / 2.0}]
6603         } else {
6604             set newtop [expr {$ybot - $wh}]
6605             if {$newtop < $wtop + $linespc} {
6606                 set newtop [expr {$wtop + $linespc}]
6607             }
6608         }
6609     }
6610     if {$newtop != $wtop} {
6611         if {$newtop < 0} {
6612             set newtop 0
6613         }
6614         allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6615         drawvisible
6616     }
6618     make_secsel $id
6620     if {$isnew} {
6621         addtohistory [list selbyid $id]
6622     }
6624     $sha1entry delete 0 end
6625     $sha1entry insert 0 $id
6626     if {$autoselect} {
6627         $sha1entry selection from 0
6628         $sha1entry selection to end
6629     }
6630     rhighlight_sel $id
6632     $ctext conf -state normal
6633     clear_ctext
6634     set linknum 0
6635     if {![info exists commitinfo($id)]} {
6636         getcommit $id
6637     }
6638     set info $commitinfo($id)
6639     set date [formatdate [lindex $info 2]]
6640     $ctext insert end "[mc "Author"]: [lindex $info 1]  $date\n"
6641     set date [formatdate [lindex $info 4]]
6642     $ctext insert end "[mc "Committer"]: [lindex $info 3]  $date\n"
6643     if {[info exists idtags($id)]} {
6644         $ctext insert end [mc "Tags:"]
6645         foreach tag $idtags($id) {
6646             $ctext insert end " $tag"
6647         }
6648         $ctext insert end "\n"
6649     }
6651     set headers {}
6652     set olds $parents($curview,$id)
6653     if {[llength $olds] > 1} {
6654         set np 0
6655         foreach p $olds {
6656             if {$np >= $mergemax} {
6657                 set tag mmax
6658             } else {
6659                 set tag m$np
6660             }
6661             $ctext insert end "[mc "Parent"]: " $tag
6662             appendwithlinks [commit_descriptor $p] {}
6663             incr np
6664         }
6665     } else {
6666         foreach p $olds {
6667             append headers "[mc "Parent"]: [commit_descriptor $p]"
6668         }
6669     }
6671     foreach c $children($curview,$id) {
6672         append headers "[mc "Child"]:  [commit_descriptor $c]"
6673     }
6675     # make anything that looks like a SHA1 ID be a clickable link
6676     appendwithlinks $headers {}
6677     if {$showneartags} {
6678         if {![info exists allcommits]} {
6679             getallcommits
6680         }
6681         $ctext insert end "[mc "Branch"]: "
6682         $ctext mark set branch "end -1c"
6683         $ctext mark gravity branch left
6684         $ctext insert end "\n[mc "Follows"]: "
6685         $ctext mark set follows "end -1c"
6686         $ctext mark gravity follows left
6687         $ctext insert end "\n[mc "Precedes"]: "
6688         $ctext mark set precedes "end -1c"
6689         $ctext mark gravity precedes left
6690         $ctext insert end "\n"
6691         dispneartags 1
6692     }
6693     $ctext insert end "\n"
6694     set comment [lindex $info 5]
6695     if {[string first "\r" $comment] >= 0} {
6696         set comment [string map {"\r" "\n    "} $comment]
6697     }
6698     appendwithlinks $comment {comment}
6700     $ctext tag remove found 1.0 end
6701     $ctext conf -state disabled
6702     set commentend [$ctext index "end - 1c"]
6704     set jump_to_here $desired_loc
6705     init_flist [mc "Comments"]
6706     if {$cmitmode eq "tree"} {
6707         gettree $id
6708     } elseif {[llength $olds] <= 1} {
6709         startdiff $id
6710     } else {
6711         mergediff $id
6712     }
6715 proc selfirstline {} {
6716     unmarkmatches
6717     selectline 0 1
6720 proc sellastline {} {
6721     global numcommits
6722     unmarkmatches
6723     set l [expr {$numcommits - 1}]
6724     selectline $l 1
6727 proc selnextline {dir} {
6728     global selectedline
6729     focus .
6730     if {$selectedline eq {}} return
6731     set l [expr {$selectedline + $dir}]
6732     unmarkmatches
6733     selectline $l 1
6736 proc selnextpage {dir} {
6737     global canv linespc selectedline numcommits
6739     set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6740     if {$lpp < 1} {
6741         set lpp 1
6742     }
6743     allcanvs yview scroll [expr {$dir * $lpp}] units
6744     drawvisible
6745     if {$selectedline eq {}} return
6746     set l [expr {$selectedline + $dir * $lpp}]
6747     if {$l < 0} {
6748         set l 0
6749     } elseif {$l >= $numcommits} {
6750         set l [expr $numcommits - 1]
6751     }
6752     unmarkmatches
6753     selectline $l 1
6756 proc unselectline {} {
6757     global selectedline currentid
6759     set selectedline {}
6760     catch {unset currentid}
6761     allcanvs delete secsel
6762     rhighlight_none
6765 proc reselectline {} {
6766     global selectedline
6768     if {$selectedline ne {}} {
6769         selectline $selectedline 0
6770     }
6773 proc addtohistory {cmd} {
6774     global history historyindex curview
6776     set elt [list $curview $cmd]
6777     if {$historyindex > 0
6778         && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6779         return
6780     }
6782     if {$historyindex < [llength $history]} {
6783         set history [lreplace $history $historyindex end $elt]
6784     } else {
6785         lappend history $elt
6786     }
6787     incr historyindex
6788     if {$historyindex > 1} {
6789         .tf.bar.leftbut conf -state normal
6790     } else {
6791         .tf.bar.leftbut conf -state disabled
6792     }
6793     .tf.bar.rightbut conf -state disabled
6796 proc godo {elt} {
6797     global curview
6799     set view [lindex $elt 0]
6800     set cmd [lindex $elt 1]
6801     if {$curview != $view} {
6802         showview $view
6803     }
6804     eval $cmd
6807 proc goback {} {
6808     global history historyindex
6809     focus .
6811     if {$historyindex > 1} {
6812         incr historyindex -1
6813         godo [lindex $history [expr {$historyindex - 1}]]
6814         .tf.bar.rightbut conf -state normal
6815     }
6816     if {$historyindex <= 1} {
6817         .tf.bar.leftbut conf -state disabled
6818     }
6821 proc goforw {} {
6822     global history historyindex
6823     focus .
6825     if {$historyindex < [llength $history]} {
6826         set cmd [lindex $history $historyindex]
6827         incr historyindex
6828         godo $cmd
6829         .tf.bar.leftbut conf -state normal
6830     }
6831     if {$historyindex >= [llength $history]} {
6832         .tf.bar.rightbut conf -state disabled
6833     }
6836 proc gettree {id} {
6837     global treefilelist treeidlist diffids diffmergeid treepending
6838     global nullid nullid2
6840     set diffids $id
6841     catch {unset diffmergeid}
6842     if {![info exists treefilelist($id)]} {
6843         if {![info exists treepending]} {
6844             if {$id eq $nullid} {
6845                 set cmd [list | git ls-files]
6846             } elseif {$id eq $nullid2} {
6847                 set cmd [list | git ls-files --stage -t]
6848             } else {
6849                 set cmd [list | git ls-tree -r $id]
6850             }
6851             if {[catch {set gtf [open $cmd r]}]} {
6852                 return
6853             }
6854             set treepending $id
6855             set treefilelist($id) {}
6856             set treeidlist($id) {}
6857             fconfigure $gtf -blocking 0 -encoding binary
6858             filerun $gtf [list gettreeline $gtf $id]
6859         }
6860     } else {
6861         setfilelist $id
6862     }
6865 proc gettreeline {gtf id} {
6866     global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6868     set nl 0
6869     while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6870         if {$diffids eq $nullid} {
6871             set fname $line
6872         } else {
6873             set i [string first "\t" $line]
6874             if {$i < 0} continue
6875             set fname [string range $line [expr {$i+1}] end]
6876             set line [string range $line 0 [expr {$i-1}]]
6877             if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6878             set sha1 [lindex $line 2]
6879             lappend treeidlist($id) $sha1
6880         }
6881         if {[string index $fname 0] eq "\""} {
6882             set fname [lindex $fname 0]
6883         }
6884         set fname [encoding convertfrom $fname]
6885         lappend treefilelist($id) $fname
6886     }
6887     if {![eof $gtf]} {
6888         return [expr {$nl >= 1000? 2: 1}]
6889     }
6890     close $gtf
6891     unset treepending
6892     if {$cmitmode ne "tree"} {
6893         if {![info exists diffmergeid]} {
6894             gettreediffs $diffids
6895         }
6896     } elseif {$id ne $diffids} {
6897         gettree $diffids
6898     } else {
6899         setfilelist $id
6900     }
6901     return 0
6904 proc showfile {f} {
6905     global treefilelist treeidlist diffids nullid nullid2
6906     global ctext_file_names ctext_file_lines
6907     global ctext commentend
6909     set i [lsearch -exact $treefilelist($diffids) $f]
6910     if {$i < 0} {
6911         puts "oops, $f not in list for id $diffids"
6912         return
6913     }
6914     if {$diffids eq $nullid} {
6915         if {[catch {set bf [open $f r]} err]} {
6916             puts "oops, can't read $f: $err"
6917             return
6918         }
6919     } else {
6920         set blob [lindex $treeidlist($diffids) $i]
6921         if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6922             puts "oops, error reading blob $blob: $err"
6923             return
6924         }
6925     }
6926     fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6927     filerun $bf [list getblobline $bf $diffids]
6928     $ctext config -state normal
6929     clear_ctext $commentend
6930     lappend ctext_file_names $f
6931     lappend ctext_file_lines [lindex [split $commentend "."] 0]
6932     $ctext insert end "\n"
6933     $ctext insert end "$f\n" filesep
6934     $ctext config -state disabled
6935     $ctext yview $commentend
6936     settabs 0
6939 proc getblobline {bf id} {
6940     global diffids cmitmode ctext
6942     if {$id ne $diffids || $cmitmode ne "tree"} {
6943         catch {close $bf}
6944         return 0
6945     }
6946     $ctext config -state normal
6947     set nl 0
6948     while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6949         $ctext insert end "$line\n"
6950     }
6951     if {[eof $bf]} {
6952         global jump_to_here ctext_file_names commentend
6954         # delete last newline
6955         $ctext delete "end - 2c" "end - 1c"
6956         close $bf
6957         if {$jump_to_here ne {} &&
6958             [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6959             set lnum [expr {[lindex $jump_to_here 1] +
6960                             [lindex [split $commentend .] 0]}]
6961             mark_ctext_line $lnum
6962         }
6963         return 0
6964     }
6965     $ctext config -state disabled
6966     return [expr {$nl >= 1000? 2: 1}]
6969 proc mark_ctext_line {lnum} {
6970     global ctext markbgcolor
6972     $ctext tag delete omark
6973     $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
6974     $ctext tag conf omark -background $markbgcolor
6975     $ctext see $lnum.0
6978 proc mergediff {id} {
6979     global diffmergeid
6980     global diffids treediffs
6981     global parents curview
6983     set diffmergeid $id
6984     set diffids $id
6985     set treediffs($id) {}
6986     set np [llength $parents($curview,$id)]
6987     settabs $np
6988     getblobdiffs $id
6991 proc startdiff {ids} {
6992     global treediffs diffids treepending diffmergeid nullid nullid2
6994     settabs 1
6995     set diffids $ids
6996     catch {unset diffmergeid}
6997     if {![info exists treediffs($ids)] ||
6998         [lsearch -exact $ids $nullid] >= 0 ||
6999         [lsearch -exact $ids $nullid2] >= 0} {
7000         if {![info exists treepending]} {
7001             gettreediffs $ids
7002         }
7003     } else {
7004         addtocflist $ids
7005     }
7008 proc path_filter {filter name} {
7009     foreach p $filter {
7010         set l [string length $p]
7011         if {[string index $p end] eq "/"} {
7012             if {[string compare -length $l $p $name] == 0} {
7013                 return 1
7014             }
7015         } else {
7016             if {[string compare -length $l $p $name] == 0 &&
7017                 ([string length $name] == $l ||
7018                  [string index $name $l] eq "/")} {
7019                 return 1
7020             }
7021         }
7022     }
7023     return 0
7026 proc addtocflist {ids} {
7027     global treediffs
7029     add_flist $treediffs($ids)
7030     getblobdiffs $ids
7033 proc diffcmd {ids flags} {
7034     global nullid nullid2
7036     set i [lsearch -exact $ids $nullid]
7037     set j [lsearch -exact $ids $nullid2]
7038     if {$i >= 0} {
7039         if {[llength $ids] > 1 && $j < 0} {
7040             # comparing working directory with some specific revision
7041             set cmd [concat | git diff-index $flags]
7042             if {$i == 0} {
7043                 lappend cmd -R [lindex $ids 1]
7044             } else {
7045                 lappend cmd [lindex $ids 0]
7046             }
7047         } else {
7048             # comparing working directory with index
7049             set cmd [concat | git diff-files $flags]
7050             if {$j == 1} {
7051                 lappend cmd -R
7052             }
7053         }
7054     } elseif {$j >= 0} {
7055         set cmd [concat | git diff-index --cached $flags]
7056         if {[llength $ids] > 1} {
7057             # comparing index with specific revision
7058             if {$i == 0} {
7059                 lappend cmd -R [lindex $ids 1]
7060             } else {
7061                 lappend cmd [lindex $ids 0]
7062             }
7063         } else {
7064             # comparing index with HEAD
7065             lappend cmd HEAD
7066         }
7067     } else {
7068         set cmd [concat | git diff-tree -r $flags $ids]
7069     }
7070     return $cmd
7073 proc gettreediffs {ids} {
7074     global treediff treepending
7076     if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7078     set treepending $ids
7079     set treediff {}
7080     fconfigure $gdtf -blocking 0 -encoding binary
7081     filerun $gdtf [list gettreediffline $gdtf $ids]
7084 proc gettreediffline {gdtf ids} {
7085     global treediff treediffs treepending diffids diffmergeid
7086     global cmitmode vfilelimit curview limitdiffs perfile_attrs
7088     set nr 0
7089     set sublist {}
7090     set max 1000
7091     if {$perfile_attrs} {
7092         # cache_gitattr is slow, and even slower on win32 where we
7093         # have to invoke it for only about 30 paths at a time
7094         set max 500
7095         if {[tk windowingsystem] == "win32"} {
7096             set max 120
7097         }
7098     }
7099     while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7100         set i [string first "\t" $line]
7101         if {$i >= 0} {
7102             set file [string range $line [expr {$i+1}] end]
7103             if {[string index $file 0] eq "\""} {
7104                 set file [lindex $file 0]
7105             }
7106             set file [encoding convertfrom $file]
7107             if {$file ne [lindex $treediff end]} {
7108                 lappend treediff $file
7109                 lappend sublist $file
7110             }
7111         }
7112     }
7113     if {$perfile_attrs} {
7114         cache_gitattr encoding $sublist
7115     }
7116     if {![eof $gdtf]} {
7117         return [expr {$nr >= $max? 2: 1}]
7118     }
7119     close $gdtf
7120     if {$limitdiffs && $vfilelimit($curview) ne {}} {
7121         set flist {}
7122         foreach f $treediff {
7123             if {[path_filter $vfilelimit($curview) $f]} {
7124                 lappend flist $f
7125             }
7126         }
7127         set treediffs($ids) $flist
7128     } else {
7129         set treediffs($ids) $treediff
7130     }
7131     unset treepending
7132     if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7133         gettree $diffids
7134     } elseif {$ids != $diffids} {
7135         if {![info exists diffmergeid]} {
7136             gettreediffs $diffids
7137         }
7138     } else {
7139         addtocflist $ids
7140     }
7141     return 0
7144 # empty string or positive integer
7145 proc diffcontextvalidate {v} {
7146     return [regexp {^(|[1-9][0-9]*)$} $v]
7149 proc diffcontextchange {n1 n2 op} {
7150     global diffcontextstring diffcontext
7152     if {[string is integer -strict $diffcontextstring]} {
7153         if {$diffcontextstring > 0} {
7154             set diffcontext $diffcontextstring
7155             reselectline
7156         }
7157     }
7160 proc changeignorespace {} {
7161     reselectline
7164 proc getblobdiffs {ids} {
7165     global blobdifffd diffids env
7166     global diffinhdr treediffs
7167     global diffcontext
7168     global ignorespace
7169     global limitdiffs vfilelimit curview
7170     global diffencoding targetline diffnparents
7172     set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7173     if {$ignorespace} {
7174         append cmd " -w"
7175     }
7176     if {$limitdiffs && $vfilelimit($curview) ne {}} {
7177         set cmd [concat $cmd -- $vfilelimit($curview)]
7178     }
7179     if {[catch {set bdf [open $cmd r]} err]} {
7180         error_popup [mc "Error getting diffs: %s" $err]
7181         return
7182     }
7183     set targetline {}
7184     set diffnparents 0
7185     set diffinhdr 0
7186     set diffencoding [get_path_encoding {}]
7187     fconfigure $bdf -blocking 0 -encoding binary
7188     set blobdifffd($ids) $bdf
7189     filerun $bdf [list getblobdiffline $bdf $diffids]
7192 proc setinlist {var i val} {
7193     global $var
7195     while {[llength [set $var]] < $i} {
7196         lappend $var {}
7197     }
7198     if {[llength [set $var]] == $i} {
7199         lappend $var $val
7200     } else {
7201         lset $var $i $val
7202     }
7205 proc makediffhdr {fname ids} {
7206     global ctext curdiffstart treediffs diffencoding
7207     global ctext_file_names jump_to_here targetline diffline
7209     set fname [encoding convertfrom $fname]
7210     set diffencoding [get_path_encoding $fname]
7211     set i [lsearch -exact $treediffs($ids) $fname]
7212     if {$i >= 0} {
7213         setinlist difffilestart $i $curdiffstart
7214     }
7215     lset ctext_file_names end $fname
7216     set l [expr {(78 - [string length $fname]) / 2}]
7217     set pad [string range "----------------------------------------" 1 $l]
7218     $ctext insert $curdiffstart "$pad $fname $pad" filesep
7219     set targetline {}
7220     if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7221         set targetline [lindex $jump_to_here 1]
7222     }
7223     set diffline 0
7226 proc getblobdiffline {bdf ids} {
7227     global diffids blobdifffd ctext curdiffstart
7228     global diffnexthead diffnextnote difffilestart
7229     global ctext_file_names ctext_file_lines
7230     global diffinhdr treediffs mergemax diffnparents
7231     global diffencoding jump_to_here targetline diffline
7233     set nr 0
7234     $ctext conf -state normal
7235     while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7236         if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7237             close $bdf
7238             return 0
7239         }
7240         if {![string compare -length 5 "diff " $line]} {
7241             if {![regexp {^diff (--cc|--git) } $line m type]} {
7242                 set line [encoding convertfrom $line]
7243                 $ctext insert end "$line\n" hunksep
7244                 continue
7245             }
7246             # start of a new file
7247             set diffinhdr 1
7248             $ctext insert end "\n"
7249             set curdiffstart [$ctext index "end - 1c"]
7250             lappend ctext_file_names ""
7251             lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7252             $ctext insert end "\n" filesep
7254             if {$type eq "--cc"} {
7255                 # start of a new file in a merge diff
7256                 set fname [string range $line 10 end]
7257                 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7258                     lappend treediffs($ids) $fname
7259                     add_flist [list $fname]
7260                 }
7262             } else {
7263                 set line [string range $line 11 end]
7264                 # If the name hasn't changed the length will be odd,
7265                 # the middle char will be a space, and the two bits either
7266                 # side will be a/name and b/name, or "a/name" and "b/name".
7267                 # If the name has changed we'll get "rename from" and
7268                 # "rename to" or "copy from" and "copy to" lines following
7269                 # this, and we'll use them to get the filenames.
7270                 # This complexity is necessary because spaces in the
7271                 # filename(s) don't get escaped.
7272                 set l [string length $line]
7273                 set i [expr {$l / 2}]
7274                 if {!(($l & 1) && [string index $line $i] eq " " &&
7275                       [string range $line 2 [expr {$i - 1}]] eq \
7276                           [string range $line [expr {$i + 3}] end])} {
7277                     continue
7278                 }
7279                 # unescape if quoted and chop off the a/ from the front
7280                 if {[string index $line 0] eq "\""} {
7281                     set fname [string range [lindex $line 0] 2 end]
7282                 } else {
7283                     set fname [string range $line 2 [expr {$i - 1}]]
7284                 }
7285             }
7286             makediffhdr $fname $ids
7288         } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7289             set fname [encoding convertfrom [string range $line 16 end]]
7290             $ctext insert end "\n"
7291             set curdiffstart [$ctext index "end - 1c"]
7292             lappend ctext_file_names $fname
7293             lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7294             $ctext insert end "$line\n" filesep
7295             set i [lsearch -exact $treediffs($ids) $fname]
7296             if {$i >= 0} {
7297                 setinlist difffilestart $i $curdiffstart
7298             }
7300         } elseif {![string compare -length 2 "@@" $line]} {
7301             regexp {^@@+} $line ats
7302             set line [encoding convertfrom $diffencoding $line]
7303             $ctext insert end "$line\n" hunksep
7304             if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7305                 set diffline $nl
7306             }
7307             set diffnparents [expr {[string length $ats] - 1}]
7308             set diffinhdr 0
7310         } elseif {$diffinhdr} {
7311             if {![string compare -length 12 "rename from " $line]} {
7312                 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7313                 if {[string index $fname 0] eq "\""} {
7314                     set fname [lindex $fname 0]
7315                 }
7316                 set fname [encoding convertfrom $fname]
7317                 set i [lsearch -exact $treediffs($ids) $fname]
7318                 if {$i >= 0} {
7319                     setinlist difffilestart $i $curdiffstart
7320                 }
7321             } elseif {![string compare -length 10 $line "rename to "] ||
7322                       ![string compare -length 8 $line "copy to "]} {
7323                 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7324                 if {[string index $fname 0] eq "\""} {
7325                     set fname [lindex $fname 0]
7326                 }
7327                 makediffhdr $fname $ids
7328             } elseif {[string compare -length 3 $line "---"] == 0} {
7329                 # do nothing
7330                 continue
7331             } elseif {[string compare -length 3 $line "+++"] == 0} {
7332                 set diffinhdr 0
7333                 continue
7334             }
7335             $ctext insert end "$line\n" filesep
7337         } else {
7338             set line [encoding convertfrom $diffencoding $line]
7339             # parse the prefix - one ' ', '-' or '+' for each parent
7340             set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7341             set tag [expr {$diffnparents > 1? "m": "d"}]
7342             if {[string trim $prefix " -+"] eq {}} {
7343                 # prefix only has " ", "-" and "+" in it: normal diff line
7344                 set num [string first "-" $prefix]
7345                 if {$num >= 0} {
7346                     # removed line, first parent with line is $num
7347                     if {$num >= $mergemax} {
7348                         set num "max"
7349                     }
7350                     $ctext insert end "$line\n" $tag$num
7351                 } else {
7352                     set tags {}
7353                     if {[string first "+" $prefix] >= 0} {
7354                         # added line
7355                         lappend tags ${tag}result
7356                         if {$diffnparents > 1} {
7357                             set num [string first " " $prefix]
7358                             if {$num >= 0} {
7359                                 if {$num >= $mergemax} {
7360                                     set num "max"
7361                                 }
7362                                 lappend tags m$num
7363                             }
7364                         }
7365                     }
7366                     if {$targetline ne {}} {
7367                         if {$diffline == $targetline} {
7368                             set seehere [$ctext index "end - 1 chars"]
7369                             set targetline {}
7370                         } else {
7371                             incr diffline
7372                         }
7373                     }
7374                     $ctext insert end "$line\n" $tags
7375                 }
7376             } else {
7377                 # "\ No newline at end of file",
7378                 # or something else we don't recognize
7379                 $ctext insert end "$line\n" hunksep
7380             }
7381         }
7382     }
7383     if {[info exists seehere]} {
7384         mark_ctext_line [lindex [split $seehere .] 0]
7385     }
7386     $ctext conf -state disabled
7387     if {[eof $bdf]} {
7388         close $bdf
7389         return 0
7390     }
7391     return [expr {$nr >= 1000? 2: 1}]
7394 proc changediffdisp {} {
7395     global ctext diffelide
7397     $ctext tag conf d0 -elide [lindex $diffelide 0]
7398     $ctext tag conf dresult -elide [lindex $diffelide 1]
7401 proc highlightfile {loc cline} {
7402     global ctext cflist cflist_top
7404     $ctext yview $loc
7405     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7406     $cflist tag add highlight $cline.0 "$cline.0 lineend"
7407     $cflist see $cline.0
7408     set cflist_top $cline
7411 proc prevfile {} {
7412     global difffilestart ctext cmitmode
7414     if {$cmitmode eq "tree"} return
7415     set prev 0.0
7416     set prevline 1
7417     set here [$ctext index @0,0]
7418     foreach loc $difffilestart {
7419         if {[$ctext compare $loc >= $here]} {
7420             highlightfile $prev $prevline
7421             return
7422         }
7423         set prev $loc
7424         incr prevline
7425     }
7426     highlightfile $prev $prevline
7429 proc nextfile {} {
7430     global difffilestart ctext cmitmode
7432     if {$cmitmode eq "tree"} return
7433     set here [$ctext index @0,0]
7434     set line 1
7435     foreach loc $difffilestart {
7436         incr line
7437         if {[$ctext compare $loc > $here]} {
7438             highlightfile $loc $line
7439             return
7440         }
7441     }
7444 proc clear_ctext {{first 1.0}} {
7445     global ctext smarktop smarkbot
7446     global ctext_file_names ctext_file_lines
7447     global pendinglinks
7449     set l [lindex [split $first .] 0]
7450     if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7451         set smarktop $l
7452     }
7453     if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7454         set smarkbot $l
7455     }
7456     $ctext delete $first end
7457     if {$first eq "1.0"} {
7458         catch {unset pendinglinks}
7459     }
7460     set ctext_file_names {}
7461     set ctext_file_lines {}
7464 proc settabs {{firstab {}}} {
7465     global firsttabstop tabstop ctext have_tk85
7467     if {$firstab ne {} && $have_tk85} {
7468         set firsttabstop $firstab
7469     }
7470     set w [font measure textfont "0"]
7471     if {$firsttabstop != 0} {
7472         $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7473                                [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7474     } elseif {$have_tk85 || $tabstop != 8} {
7475         $ctext conf -tabs [expr {$tabstop * $w}]
7476     } else {
7477         $ctext conf -tabs {}
7478     }
7481 proc incrsearch {name ix op} {
7482     global ctext searchstring searchdirn
7484     $ctext tag remove found 1.0 end
7485     if {[catch {$ctext index anchor}]} {
7486         # no anchor set, use start of selection, or of visible area
7487         set sel [$ctext tag ranges sel]
7488         if {$sel ne {}} {
7489             $ctext mark set anchor [lindex $sel 0]
7490         } elseif {$searchdirn eq "-forwards"} {
7491             $ctext mark set anchor @0,0
7492         } else {
7493             $ctext mark set anchor @0,[winfo height $ctext]
7494         }
7495     }
7496     if {$searchstring ne {}} {
7497         set here [$ctext search $searchdirn -- $searchstring anchor]
7498         if {$here ne {}} {
7499             $ctext see $here
7500         }
7501         searchmarkvisible 1
7502     }
7505 proc dosearch {} {
7506     global sstring ctext searchstring searchdirn
7508     focus $sstring
7509     $sstring icursor end
7510     set searchdirn -forwards
7511     if {$searchstring ne {}} {
7512         set sel [$ctext tag ranges sel]
7513         if {$sel ne {}} {
7514             set start "[lindex $sel 0] + 1c"
7515         } elseif {[catch {set start [$ctext index anchor]}]} {
7516             set start "@0,0"
7517         }
7518         set match [$ctext search -count mlen -- $searchstring $start]
7519         $ctext tag remove sel 1.0 end
7520         if {$match eq {}} {
7521             bell
7522             return
7523         }
7524         $ctext see $match
7525         set mend "$match + $mlen c"
7526         $ctext tag add sel $match $mend
7527         $ctext mark unset anchor
7528     }
7531 proc dosearchback {} {
7532     global sstring ctext searchstring searchdirn
7534     focus $sstring
7535     $sstring icursor end
7536     set searchdirn -backwards
7537     if {$searchstring ne {}} {
7538         set sel [$ctext tag ranges sel]
7539         if {$sel ne {}} {
7540             set start [lindex $sel 0]
7541         } elseif {[catch {set start [$ctext index anchor]}]} {
7542             set start @0,[winfo height $ctext]
7543         }
7544         set match [$ctext search -backwards -count ml -- $searchstring $start]
7545         $ctext tag remove sel 1.0 end
7546         if {$match eq {}} {
7547             bell
7548             return
7549         }
7550         $ctext see $match
7551         set mend "$match + $ml c"
7552         $ctext tag add sel $match $mend
7553         $ctext mark unset anchor
7554     }
7557 proc searchmark {first last} {
7558     global ctext searchstring
7560     set mend $first.0
7561     while {1} {
7562         set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7563         if {$match eq {}} break
7564         set mend "$match + $mlen c"
7565         $ctext tag add found $match $mend
7566     }
7569 proc searchmarkvisible {doall} {
7570     global ctext smarktop smarkbot
7572     set topline [lindex [split [$ctext index @0,0] .] 0]
7573     set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7574     if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7575         # no overlap with previous
7576         searchmark $topline $botline
7577         set smarktop $topline
7578         set smarkbot $botline
7579     } else {
7580         if {$topline < $smarktop} {
7581             searchmark $topline [expr {$smarktop-1}]
7582             set smarktop $topline
7583         }
7584         if {$botline > $smarkbot} {
7585             searchmark [expr {$smarkbot+1}] $botline
7586             set smarkbot $botline
7587         }
7588     }
7591 proc scrolltext {f0 f1} {
7592     global searchstring
7594     .bleft.bottom.sb set $f0 $f1
7595     if {$searchstring ne {}} {
7596         searchmarkvisible 0
7597     }
7600 proc setcoords {} {
7601     global linespc charspc canvx0 canvy0
7602     global xspc1 xspc2 lthickness
7604     set linespc [font metrics mainfont -linespace]
7605     set charspc [font measure mainfont "m"]
7606     set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7607     set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7608     set lthickness [expr {int($linespc / 9) + 1}]
7609     set xspc1(0) $linespc
7610     set xspc2 $linespc
7613 proc redisplay {} {
7614     global canv
7615     global selectedline
7617     set ymax [lindex [$canv cget -scrollregion] 3]
7618     if {$ymax eq {} || $ymax == 0} return
7619     set span [$canv yview]
7620     clear_display
7621     setcanvscroll
7622     allcanvs yview moveto [lindex $span 0]
7623     drawvisible
7624     if {$selectedline ne {}} {
7625         selectline $selectedline 0
7626         allcanvs yview moveto [lindex $span 0]
7627     }
7630 proc parsefont {f n} {
7631     global fontattr
7633     set fontattr($f,family) [lindex $n 0]
7634     set s [lindex $n 1]
7635     if {$s eq {} || $s == 0} {
7636         set s 10
7637     } elseif {$s < 0} {
7638         set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7639     }
7640     set fontattr($f,size) $s
7641     set fontattr($f,weight) normal
7642     set fontattr($f,slant) roman
7643     foreach style [lrange $n 2 end] {
7644         switch -- $style {
7645             "normal" -
7646             "bold"   {set fontattr($f,weight) $style}
7647             "roman" -
7648             "italic" {set fontattr($f,slant) $style}
7649         }
7650     }
7653 proc fontflags {f {isbold 0}} {
7654     global fontattr
7656     return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7657                 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7658                 -slant $fontattr($f,slant)]
7661 proc fontname {f} {
7662     global fontattr
7664     set n [list $fontattr($f,family) $fontattr($f,size)]
7665     if {$fontattr($f,weight) eq "bold"} {
7666         lappend n "bold"
7667     }
7668     if {$fontattr($f,slant) eq "italic"} {
7669         lappend n "italic"
7670     }
7671     return $n
7674 proc incrfont {inc} {
7675     global mainfont textfont ctext canv cflist showrefstop
7676     global stopped entries fontattr
7678     unmarkmatches
7679     set s $fontattr(mainfont,size)
7680     incr s $inc
7681     if {$s < 1} {
7682         set s 1
7683     }
7684     set fontattr(mainfont,size) $s
7685     font config mainfont -size $s
7686     font config mainfontbold -size $s
7687     set mainfont [fontname mainfont]
7688     set s $fontattr(textfont,size)
7689     incr s $inc
7690     if {$s < 1} {
7691         set s 1
7692     }
7693     set fontattr(textfont,size) $s
7694     font config textfont -size $s
7695     font config textfontbold -size $s
7696     set textfont [fontname textfont]
7697     setcoords
7698     settabs
7699     redisplay
7702 proc clearsha1 {} {
7703     global sha1entry sha1string
7704     if {[string length $sha1string] == 40} {
7705         $sha1entry delete 0 end
7706     }
7709 proc sha1change {n1 n2 op} {
7710     global sha1string currentid sha1but
7711     if {$sha1string == {}
7712         || ([info exists currentid] && $sha1string == $currentid)} {
7713         set state disabled
7714     } else {
7715         set state normal
7716     }
7717     if {[$sha1but cget -state] == $state} return
7718     if {$state == "normal"} {
7719         $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7720     } else {
7721         $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7722     }
7725 proc gotocommit {} {
7726     global sha1string tagids headids curview varcid
7728     if {$sha1string == {}
7729         || ([info exists currentid] && $sha1string == $currentid)} return
7730     if {[info exists tagids($sha1string)]} {
7731         set id $tagids($sha1string)
7732     } elseif {[info exists headids($sha1string)]} {
7733         set id $headids($sha1string)
7734     } else {
7735         set id [string tolower $sha1string]
7736         if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7737             set matches [longid $id]
7738             if {$matches ne {}} {
7739                 if {[llength $matches] > 1} {
7740                     error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7741                     return
7742                 }
7743                 set id [lindex $matches 0]
7744             }
7745         }
7746     }
7747     if {[commitinview $id $curview]} {
7748         selectline [rowofcommit $id] 1
7749         return
7750     }
7751     if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7752         set msg [mc "SHA1 id %s is not known" $sha1string]
7753     } else {
7754         set msg [mc "Tag/Head %s is not known" $sha1string]
7755     }
7756     error_popup $msg
7759 proc lineenter {x y id} {
7760     global hoverx hovery hoverid hovertimer
7761     global commitinfo canv
7763     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7764     set hoverx $x
7765     set hovery $y
7766     set hoverid $id
7767     if {[info exists hovertimer]} {
7768         after cancel $hovertimer
7769     }
7770     set hovertimer [after 500 linehover]
7771     $canv delete hover
7774 proc linemotion {x y id} {
7775     global hoverx hovery hoverid hovertimer
7777     if {[info exists hoverid] && $id == $hoverid} {
7778         set hoverx $x
7779         set hovery $y
7780         if {[info exists hovertimer]} {
7781             after cancel $hovertimer
7782         }
7783         set hovertimer [after 500 linehover]
7784     }
7787 proc lineleave {id} {
7788     global hoverid hovertimer canv
7790     if {[info exists hoverid] && $id == $hoverid} {
7791         $canv delete hover
7792         if {[info exists hovertimer]} {
7793             after cancel $hovertimer
7794             unset hovertimer
7795         }
7796         unset hoverid
7797     }
7800 proc linehover {} {
7801     global hoverx hovery hoverid hovertimer
7802     global canv linespc lthickness
7803     global commitinfo
7805     set text [lindex $commitinfo($hoverid) 0]
7806     set ymax [lindex [$canv cget -scrollregion] 3]
7807     if {$ymax == {}} return
7808     set yfrac [lindex [$canv yview] 0]
7809     set x [expr {$hoverx + 2 * $linespc}]
7810     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7811     set x0 [expr {$x - 2 * $lthickness}]
7812     set y0 [expr {$y - 2 * $lthickness}]
7813     set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7814     set y1 [expr {$y + $linespc + 2 * $lthickness}]
7815     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7816                -fill \#ffff80 -outline black -width 1 -tags hover]
7817     $canv raise $t
7818     set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7819                -font mainfont]
7820     $canv raise $t
7823 proc clickisonarrow {id y} {
7824     global lthickness
7826     set ranges [rowranges $id]
7827     set thresh [expr {2 * $lthickness + 6}]
7828     set n [expr {[llength $ranges] - 1}]
7829     for {set i 1} {$i < $n} {incr i} {
7830         set row [lindex $ranges $i]
7831         if {abs([yc $row] - $y) < $thresh} {
7832             return $i
7833         }
7834     }
7835     return {}
7838 proc arrowjump {id n y} {
7839     global canv
7841     # 1 <-> 2, 3 <-> 4, etc...
7842     set n [expr {(($n - 1) ^ 1) + 1}]
7843     set row [lindex [rowranges $id] $n]
7844     set yt [yc $row]
7845     set ymax [lindex [$canv cget -scrollregion] 3]
7846     if {$ymax eq {} || $ymax <= 0} return
7847     set view [$canv yview]
7848     set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7849     set yfrac [expr {$yt / $ymax - $yspan / 2}]
7850     if {$yfrac < 0} {
7851         set yfrac 0
7852     }
7853     allcanvs yview moveto $yfrac
7856 proc lineclick {x y id isnew} {
7857     global ctext commitinfo children canv thickerline curview
7859     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7860     unmarkmatches
7861     unselectline
7862     normalline
7863     $canv delete hover
7864     # draw this line thicker than normal
7865     set thickerline $id
7866     drawlines $id
7867     if {$isnew} {
7868         set ymax [lindex [$canv cget -scrollregion] 3]
7869         if {$ymax eq {}} return
7870         set yfrac [lindex [$canv yview] 0]
7871         set y [expr {$y + $yfrac * $ymax}]
7872     }
7873     set dirn [clickisonarrow $id $y]
7874     if {$dirn ne {}} {
7875         arrowjump $id $dirn $y
7876         return
7877     }
7879     if {$isnew} {
7880         addtohistory [list lineclick $x $y $id 0]
7881     }
7882     # fill the details pane with info about this line
7883     $ctext conf -state normal
7884     clear_ctext
7885     settabs 0
7886     $ctext insert end "[mc "Parent"]:\t"
7887     $ctext insert end $id link0
7888     setlink $id link0
7889     set info $commitinfo($id)
7890     $ctext insert end "\n\t[lindex $info 0]\n"
7891     $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7892     set date [formatdate [lindex $info 2]]
7893     $ctext insert end "\t[mc "Date"]:\t$date\n"
7894     set kids $children($curview,$id)
7895     if {$kids ne {}} {
7896         $ctext insert end "\n[mc "Children"]:"
7897         set i 0
7898         foreach child $kids {
7899             incr i
7900             if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7901             set info $commitinfo($child)
7902             $ctext insert end "\n\t"
7903             $ctext insert end $child link$i
7904             setlink $child link$i
7905             $ctext insert end "\n\t[lindex $info 0]"
7906             $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7907             set date [formatdate [lindex $info 2]]
7908             $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7909         }
7910     }
7911     $ctext conf -state disabled
7912     init_flist {}
7915 proc normalline {} {
7916     global thickerline
7917     if {[info exists thickerline]} {
7918         set id $thickerline
7919         unset thickerline
7920         drawlines $id
7921     }
7924 proc selbyid {id} {
7925     global curview
7926     if {[commitinview $id $curview]} {
7927         selectline [rowofcommit $id] 1
7928     }
7931 proc mstime {} {
7932     global startmstime
7933     if {![info exists startmstime]} {
7934         set startmstime [clock clicks -milliseconds]
7935     }
7936     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7939 proc rowmenu {x y id} {
7940     global rowctxmenu selectedline rowmenuid curview
7941     global nullid nullid2 fakerowmenu mainhead
7943     stopfinding
7944     set rowmenuid $id
7945     if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7946         set state disabled
7947     } else {
7948         set state normal
7949     }
7950     if {$id ne $nullid && $id ne $nullid2} {
7951         set menu $rowctxmenu
7952         if {$mainhead ne {}} {
7953             $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
7954         } else {
7955             $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7956         }
7957     } else {
7958         set menu $fakerowmenu
7959     }
7960     $menu entryconfigure [mca "Diff this -> selected"] -state $state
7961     $menu entryconfigure [mca "Diff selected -> this"] -state $state
7962     $menu entryconfigure [mca "Make patch"] -state $state
7963     tk_popup $menu $x $y
7966 proc diffvssel {dirn} {
7967     global rowmenuid selectedline
7969     if {$selectedline eq {}} return
7970     if {$dirn} {
7971         set oldid [commitonrow $selectedline]
7972         set newid $rowmenuid
7973     } else {
7974         set oldid $rowmenuid
7975         set newid [commitonrow $selectedline]
7976     }
7977     addtohistory [list doseldiff $oldid $newid]
7978     doseldiff $oldid $newid
7981 proc doseldiff {oldid newid} {
7982     global ctext
7983     global commitinfo
7985     $ctext conf -state normal
7986     clear_ctext
7987     init_flist [mc "Top"]
7988     $ctext insert end "[mc "From"] "
7989     $ctext insert end $oldid link0
7990     setlink $oldid link0
7991     $ctext insert end "\n     "
7992     $ctext insert end [lindex $commitinfo($oldid) 0]
7993     $ctext insert end "\n\n[mc "To"]   "
7994     $ctext insert end $newid link1
7995     setlink $newid link1
7996     $ctext insert end "\n     "
7997     $ctext insert end [lindex $commitinfo($newid) 0]
7998     $ctext insert end "\n"
7999     $ctext conf -state disabled
8000     $ctext tag remove found 1.0 end
8001     startdiff [list $oldid $newid]
8004 proc mkpatch {} {
8005     global rowmenuid currentid commitinfo patchtop patchnum
8007     if {![info exists currentid]} return
8008     set oldid $currentid
8009     set oldhead [lindex $commitinfo($oldid) 0]
8010     set newid $rowmenuid
8011     set newhead [lindex $commitinfo($newid) 0]
8012     set top .patch
8013     set patchtop $top
8014     catch {destroy $top}
8015     toplevel $top
8016     make_transient $top .
8017     label $top.title -text [mc "Generate patch"]
8018     grid $top.title - -pady 10
8019     label $top.from -text [mc "From:"]
8020     entry $top.fromsha1 -width 40 -relief flat
8021     $top.fromsha1 insert 0 $oldid
8022     $top.fromsha1 conf -state readonly
8023     grid $top.from $top.fromsha1 -sticky w
8024     entry $top.fromhead -width 60 -relief flat
8025     $top.fromhead insert 0 $oldhead
8026     $top.fromhead conf -state readonly
8027     grid x $top.fromhead -sticky w
8028     label $top.to -text [mc "To:"]
8029     entry $top.tosha1 -width 40 -relief flat
8030     $top.tosha1 insert 0 $newid
8031     $top.tosha1 conf -state readonly
8032     grid $top.to $top.tosha1 -sticky w
8033     entry $top.tohead -width 60 -relief flat
8034     $top.tohead insert 0 $newhead
8035     $top.tohead conf -state readonly
8036     grid x $top.tohead -sticky w
8037     button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8038     grid $top.rev x -pady 10
8039     label $top.flab -text [mc "Output file:"]
8040     entry $top.fname -width 60
8041     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8042     incr patchnum
8043     grid $top.flab $top.fname -sticky w
8044     frame $top.buts
8045     button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8046     button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8047     bind $top <Key-Return> mkpatchgo
8048     bind $top <Key-Escape> mkpatchcan
8049     grid $top.buts.gen $top.buts.can
8050     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8051     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8052     grid $top.buts - -pady 10 -sticky ew
8053     focus $top.fname
8056 proc mkpatchrev {} {
8057     global patchtop
8059     set oldid [$patchtop.fromsha1 get]
8060     set oldhead [$patchtop.fromhead get]
8061     set newid [$patchtop.tosha1 get]
8062     set newhead [$patchtop.tohead get]
8063     foreach e [list fromsha1 fromhead tosha1 tohead] \
8064             v [list $newid $newhead $oldid $oldhead] {
8065         $patchtop.$e conf -state normal
8066         $patchtop.$e delete 0 end
8067         $patchtop.$e insert 0 $v
8068         $patchtop.$e conf -state readonly
8069     }
8072 proc mkpatchgo {} {
8073     global patchtop nullid nullid2
8075     set oldid [$patchtop.fromsha1 get]
8076     set newid [$patchtop.tosha1 get]
8077     set fname [$patchtop.fname get]
8078     set cmd [diffcmd [list $oldid $newid] -p]
8079     # trim off the initial "|"
8080     set cmd [lrange $cmd 1 end]
8081     lappend cmd >$fname &
8082     if {[catch {eval exec $cmd} err]} {
8083         error_popup "[mc "Error creating patch:"] $err" $patchtop
8084     }
8085     catch {destroy $patchtop}
8086     unset patchtop
8089 proc mkpatchcan {} {
8090     global patchtop
8092     catch {destroy $patchtop}
8093     unset patchtop
8096 proc mktag {} {
8097     global rowmenuid mktagtop commitinfo
8099     set top .maketag
8100     set mktagtop $top
8101     catch {destroy $top}
8102     toplevel $top
8103     make_transient $top .
8104     label $top.title -text [mc "Create tag"]
8105     grid $top.title - -pady 10
8106     label $top.id -text [mc "ID:"]
8107     entry $top.sha1 -width 40 -relief flat
8108     $top.sha1 insert 0 $rowmenuid
8109     $top.sha1 conf -state readonly
8110     grid $top.id $top.sha1 -sticky w
8111     entry $top.head -width 60 -relief flat
8112     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8113     $top.head conf -state readonly
8114     grid x $top.head -sticky w
8115     label $top.tlab -text [mc "Tag name:"]
8116     entry $top.tag -width 60
8117     grid $top.tlab $top.tag -sticky w
8118     frame $top.buts
8119     button $top.buts.gen -text [mc "Create"] -command mktaggo
8120     button $top.buts.can -text [mc "Cancel"] -command mktagcan
8121     bind $top <Key-Return> mktaggo
8122     bind $top <Key-Escape> mktagcan
8123     grid $top.buts.gen $top.buts.can
8124     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8125     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8126     grid $top.buts - -pady 10 -sticky ew
8127     focus $top.tag
8130 proc domktag {} {
8131     global mktagtop env tagids idtags
8133     set id [$mktagtop.sha1 get]
8134     set tag [$mktagtop.tag get]
8135     if {$tag == {}} {
8136         error_popup [mc "No tag name specified"] $mktagtop
8137         return 0
8138     }
8139     if {[info exists tagids($tag)]} {
8140         error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8141         return 0
8142     }
8143     if {[catch {
8144         exec git tag $tag $id
8145     } err]} {
8146         error_popup "[mc "Error creating tag:"] $err" $mktagtop
8147         return 0
8148     }
8150     set tagids($tag) $id
8151     lappend idtags($id) $tag
8152     redrawtags $id
8153     addedtag $id
8154     dispneartags 0
8155     run refill_reflist
8156     return 1
8159 proc redrawtags {id} {
8160     global canv linehtag idpos currentid curview cmitlisted
8161     global canvxmax iddrawn circleitem mainheadid circlecolors
8163     if {![commitinview $id $curview]} return
8164     if {![info exists iddrawn($id)]} return
8165     set row [rowofcommit $id]
8166     if {$id eq $mainheadid} {
8167         set ofill yellow
8168     } else {
8169         set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8170     }
8171     $canv itemconf $circleitem($row) -fill $ofill
8172     $canv delete tag.$id
8173     set xt [eval drawtags $id $idpos($id)]
8174     $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8175     set text [$canv itemcget $linehtag($id) -text]
8176     set font [$canv itemcget $linehtag($id) -font]
8177     set xr [expr {$xt + [font measure $font $text]}]
8178     if {$xr > $canvxmax} {
8179         set canvxmax $xr
8180         setcanvscroll
8181     }
8182     if {[info exists currentid] && $currentid == $id} {
8183         make_secsel $id
8184     }
8187 proc mktagcan {} {
8188     global mktagtop
8190     catch {destroy $mktagtop}
8191     unset mktagtop
8194 proc mktaggo {} {
8195     if {![domktag]} return
8196     mktagcan
8199 proc writecommit {} {
8200     global rowmenuid wrcomtop commitinfo wrcomcmd
8202     set top .writecommit
8203     set wrcomtop $top
8204     catch {destroy $top}
8205     toplevel $top
8206     make_transient $top .
8207     label $top.title -text [mc "Write commit to file"]
8208     grid $top.title - -pady 10
8209     label $top.id -text [mc "ID:"]
8210     entry $top.sha1 -width 40 -relief flat
8211     $top.sha1 insert 0 $rowmenuid
8212     $top.sha1 conf -state readonly
8213     grid $top.id $top.sha1 -sticky w
8214     entry $top.head -width 60 -relief flat
8215     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8216     $top.head conf -state readonly
8217     grid x $top.head -sticky w
8218     label $top.clab -text [mc "Command:"]
8219     entry $top.cmd -width 60 -textvariable wrcomcmd
8220     grid $top.clab $top.cmd -sticky w -pady 10
8221     label $top.flab -text [mc "Output file:"]
8222     entry $top.fname -width 60
8223     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8224     grid $top.flab $top.fname -sticky w
8225     frame $top.buts
8226     button $top.buts.gen -text [mc "Write"] -command wrcomgo
8227     button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8228     bind $top <Key-Return> wrcomgo
8229     bind $top <Key-Escape> wrcomcan
8230     grid $top.buts.gen $top.buts.can
8231     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8232     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8233     grid $top.buts - -pady 10 -sticky ew
8234     focus $top.fname
8237 proc wrcomgo {} {
8238     global wrcomtop
8240     set id [$wrcomtop.sha1 get]
8241     set cmd "echo $id | [$wrcomtop.cmd get]"
8242     set fname [$wrcomtop.fname get]
8243     if {[catch {exec sh -c $cmd >$fname &} err]} {
8244         error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8245     }
8246     catch {destroy $wrcomtop}
8247     unset wrcomtop
8250 proc wrcomcan {} {
8251     global wrcomtop
8253     catch {destroy $wrcomtop}
8254     unset wrcomtop
8257 proc mkbranch {} {
8258     global rowmenuid mkbrtop
8260     set top .makebranch
8261     catch {destroy $top}
8262     toplevel $top
8263     make_transient $top .
8264     label $top.title -text [mc "Create new branch"]
8265     grid $top.title - -pady 10
8266     label $top.id -text [mc "ID:"]
8267     entry $top.sha1 -width 40 -relief flat
8268     $top.sha1 insert 0 $rowmenuid
8269     $top.sha1 conf -state readonly
8270     grid $top.id $top.sha1 -sticky w
8271     label $top.nlab -text [mc "Name:"]
8272     entry $top.name -width 40
8273     grid $top.nlab $top.name -sticky w
8274     frame $top.buts
8275     button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8276     button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8277     bind $top <Key-Return> [list mkbrgo $top]
8278     bind $top <Key-Escape> "catch {destroy $top}"
8279     grid $top.buts.go $top.buts.can
8280     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8281     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8282     grid $top.buts - -pady 10 -sticky ew
8283     focus $top.name
8286 proc mkbrgo {top} {
8287     global headids idheads
8289     set name [$top.name get]
8290     set id [$top.sha1 get]
8291     set cmdargs {}
8292     set old_id {}
8293     if {$name eq {}} {
8294         error_popup [mc "Please specify a name for the new branch"] $top
8295         return
8296     }
8297     if {[info exists headids($name)]} {
8298         if {![confirm_popup [mc \
8299                 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8300             return
8301         }
8302         set old_id $headids($name)
8303         lappend cmdargs -f
8304     }
8305     catch {destroy $top}
8306     lappend cmdargs $name $id
8307     nowbusy newbranch
8308     update
8309     if {[catch {
8310         eval exec git branch $cmdargs
8311     } err]} {
8312         notbusy newbranch
8313         error_popup $err
8314     } else {
8315         notbusy newbranch
8316         if {$old_id ne {}} {
8317             movehead $id $name
8318             movedhead $id $name
8319             redrawtags $old_id
8320             redrawtags $id
8321         } else {
8322             set headids($name) $id
8323             lappend idheads($id) $name
8324             addedhead $id $name
8325             redrawtags $id
8326         }
8327         dispneartags 0
8328         run refill_reflist
8329     }
8332 proc exec_citool {tool_args {baseid {}}} {
8333     global commitinfo env
8335     set save_env [array get env GIT_AUTHOR_*]
8337     if {$baseid ne {}} {
8338         if {![info exists commitinfo($baseid)]} {
8339             getcommit $baseid
8340         }
8341         set author [lindex $commitinfo($baseid) 1]
8342         set date [lindex $commitinfo($baseid) 2]
8343         if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8344                     $author author name email]
8345             && $date ne {}} {
8346             set env(GIT_AUTHOR_NAME) $name
8347             set env(GIT_AUTHOR_EMAIL) $email
8348             set env(GIT_AUTHOR_DATE) $date
8349         }
8350     }
8352     eval exec git citool $tool_args &
8354     array unset env GIT_AUTHOR_*
8355     array set env $save_env
8358 proc cherrypick {} {
8359     global rowmenuid curview
8360     global mainhead mainheadid
8362     set oldhead [exec git rev-parse HEAD]
8363     set dheads [descheads $rowmenuid]
8364     if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8365         set ok [confirm_popup [mc "Commit %s is already\
8366                 included in branch %s -- really re-apply it?" \
8367                                    [string range $rowmenuid 0 7] $mainhead]]
8368         if {!$ok} return
8369     }
8370     nowbusy cherrypick [mc "Cherry-picking"]
8371     update
8372     # Unfortunately git-cherry-pick writes stuff to stderr even when
8373     # no error occurs, and exec takes that as an indication of error...
8374     if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8375         notbusy cherrypick
8376         if {[regexp -line \
8377                  {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8378                  $err msg fname]} {
8379             error_popup [mc "Cherry-pick failed because of local changes\
8380                         to file '%s'.\nPlease commit, reset or stash\
8381                         your changes and try again." $fname]
8382         } elseif {[regexp -line \
8383                        {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8384                        $err]} {
8385             if {[confirm_popup [mc "Cherry-pick failed because of merge\
8386                         conflict.\nDo you wish to run git citool to\
8387                         resolve it?"]]} {
8388                 # Force citool to read MERGE_MSG
8389                 file delete [file join [gitdir] "GITGUI_MSG"]
8390                 exec_citool {} $rowmenuid
8391             }
8392         } else {
8393             error_popup $err
8394         }
8395         run updatecommits
8396         return
8397     }
8398     set newhead [exec git rev-parse HEAD]
8399     if {$newhead eq $oldhead} {
8400         notbusy cherrypick
8401         error_popup [mc "No changes committed"]
8402         return
8403     }
8404     addnewchild $newhead $oldhead
8405     if {[commitinview $oldhead $curview]} {
8406         # XXX this isn't right if we have a path limit...
8407         insertrow $newhead $oldhead $curview
8408         if {$mainhead ne {}} {
8409             movehead $newhead $mainhead
8410             movedhead $newhead $mainhead
8411         }
8412         set mainheadid $newhead
8413         redrawtags $oldhead
8414         redrawtags $newhead
8415         selbyid $newhead
8416     }
8417     notbusy cherrypick
8420 proc resethead {} {
8421     global mainhead rowmenuid confirm_ok resettype
8423     set confirm_ok 0
8424     set w ".confirmreset"
8425     toplevel $w
8426     make_transient $w .
8427     wm title $w [mc "Confirm reset"]
8428     message $w.m -text \
8429         [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8430         -justify center -aspect 1000
8431     pack $w.m -side top -fill x -padx 20 -pady 20
8432     frame $w.f -relief sunken -border 2
8433     message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8434     grid $w.f.rt -sticky w
8435     set resettype mixed
8436     radiobutton $w.f.soft -value soft -variable resettype -justify left \
8437         -text [mc "Soft: Leave working tree and index untouched"]
8438     grid $w.f.soft -sticky w
8439     radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8440         -text [mc "Mixed: Leave working tree untouched, reset index"]
8441     grid $w.f.mixed -sticky w
8442     radiobutton $w.f.hard -value hard -variable resettype -justify left \
8443         -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8444     grid $w.f.hard -sticky w
8445     pack $w.f -side top -fill x
8446     button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8447     pack $w.ok -side left -fill x -padx 20 -pady 20
8448     button $w.cancel -text [mc Cancel] -command "destroy $w"
8449     bind $w <Key-Escape> [list destroy $w]
8450     pack $w.cancel -side right -fill x -padx 20 -pady 20
8451     bind $w <Visibility> "grab $w; focus $w"
8452     tkwait window $w
8453     if {!$confirm_ok} return
8454     if {[catch {set fd [open \
8455             [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8456         error_popup $err
8457     } else {
8458         dohidelocalchanges
8459         filerun $fd [list readresetstat $fd]
8460         nowbusy reset [mc "Resetting"]
8461         selbyid $rowmenuid
8462     }
8465 proc readresetstat {fd} {
8466     global mainhead mainheadid showlocalchanges rprogcoord
8468     if {[gets $fd line] >= 0} {
8469         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8470             set rprogcoord [expr {1.0 * $m / $n}]
8471             adjustprogress
8472         }
8473         return 1
8474     }
8475     set rprogcoord 0
8476     adjustprogress
8477     notbusy reset
8478     if {[catch {close $fd} err]} {
8479         error_popup $err
8480     }
8481     set oldhead $mainheadid
8482     set newhead [exec git rev-parse HEAD]
8483     if {$newhead ne $oldhead} {
8484         movehead $newhead $mainhead
8485         movedhead $newhead $mainhead
8486         set mainheadid $newhead
8487         redrawtags $oldhead
8488         redrawtags $newhead
8489     }
8490     if {$showlocalchanges} {
8491         doshowlocalchanges
8492     }
8493     return 0
8496 # context menu for a head
8497 proc headmenu {x y id head} {
8498     global headmenuid headmenuhead headctxmenu mainhead
8500     stopfinding
8501     set headmenuid $id
8502     set headmenuhead $head
8503     set state normal
8504     if {$head eq $mainhead} {
8505         set state disabled
8506     }
8507     $headctxmenu entryconfigure 0 -state $state
8508     $headctxmenu entryconfigure 1 -state $state
8509     tk_popup $headctxmenu $x $y
8512 proc cobranch {} {
8513     global headmenuid headmenuhead headids
8514     global showlocalchanges
8516     # check the tree is clean first??
8517     nowbusy checkout [mc "Checking out"]
8518     update
8519     dohidelocalchanges
8520     if {[catch {
8521         set fd [open [list | git checkout $headmenuhead 2>@1] r]
8522     } err]} {
8523         notbusy checkout
8524         error_popup $err
8525         if {$showlocalchanges} {
8526             dodiffindex
8527         }
8528     } else {
8529         filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8530     }
8533 proc readcheckoutstat {fd newhead newheadid} {
8534     global mainhead mainheadid headids showlocalchanges progresscoords
8535     global viewmainheadid curview
8537     if {[gets $fd line] >= 0} {
8538         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8539             set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8540             adjustprogress
8541         }
8542         return 1
8543     }
8544     set progresscoords {0 0}
8545     adjustprogress
8546     notbusy checkout
8547     if {[catch {close $fd} err]} {
8548         error_popup $err
8549     }
8550     set oldmainid $mainheadid
8551     set mainhead $newhead
8552     set mainheadid $newheadid
8553     set viewmainheadid($curview) $newheadid
8554     redrawtags $oldmainid
8555     redrawtags $newheadid
8556     selbyid $newheadid
8557     if {$showlocalchanges} {
8558         dodiffindex
8559     }
8562 proc rmbranch {} {
8563     global headmenuid headmenuhead mainhead
8564     global idheads
8566     set head $headmenuhead
8567     set id $headmenuid
8568     # this check shouldn't be needed any more...
8569     if {$head eq $mainhead} {
8570         error_popup [mc "Cannot delete the currently checked-out branch"]
8571         return
8572     }
8573     set dheads [descheads $id]
8574     if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8575         # the stuff on this branch isn't on any other branch
8576         if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8577                         branch.\nReally delete branch %s?" $head $head]]} return
8578     }
8579     nowbusy rmbranch
8580     update
8581     if {[catch {exec git branch -D $head} err]} {
8582         notbusy rmbranch
8583         error_popup $err
8584         return
8585     }
8586     removehead $id $head
8587     removedhead $id $head
8588     redrawtags $id
8589     notbusy rmbranch
8590     dispneartags 0
8591     run refill_reflist
8594 # Display a list of tags and heads
8595 proc showrefs {} {
8596     global showrefstop bgcolor fgcolor selectbgcolor
8597     global bglist fglist reflistfilter reflist maincursor
8599     set top .showrefs
8600     set showrefstop $top
8601     if {[winfo exists $top]} {
8602         raise $top
8603         refill_reflist
8604         return
8605     }
8606     toplevel $top
8607     wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8608     make_transient $top .
8609     text $top.list -background $bgcolor -foreground $fgcolor \
8610         -selectbackground $selectbgcolor -font mainfont \
8611         -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8612         -width 30 -height 20 -cursor $maincursor \
8613         -spacing1 1 -spacing3 1 -state disabled
8614     $top.list tag configure highlight -background $selectbgcolor
8615     lappend bglist $top.list
8616     lappend fglist $top.list
8617     scrollbar $top.ysb -command "$top.list yview" -orient vertical
8618     scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8619     grid $top.list $top.ysb -sticky nsew
8620     grid $top.xsb x -sticky ew
8621     frame $top.f
8622     label $top.f.l -text "[mc "Filter"]: "
8623     entry $top.f.e -width 20 -textvariable reflistfilter
8624     set reflistfilter "*"
8625     trace add variable reflistfilter write reflistfilter_change
8626     pack $top.f.e -side right -fill x -expand 1
8627     pack $top.f.l -side left
8628     grid $top.f - -sticky ew -pady 2
8629     button $top.close -command [list destroy $top] -text [mc "Close"]
8630     bind $top <Key-Escape> [list destroy $top]
8631     grid $top.close -
8632     grid columnconfigure $top 0 -weight 1
8633     grid rowconfigure $top 0 -weight 1
8634     bind $top.list <1> {break}
8635     bind $top.list <B1-Motion> {break}
8636     bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8637     set reflist {}
8638     refill_reflist
8641 proc sel_reflist {w x y} {
8642     global showrefstop reflist headids tagids otherrefids
8644     if {![winfo exists $showrefstop]} return
8645     set l [lindex [split [$w index "@$x,$y"] "."] 0]
8646     set ref [lindex $reflist [expr {$l-1}]]
8647     set n [lindex $ref 0]
8648     switch -- [lindex $ref 1] {
8649         "H" {selbyid $headids($n)}
8650         "T" {selbyid $tagids($n)}
8651         "o" {selbyid $otherrefids($n)}
8652     }
8653     $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8656 proc unsel_reflist {} {
8657     global showrefstop
8659     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8660     $showrefstop.list tag remove highlight 0.0 end
8663 proc reflistfilter_change {n1 n2 op} {
8664     global reflistfilter
8666     after cancel refill_reflist
8667     after 200 refill_reflist
8670 proc refill_reflist {} {
8671     global reflist reflistfilter showrefstop headids tagids otherrefids
8672     global curview
8674     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8675     set refs {}
8676     foreach n [array names headids] {
8677         if {[string match $reflistfilter $n]} {
8678             if {[commitinview $headids($n) $curview]} {
8679                 lappend refs [list $n H]
8680             } else {
8681                 interestedin $headids($n) {run refill_reflist}
8682             }
8683         }
8684     }
8685     foreach n [array names tagids] {
8686         if {[string match $reflistfilter $n]} {
8687             if {[commitinview $tagids($n) $curview]} {
8688                 lappend refs [list $n T]
8689             } else {
8690                 interestedin $tagids($n) {run refill_reflist}
8691             }
8692         }
8693     }
8694     foreach n [array names otherrefids] {
8695         if {[string match $reflistfilter $n]} {
8696             if {[commitinview $otherrefids($n) $curview]} {
8697                 lappend refs [list $n o]
8698             } else {
8699                 interestedin $otherrefids($n) {run refill_reflist}
8700             }
8701         }
8702     }
8703     set refs [lsort -index 0 $refs]
8704     if {$refs eq $reflist} return
8706     # Update the contents of $showrefstop.list according to the
8707     # differences between $reflist (old) and $refs (new)
8708     $showrefstop.list conf -state normal
8709     $showrefstop.list insert end "\n"
8710     set i 0
8711     set j 0
8712     while {$i < [llength $reflist] || $j < [llength $refs]} {
8713         if {$i < [llength $reflist]} {
8714             if {$j < [llength $refs]} {
8715                 set cmp [string compare [lindex $reflist $i 0] \
8716                              [lindex $refs $j 0]]
8717                 if {$cmp == 0} {
8718                     set cmp [string compare [lindex $reflist $i 1] \
8719                                  [lindex $refs $j 1]]
8720                 }
8721             } else {
8722                 set cmp -1
8723             }
8724         } else {
8725             set cmp 1
8726         }
8727         switch -- $cmp {
8728             -1 {
8729                 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8730                 incr i
8731             }
8732             0 {
8733                 incr i
8734                 incr j
8735             }
8736             1 {
8737                 set l [expr {$j + 1}]
8738                 $showrefstop.list image create $l.0 -align baseline \
8739                     -image reficon-[lindex $refs $j 1] -padx 2
8740                 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8741                 incr j
8742             }
8743         }
8744     }
8745     set reflist $refs
8746     # delete last newline
8747     $showrefstop.list delete end-2c end-1c
8748     $showrefstop.list conf -state disabled
8751 # Stuff for finding nearby tags
8752 proc getallcommits {} {
8753     global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8754     global idheads idtags idotherrefs allparents tagobjid
8756     if {![info exists allcommits]} {
8757         set nextarc 0
8758         set allcommits 0
8759         set seeds {}
8760         set allcwait 0
8761         set cachedarcs 0
8762         set allccache [file join [gitdir] "gitk.cache"]
8763         if {![catch {
8764             set f [open $allccache r]
8765             set allcwait 1
8766             getcache $f
8767         }]} return
8768     }
8770     if {$allcwait} {
8771         return
8772     }
8773     set cmd [list | git rev-list --parents]
8774     set allcupdate [expr {$seeds ne {}}]
8775     if {!$allcupdate} {
8776         set ids "--all"
8777     } else {
8778         set refs [concat [array names idheads] [array names idtags] \
8779                       [array names idotherrefs]]
8780         set ids {}
8781         set tagobjs {}
8782         foreach name [array names tagobjid] {
8783             lappend tagobjs $tagobjid($name)
8784         }
8785         foreach id [lsort -unique $refs] {
8786             if {![info exists allparents($id)] &&
8787                 [lsearch -exact $tagobjs $id] < 0} {
8788                 lappend ids $id
8789             }
8790         }
8791         if {$ids ne {}} {
8792             foreach id $seeds {
8793                 lappend ids "^$id"
8794             }
8795         }
8796     }
8797     if {$ids ne {}} {
8798         set fd [open [concat $cmd $ids] r]
8799         fconfigure $fd -blocking 0
8800         incr allcommits
8801         nowbusy allcommits
8802         filerun $fd [list getallclines $fd]
8803     } else {
8804         dispneartags 0
8805     }
8808 # Since most commits have 1 parent and 1 child, we group strings of
8809 # such commits into "arcs" joining branch/merge points (BMPs), which
8810 # are commits that either don't have 1 parent or don't have 1 child.
8812 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8813 # arcout(id) - outgoing arcs for BMP
8814 # arcids(a) - list of IDs on arc including end but not start
8815 # arcstart(a) - BMP ID at start of arc
8816 # arcend(a) - BMP ID at end of arc
8817 # growing(a) - arc a is still growing
8818 # arctags(a) - IDs out of arcids (excluding end) that have tags
8819 # archeads(a) - IDs out of arcids (excluding end) that have heads
8820 # The start of an arc is at the descendent end, so "incoming" means
8821 # coming from descendents, and "outgoing" means going towards ancestors.
8823 proc getallclines {fd} {
8824     global allparents allchildren idtags idheads nextarc
8825     global arcnos arcids arctags arcout arcend arcstart archeads growing
8826     global seeds allcommits cachedarcs allcupdate
8827     
8828     set nid 0
8829     while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8830         set id [lindex $line 0]
8831         if {[info exists allparents($id)]} {
8832             # seen it already
8833             continue
8834         }
8835         set cachedarcs 0
8836         set olds [lrange $line 1 end]
8837         set allparents($id) $olds
8838         if {![info exists allchildren($id)]} {
8839             set allchildren($id) {}
8840             set arcnos($id) {}
8841             lappend seeds $id
8842         } else {
8843             set a $arcnos($id)
8844             if {[llength $olds] == 1 && [llength $a] == 1} {
8845                 lappend arcids($a) $id
8846                 if {[info exists idtags($id)]} {
8847                     lappend arctags($a) $id
8848                 }
8849                 if {[info exists idheads($id)]} {
8850                     lappend archeads($a) $id
8851                 }
8852                 if {[info exists allparents($olds)]} {
8853                     # seen parent already
8854                     if {![info exists arcout($olds)]} {
8855                         splitarc $olds
8856                     }
8857                     lappend arcids($a) $olds
8858                     set arcend($a) $olds
8859                     unset growing($a)
8860                 }
8861                 lappend allchildren($olds) $id
8862                 lappend arcnos($olds) $a
8863                 continue
8864             }
8865         }
8866         foreach a $arcnos($id) {
8867             lappend arcids($a) $id
8868             set arcend($a) $id
8869             unset growing($a)
8870         }
8872         set ao {}
8873         foreach p $olds {
8874             lappend allchildren($p) $id
8875             set a [incr nextarc]
8876             set arcstart($a) $id
8877             set archeads($a) {}
8878             set arctags($a) {}
8879             set archeads($a) {}
8880             set arcids($a) {}
8881             lappend ao $a
8882             set growing($a) 1
8883             if {[info exists allparents($p)]} {
8884                 # seen it already, may need to make a new branch
8885                 if {![info exists arcout($p)]} {
8886                     splitarc $p
8887                 }
8888                 lappend arcids($a) $p
8889                 set arcend($a) $p
8890                 unset growing($a)
8891             }
8892             lappend arcnos($p) $a
8893         }
8894         set arcout($id) $ao
8895     }
8896     if {$nid > 0} {
8897         global cached_dheads cached_dtags cached_atags
8898         catch {unset cached_dheads}
8899         catch {unset cached_dtags}
8900         catch {unset cached_atags}
8901     }
8902     if {![eof $fd]} {
8903         return [expr {$nid >= 1000? 2: 1}]
8904     }
8905     set cacheok 1
8906     if {[catch {
8907         fconfigure $fd -blocking 1
8908         close $fd
8909     } err]} {
8910         # got an error reading the list of commits
8911         # if we were updating, try rereading the whole thing again
8912         if {$allcupdate} {
8913             incr allcommits -1
8914             dropcache $err
8915             return
8916         }
8917         error_popup "[mc "Error reading commit topology information;\
8918                 branch and preceding/following tag information\
8919                 will be incomplete."]\n($err)"
8920         set cacheok 0
8921     }
8922     if {[incr allcommits -1] == 0} {
8923         notbusy allcommits
8924         if {$cacheok} {
8925             run savecache
8926         }
8927     }
8928     dispneartags 0
8929     return 0
8932 proc recalcarc {a} {
8933     global arctags archeads arcids idtags idheads
8935     set at {}
8936     set ah {}
8937     foreach id [lrange $arcids($a) 0 end-1] {
8938         if {[info exists idtags($id)]} {
8939             lappend at $id
8940         }
8941         if {[info exists idheads($id)]} {
8942             lappend ah $id
8943         }
8944     }
8945     set arctags($a) $at
8946     set archeads($a) $ah
8949 proc splitarc {p} {
8950     global arcnos arcids nextarc arctags archeads idtags idheads
8951     global arcstart arcend arcout allparents growing
8953     set a $arcnos($p)
8954     if {[llength $a] != 1} {
8955         puts "oops splitarc called but [llength $a] arcs already"
8956         return
8957     }
8958     set a [lindex $a 0]
8959     set i [lsearch -exact $arcids($a) $p]
8960     if {$i < 0} {
8961         puts "oops splitarc $p not in arc $a"
8962         return
8963     }
8964     set na [incr nextarc]
8965     if {[info exists arcend($a)]} {
8966         set arcend($na) $arcend($a)
8967     } else {
8968         set l [lindex $allparents([lindex $arcids($a) end]) 0]
8969         set j [lsearch -exact $arcnos($l) $a]
8970         set arcnos($l) [lreplace $arcnos($l) $j $j $na]
8971     }
8972     set tail [lrange $arcids($a) [expr {$i+1}] end]
8973     set arcids($a) [lrange $arcids($a) 0 $i]
8974     set arcend($a) $p
8975     set arcstart($na) $p
8976     set arcout($p) $na
8977     set arcids($na) $tail
8978     if {[info exists growing($a)]} {
8979         set growing($na) 1
8980         unset growing($a)
8981     }
8983     foreach id $tail {
8984         if {[llength $arcnos($id)] == 1} {
8985             set arcnos($id) $na
8986         } else {
8987             set j [lsearch -exact $arcnos($id) $a]
8988             set arcnos($id) [lreplace $arcnos($id) $j $j $na]
8989         }
8990     }
8992     # reconstruct tags and heads lists
8993     if {$arctags($a) ne {} || $archeads($a) ne {}} {
8994         recalcarc $a
8995         recalcarc $na
8996     } else {
8997         set arctags($na) {}
8998         set archeads($na) {}
8999     }
9002 # Update things for a new commit added that is a child of one
9003 # existing commit.  Used when cherry-picking.
9004 proc addnewchild {id p} {
9005     global allparents allchildren idtags nextarc
9006     global arcnos arcids arctags arcout arcend arcstart archeads growing
9007     global seeds allcommits
9009     if {![info exists allcommits] || ![info exists arcnos($p)]} return
9010     set allparents($id) [list $p]
9011     set allchildren($id) {}
9012     set arcnos($id) {}
9013     lappend seeds $id
9014     lappend allchildren($p) $id
9015     set a [incr nextarc]
9016     set arcstart($a) $id
9017     set archeads($a) {}
9018     set arctags($a) {}
9019     set arcids($a) [list $p]
9020     set arcend($a) $p
9021     if {![info exists arcout($p)]} {
9022         splitarc $p
9023     }
9024     lappend arcnos($p) $a
9025     set arcout($id) [list $a]
9028 # This implements a cache for the topology information.
9029 # The cache saves, for each arc, the start and end of the arc,
9030 # the ids on the arc, and the outgoing arcs from the end.
9031 proc readcache {f} {
9032     global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9033     global idtags idheads allparents cachedarcs possible_seeds seeds growing
9034     global allcwait
9036     set a $nextarc
9037     set lim $cachedarcs
9038     if {$lim - $a > 500} {
9039         set lim [expr {$a + 500}]
9040     }
9041     if {[catch {
9042         if {$a == $lim} {
9043             # finish reading the cache and setting up arctags, etc.
9044             set line [gets $f]
9045             if {$line ne "1"} {error "bad final version"}
9046             close $f
9047             foreach id [array names idtags] {
9048                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9049                     [llength $allparents($id)] == 1} {
9050                     set a [lindex $arcnos($id) 0]
9051                     if {$arctags($a) eq {}} {
9052                         recalcarc $a
9053                     }
9054                 }
9055             }
9056             foreach id [array names idheads] {
9057                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9058                     [llength $allparents($id)] == 1} {
9059                     set a [lindex $arcnos($id) 0]
9060                     if {$archeads($a) eq {}} {
9061                         recalcarc $a
9062                     }
9063                 }
9064             }
9065             foreach id [lsort -unique $possible_seeds] {
9066                 if {$arcnos($id) eq {}} {
9067                     lappend seeds $id
9068                 }
9069             }
9070             set allcwait 0
9071         } else {
9072             while {[incr a] <= $lim} {
9073                 set line [gets $f]
9074                 if {[llength $line] != 3} {error "bad line"}
9075                 set s [lindex $line 0]
9076                 set arcstart($a) $s
9077                 lappend arcout($s) $a
9078                 if {![info exists arcnos($s)]} {
9079                     lappend possible_seeds $s
9080                     set arcnos($s) {}
9081                 }
9082                 set e [lindex $line 1]
9083                 if {$e eq {}} {
9084                     set growing($a) 1
9085                 } else {
9086                     set arcend($a) $e
9087                     if {![info exists arcout($e)]} {
9088                         set arcout($e) {}
9089                     }
9090                 }
9091                 set arcids($a) [lindex $line 2]
9092                 foreach id $arcids($a) {
9093                     lappend allparents($s) $id
9094                     set s $id
9095                     lappend arcnos($id) $a
9096                 }
9097                 if {![info exists allparents($s)]} {
9098                     set allparents($s) {}
9099                 }
9100                 set arctags($a) {}
9101                 set archeads($a) {}
9102             }
9103             set nextarc [expr {$a - 1}]
9104         }
9105     } err]} {
9106         dropcache $err
9107         return 0
9108     }
9109     if {!$allcwait} {
9110         getallcommits
9111     }
9112     return $allcwait
9115 proc getcache {f} {
9116     global nextarc cachedarcs possible_seeds
9118     if {[catch {
9119         set line [gets $f]
9120         if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9121         # make sure it's an integer
9122         set cachedarcs [expr {int([lindex $line 1])}]
9123         if {$cachedarcs < 0} {error "bad number of arcs"}
9124         set nextarc 0
9125         set possible_seeds {}
9126         run readcache $f
9127     } err]} {
9128         dropcache $err
9129     }
9130     return 0
9133 proc dropcache {err} {
9134     global allcwait nextarc cachedarcs seeds
9136     #puts "dropping cache ($err)"
9137     foreach v {arcnos arcout arcids arcstart arcend growing \
9138                    arctags archeads allparents allchildren} {
9139         global $v
9140         catch {unset $v}
9141     }
9142     set allcwait 0
9143     set nextarc 0
9144     set cachedarcs 0
9145     set seeds {}
9146     getallcommits
9149 proc writecache {f} {
9150     global cachearc cachedarcs allccache
9151     global arcstart arcend arcnos arcids arcout
9153     set a $cachearc
9154     set lim $cachedarcs
9155     if {$lim - $a > 1000} {
9156         set lim [expr {$a + 1000}]
9157     }
9158     if {[catch {
9159         while {[incr a] <= $lim} {
9160             if {[info exists arcend($a)]} {
9161                 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9162             } else {
9163                 puts $f [list $arcstart($a) {} $arcids($a)]
9164             }
9165         }
9166     } err]} {
9167         catch {close $f}
9168         catch {file delete $allccache}
9169         #puts "writing cache failed ($err)"
9170         return 0
9171     }
9172     set cachearc [expr {$a - 1}]
9173     if {$a > $cachedarcs} {
9174         puts $f "1"
9175         close $f
9176         return 0
9177     }
9178     return 1
9181 proc savecache {} {
9182     global nextarc cachedarcs cachearc allccache
9184     if {$nextarc == $cachedarcs} return
9185     set cachearc 0
9186     set cachedarcs $nextarc
9187     catch {
9188         set f [open $allccache w]
9189         puts $f [list 1 $cachedarcs]
9190         run writecache $f
9191     }
9194 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9195 # or 0 if neither is true.
9196 proc anc_or_desc {a b} {
9197     global arcout arcstart arcend arcnos cached_isanc
9199     if {$arcnos($a) eq $arcnos($b)} {
9200         # Both are on the same arc(s); either both are the same BMP,
9201         # or if one is not a BMP, the other is also not a BMP or is
9202         # the BMP at end of the arc (and it only has 1 incoming arc).
9203         # Or both can be BMPs with no incoming arcs.
9204         if {$a eq $b || $arcnos($a) eq {}} {
9205             return 0
9206         }
9207         # assert {[llength $arcnos($a)] == 1}
9208         set arc [lindex $arcnos($a) 0]
9209         set i [lsearch -exact $arcids($arc) $a]
9210         set j [lsearch -exact $arcids($arc) $b]
9211         if {$i < 0 || $i > $j} {
9212             return 1
9213         } else {
9214             return -1
9215         }
9216     }
9218     if {![info exists arcout($a)]} {
9219         set arc [lindex $arcnos($a) 0]
9220         if {[info exists arcend($arc)]} {
9221             set aend $arcend($arc)
9222         } else {
9223             set aend {}
9224         }
9225         set a $arcstart($arc)
9226     } else {
9227         set aend $a
9228     }
9229     if {![info exists arcout($b)]} {
9230         set arc [lindex $arcnos($b) 0]
9231         if {[info exists arcend($arc)]} {
9232             set bend $arcend($arc)
9233         } else {
9234             set bend {}
9235         }
9236         set b $arcstart($arc)
9237     } else {
9238         set bend $b
9239     }
9240     if {$a eq $bend} {
9241         return 1
9242     }
9243     if {$b eq $aend} {
9244         return -1
9245     }
9246     if {[info exists cached_isanc($a,$bend)]} {
9247         if {$cached_isanc($a,$bend)} {
9248             return 1
9249         }
9250     }
9251     if {[info exists cached_isanc($b,$aend)]} {
9252         if {$cached_isanc($b,$aend)} {
9253             return -1
9254         }
9255         if {[info exists cached_isanc($a,$bend)]} {
9256             return 0
9257         }
9258     }
9260     set todo [list $a $b]
9261     set anc($a) a
9262     set anc($b) b
9263     for {set i 0} {$i < [llength $todo]} {incr i} {
9264         set x [lindex $todo $i]
9265         if {$anc($x) eq {}} {
9266             continue
9267         }
9268         foreach arc $arcnos($x) {
9269             set xd $arcstart($arc)
9270             if {$xd eq $bend} {
9271                 set cached_isanc($a,$bend) 1
9272                 set cached_isanc($b,$aend) 0
9273                 return 1
9274             } elseif {$xd eq $aend} {
9275                 set cached_isanc($b,$aend) 1
9276                 set cached_isanc($a,$bend) 0
9277                 return -1
9278             }
9279             if {![info exists anc($xd)]} {
9280                 set anc($xd) $anc($x)
9281                 lappend todo $xd
9282             } elseif {$anc($xd) ne $anc($x)} {
9283                 set anc($xd) {}
9284             }
9285         }
9286     }
9287     set cached_isanc($a,$bend) 0
9288     set cached_isanc($b,$aend) 0
9289     return 0
9292 # This identifies whether $desc has an ancestor that is
9293 # a growing tip of the graph and which is not an ancestor of $anc
9294 # and returns 0 if so and 1 if not.
9295 # If we subsequently discover a tag on such a growing tip, and that
9296 # turns out to be a descendent of $anc (which it could, since we
9297 # don't necessarily see children before parents), then $desc
9298 # isn't a good choice to display as a descendent tag of
9299 # $anc (since it is the descendent of another tag which is
9300 # a descendent of $anc).  Similarly, $anc isn't a good choice to
9301 # display as a ancestor tag of $desc.
9303 proc is_certain {desc anc} {
9304     global arcnos arcout arcstart arcend growing problems
9306     set certain {}
9307     if {[llength $arcnos($anc)] == 1} {
9308         # tags on the same arc are certain
9309         if {$arcnos($desc) eq $arcnos($anc)} {
9310             return 1
9311         }
9312         if {![info exists arcout($anc)]} {
9313             # if $anc is partway along an arc, use the start of the arc instead
9314             set a [lindex $arcnos($anc) 0]
9315             set anc $arcstart($a)
9316         }
9317     }
9318     if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9319         set x $desc
9320     } else {
9321         set a [lindex $arcnos($desc) 0]
9322         set x $arcend($a)
9323     }
9324     if {$x == $anc} {
9325         return 1
9326     }
9327     set anclist [list $x]
9328     set dl($x) 1
9329     set nnh 1
9330     set ngrowanc 0
9331     for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9332         set x [lindex $anclist $i]
9333         if {$dl($x)} {
9334             incr nnh -1
9335         }
9336         set done($x) 1
9337         foreach a $arcout($x) {
9338             if {[info exists growing($a)]} {
9339                 if {![info exists growanc($x)] && $dl($x)} {
9340                     set growanc($x) 1
9341                     incr ngrowanc
9342                 }
9343             } else {
9344                 set y $arcend($a)
9345                 if {[info exists dl($y)]} {
9346                     if {$dl($y)} {
9347                         if {!$dl($x)} {
9348                             set dl($y) 0
9349                             if {![info exists done($y)]} {
9350                                 incr nnh -1
9351                             }
9352                             if {[info exists growanc($x)]} {
9353                                 incr ngrowanc -1
9354                             }
9355                             set xl [list $y]
9356                             for {set k 0} {$k < [llength $xl]} {incr k} {
9357                                 set z [lindex $xl $k]
9358                                 foreach c $arcout($z) {
9359                                     if {[info exists arcend($c)]} {
9360                                         set v $arcend($c)
9361                                         if {[info exists dl($v)] && $dl($v)} {
9362                                             set dl($v) 0
9363                                             if {![info exists done($v)]} {
9364                                                 incr nnh -1
9365                                             }
9366                                             if {[info exists growanc($v)]} {
9367                                                 incr ngrowanc -1
9368                                             }
9369                                             lappend xl $v
9370                                         }
9371                                     }
9372                                 }
9373                             }
9374                         }
9375                     }
9376                 } elseif {$y eq $anc || !$dl($x)} {
9377                     set dl($y) 0
9378                     lappend anclist $y
9379                 } else {
9380                     set dl($y) 1
9381                     lappend anclist $y
9382                     incr nnh
9383                 }
9384             }
9385         }
9386     }
9387     foreach x [array names growanc] {
9388         if {$dl($x)} {
9389             return 0
9390         }
9391         return 0
9392     }
9393     return 1
9396 proc validate_arctags {a} {
9397     global arctags idtags
9399     set i -1
9400     set na $arctags($a)
9401     foreach id $arctags($a) {
9402         incr i
9403         if {![info exists idtags($id)]} {
9404             set na [lreplace $na $i $i]
9405             incr i -1
9406         }
9407     }
9408     set arctags($a) $na
9411 proc validate_archeads {a} {
9412     global archeads idheads
9414     set i -1
9415     set na $archeads($a)
9416     foreach id $archeads($a) {
9417         incr i
9418         if {![info exists idheads($id)]} {
9419             set na [lreplace $na $i $i]
9420             incr i -1
9421         }
9422     }
9423     set archeads($a) $na
9426 # Return the list of IDs that have tags that are descendents of id,
9427 # ignoring IDs that are descendents of IDs already reported.
9428 proc desctags {id} {
9429     global arcnos arcstart arcids arctags idtags allparents
9430     global growing cached_dtags
9432     if {![info exists allparents($id)]} {
9433         return {}
9434     }
9435     set t1 [clock clicks -milliseconds]
9436     set argid $id
9437     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9438         # part-way along an arc; check that arc first
9439         set a [lindex $arcnos($id) 0]
9440         if {$arctags($a) ne {}} {
9441             validate_arctags $a
9442             set i [lsearch -exact $arcids($a) $id]
9443             set tid {}
9444             foreach t $arctags($a) {
9445                 set j [lsearch -exact $arcids($a) $t]
9446                 if {$j >= $i} break
9447                 set tid $t
9448             }
9449             if {$tid ne {}} {
9450                 return $tid
9451             }
9452         }
9453         set id $arcstart($a)
9454         if {[info exists idtags($id)]} {
9455             return $id
9456         }
9457     }
9458     if {[info exists cached_dtags($id)]} {
9459         return $cached_dtags($id)
9460     }
9462     set origid $id
9463     set todo [list $id]
9464     set queued($id) 1
9465     set nc 1
9466     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9467         set id [lindex $todo $i]
9468         set done($id) 1
9469         set ta [info exists hastaggedancestor($id)]
9470         if {!$ta} {
9471             incr nc -1
9472         }
9473         # ignore tags on starting node
9474         if {!$ta && $i > 0} {
9475             if {[info exists idtags($id)]} {
9476                 set tagloc($id) $id
9477                 set ta 1
9478             } elseif {[info exists cached_dtags($id)]} {
9479                 set tagloc($id) $cached_dtags($id)
9480                 set ta 1
9481             }
9482         }
9483         foreach a $arcnos($id) {
9484             set d $arcstart($a)
9485             if {!$ta && $arctags($a) ne {}} {
9486                 validate_arctags $a
9487                 if {$arctags($a) ne {}} {
9488                     lappend tagloc($id) [lindex $arctags($a) end]
9489                 }
9490             }
9491             if {$ta || $arctags($a) ne {}} {
9492                 set tomark [list $d]
9493                 for {set j 0} {$j < [llength $tomark]} {incr j} {
9494                     set dd [lindex $tomark $j]
9495                     if {![info exists hastaggedancestor($dd)]} {
9496                         if {[info exists done($dd)]} {
9497                             foreach b $arcnos($dd) {
9498                                 lappend tomark $arcstart($b)
9499                             }
9500                             if {[info exists tagloc($dd)]} {
9501                                 unset tagloc($dd)
9502                             }
9503                         } elseif {[info exists queued($dd)]} {
9504                             incr nc -1
9505                         }
9506                         set hastaggedancestor($dd) 1
9507                     }
9508                 }
9509             }
9510             if {![info exists queued($d)]} {
9511                 lappend todo $d
9512                 set queued($d) 1
9513                 if {![info exists hastaggedancestor($d)]} {
9514                     incr nc
9515                 }
9516             }
9517         }
9518     }
9519     set tags {}
9520     foreach id [array names tagloc] {
9521         if {![info exists hastaggedancestor($id)]} {
9522             foreach t $tagloc($id) {
9523                 if {[lsearch -exact $tags $t] < 0} {
9524                     lappend tags $t
9525                 }
9526             }
9527         }
9528     }
9529     set t2 [clock clicks -milliseconds]
9530     set loopix $i
9532     # remove tags that are descendents of other tags
9533     for {set i 0} {$i < [llength $tags]} {incr i} {
9534         set a [lindex $tags $i]
9535         for {set j 0} {$j < $i} {incr j} {
9536             set b [lindex $tags $j]
9537             set r [anc_or_desc $a $b]
9538             if {$r == 1} {
9539                 set tags [lreplace $tags $j $j]
9540                 incr j -1
9541                 incr i -1
9542             } elseif {$r == -1} {
9543                 set tags [lreplace $tags $i $i]
9544                 incr i -1
9545                 break
9546             }
9547         }
9548     }
9550     if {[array names growing] ne {}} {
9551         # graph isn't finished, need to check if any tag could get
9552         # eclipsed by another tag coming later.  Simply ignore any
9553         # tags that could later get eclipsed.
9554         set ctags {}
9555         foreach t $tags {
9556             if {[is_certain $t $origid]} {
9557                 lappend ctags $t
9558             }
9559         }
9560         if {$tags eq $ctags} {
9561             set cached_dtags($origid) $tags
9562         } else {
9563             set tags $ctags
9564         }
9565     } else {
9566         set cached_dtags($origid) $tags
9567     }
9568     set t3 [clock clicks -milliseconds]
9569     if {0 && $t3 - $t1 >= 100} {
9570         puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9571             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9572     }
9573     return $tags
9576 proc anctags {id} {
9577     global arcnos arcids arcout arcend arctags idtags allparents
9578     global growing cached_atags
9580     if {![info exists allparents($id)]} {
9581         return {}
9582     }
9583     set t1 [clock clicks -milliseconds]
9584     set argid $id
9585     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9586         # part-way along an arc; check that arc first
9587         set a [lindex $arcnos($id) 0]
9588         if {$arctags($a) ne {}} {
9589             validate_arctags $a
9590             set i [lsearch -exact $arcids($a) $id]
9591             foreach t $arctags($a) {
9592                 set j [lsearch -exact $arcids($a) $t]
9593                 if {$j > $i} {
9594                     return $t
9595                 }
9596             }
9597         }
9598         if {![info exists arcend($a)]} {
9599             return {}
9600         }
9601         set id $arcend($a)
9602         if {[info exists idtags($id)]} {
9603             return $id
9604         }
9605     }
9606     if {[info exists cached_atags($id)]} {
9607         return $cached_atags($id)
9608     }
9610     set origid $id
9611     set todo [list $id]
9612     set queued($id) 1
9613     set taglist {}
9614     set nc 1
9615     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9616         set id [lindex $todo $i]
9617         set done($id) 1
9618         set td [info exists hastaggeddescendent($id)]
9619         if {!$td} {
9620             incr nc -1
9621         }
9622         # ignore tags on starting node
9623         if {!$td && $i > 0} {
9624             if {[info exists idtags($id)]} {
9625                 set tagloc($id) $id
9626                 set td 1
9627             } elseif {[info exists cached_atags($id)]} {
9628                 set tagloc($id) $cached_atags($id)
9629                 set td 1
9630             }
9631         }
9632         foreach a $arcout($id) {
9633             if {!$td && $arctags($a) ne {}} {
9634                 validate_arctags $a
9635                 if {$arctags($a) ne {}} {
9636                     lappend tagloc($id) [lindex $arctags($a) 0]
9637                 }
9638             }
9639             if {![info exists arcend($a)]} continue
9640             set d $arcend($a)
9641             if {$td || $arctags($a) ne {}} {
9642                 set tomark [list $d]
9643                 for {set j 0} {$j < [llength $tomark]} {incr j} {
9644                     set dd [lindex $tomark $j]
9645                     if {![info exists hastaggeddescendent($dd)]} {
9646                         if {[info exists done($dd)]} {
9647                             foreach b $arcout($dd) {
9648                                 if {[info exists arcend($b)]} {
9649                                     lappend tomark $arcend($b)
9650                                 }
9651                             }
9652                             if {[info exists tagloc($dd)]} {
9653                                 unset tagloc($dd)
9654                             }
9655                         } elseif {[info exists queued($dd)]} {
9656                             incr nc -1
9657                         }
9658                         set hastaggeddescendent($dd) 1
9659                     }
9660                 }
9661             }
9662             if {![info exists queued($d)]} {
9663                 lappend todo $d
9664                 set queued($d) 1
9665                 if {![info exists hastaggeddescendent($d)]} {
9666                     incr nc
9667                 }
9668             }
9669         }
9670     }
9671     set t2 [clock clicks -milliseconds]
9672     set loopix $i
9673     set tags {}
9674     foreach id [array names tagloc] {
9675         if {![info exists hastaggeddescendent($id)]} {
9676             foreach t $tagloc($id) {
9677                 if {[lsearch -exact $tags $t] < 0} {
9678                     lappend tags $t
9679                 }
9680             }
9681         }
9682     }
9684     # remove tags that are ancestors of other tags
9685     for {set i 0} {$i < [llength $tags]} {incr i} {
9686         set a [lindex $tags $i]
9687         for {set j 0} {$j < $i} {incr j} {
9688             set b [lindex $tags $j]
9689             set r [anc_or_desc $a $b]
9690             if {$r == -1} {
9691                 set tags [lreplace $tags $j $j]
9692                 incr j -1
9693                 incr i -1
9694             } elseif {$r == 1} {
9695                 set tags [lreplace $tags $i $i]
9696                 incr i -1
9697                 break
9698             }
9699         }
9700     }
9702     if {[array names growing] ne {}} {
9703         # graph isn't finished, need to check if any tag could get
9704         # eclipsed by another tag coming later.  Simply ignore any
9705         # tags that could later get eclipsed.
9706         set ctags {}
9707         foreach t $tags {
9708             if {[is_certain $origid $t]} {
9709                 lappend ctags $t
9710             }
9711         }
9712         if {$tags eq $ctags} {
9713             set cached_atags($origid) $tags
9714         } else {
9715             set tags $ctags
9716         }
9717     } else {
9718         set cached_atags($origid) $tags
9719     }
9720     set t3 [clock clicks -milliseconds]
9721     if {0 && $t3 - $t1 >= 100} {
9722         puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9723             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9724     }
9725     return $tags
9728 # Return the list of IDs that have heads that are descendents of id,
9729 # including id itself if it has a head.
9730 proc descheads {id} {
9731     global arcnos arcstart arcids archeads idheads cached_dheads
9732     global allparents
9734     if {![info exists allparents($id)]} {
9735         return {}
9736     }
9737     set aret {}
9738     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9739         # part-way along an arc; check it first
9740         set a [lindex $arcnos($id) 0]
9741         if {$archeads($a) ne {}} {
9742             validate_archeads $a
9743             set i [lsearch -exact $arcids($a) $id]
9744             foreach t $archeads($a) {
9745                 set j [lsearch -exact $arcids($a) $t]
9746                 if {$j > $i} break
9747                 lappend aret $t
9748             }
9749         }
9750         set id $arcstart($a)
9751     }
9752     set origid $id
9753     set todo [list $id]
9754     set seen($id) 1
9755     set ret {}
9756     for {set i 0} {$i < [llength $todo]} {incr i} {
9757         set id [lindex $todo $i]
9758         if {[info exists cached_dheads($id)]} {
9759             set ret [concat $ret $cached_dheads($id)]
9760         } else {
9761             if {[info exists idheads($id)]} {
9762                 lappend ret $id
9763             }
9764             foreach a $arcnos($id) {
9765                 if {$archeads($a) ne {}} {
9766                     validate_archeads $a
9767                     if {$archeads($a) ne {}} {
9768                         set ret [concat $ret $archeads($a)]
9769                     }
9770                 }
9771                 set d $arcstart($a)
9772                 if {![info exists seen($d)]} {
9773                     lappend todo $d
9774                     set seen($d) 1
9775                 }
9776             }
9777         }
9778     }
9779     set ret [lsort -unique $ret]
9780     set cached_dheads($origid) $ret
9781     return [concat $ret $aret]
9784 proc addedtag {id} {
9785     global arcnos arcout cached_dtags cached_atags
9787     if {![info exists arcnos($id)]} return
9788     if {![info exists arcout($id)]} {
9789         recalcarc [lindex $arcnos($id) 0]
9790     }
9791     catch {unset cached_dtags}
9792     catch {unset cached_atags}
9795 proc addedhead {hid head} {
9796     global arcnos arcout cached_dheads
9798     if {![info exists arcnos($hid)]} return
9799     if {![info exists arcout($hid)]} {
9800         recalcarc [lindex $arcnos($hid) 0]
9801     }
9802     catch {unset cached_dheads}
9805 proc removedhead {hid head} {
9806     global cached_dheads
9808     catch {unset cached_dheads}
9811 proc movedhead {hid head} {
9812     global arcnos arcout cached_dheads
9814     if {![info exists arcnos($hid)]} return
9815     if {![info exists arcout($hid)]} {
9816         recalcarc [lindex $arcnos($hid) 0]
9817     }
9818     catch {unset cached_dheads}
9821 proc changedrefs {} {
9822     global cached_dheads cached_dtags cached_atags
9823     global arctags archeads arcnos arcout idheads idtags
9825     foreach id [concat [array names idheads] [array names idtags]] {
9826         if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9827             set a [lindex $arcnos($id) 0]
9828             if {![info exists donearc($a)]} {
9829                 recalcarc $a
9830                 set donearc($a) 1
9831             }
9832         }
9833     }
9834     catch {unset cached_dtags}
9835     catch {unset cached_atags}
9836     catch {unset cached_dheads}
9839 proc rereadrefs {} {
9840     global idtags idheads idotherrefs mainheadid
9842     set refids [concat [array names idtags] \
9843                     [array names idheads] [array names idotherrefs]]
9844     foreach id $refids {
9845         if {![info exists ref($id)]} {
9846             set ref($id) [listrefs $id]
9847         }
9848     }
9849     set oldmainhead $mainheadid
9850     readrefs
9851     changedrefs
9852     set refids [lsort -unique [concat $refids [array names idtags] \
9853                         [array names idheads] [array names idotherrefs]]]
9854     foreach id $refids {
9855         set v [listrefs $id]
9856         if {![info exists ref($id)] || $ref($id) != $v} {
9857             redrawtags $id
9858         }
9859     }
9860     if {$oldmainhead ne $mainheadid} {
9861         redrawtags $oldmainhead
9862         redrawtags $mainheadid
9863     }
9864     run refill_reflist
9867 proc listrefs {id} {
9868     global idtags idheads idotherrefs
9870     set x {}
9871     if {[info exists idtags($id)]} {
9872         set x $idtags($id)
9873     }
9874     set y {}
9875     if {[info exists idheads($id)]} {
9876         set y $idheads($id)
9877     }
9878     set z {}
9879     if {[info exists idotherrefs($id)]} {
9880         set z $idotherrefs($id)
9881     }
9882     return [list $x $y $z]
9885 proc showtag {tag isnew} {
9886     global ctext tagcontents tagids linknum tagobjid
9888     if {$isnew} {
9889         addtohistory [list showtag $tag 0]
9890     }
9891     $ctext conf -state normal
9892     clear_ctext
9893     settabs 0
9894     set linknum 0
9895     if {![info exists tagcontents($tag)]} {
9896         catch {
9897             set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9898         }
9899     }
9900     if {[info exists tagcontents($tag)]} {
9901         set text $tagcontents($tag)
9902     } else {
9903         set text "[mc "Tag"]: $tag\n[mc "Id"]:  $tagids($tag)"
9904     }
9905     appendwithlinks $text {}
9906     $ctext conf -state disabled
9907     init_flist {}
9910 proc doquit {} {
9911     global stopped
9912     global gitktmpdir
9914     set stopped 100
9915     savestuff .
9916     destroy .
9918     if {[info exists gitktmpdir]} {
9919         catch {file delete -force $gitktmpdir}
9920     }
9923 proc mkfontdisp {font top which} {
9924     global fontattr fontpref $font
9926     set fontpref($font) [set $font]
9927     button $top.${font}but -text $which -font optionfont \
9928         -command [list choosefont $font $which]
9929     label $top.$font -relief flat -font $font \
9930         -text $fontattr($font,family) -justify left
9931     grid x $top.${font}but $top.$font -sticky w
9934 proc choosefont {font which} {
9935     global fontparam fontlist fonttop fontattr
9936     global prefstop
9938     set fontparam(which) $which
9939     set fontparam(font) $font
9940     set fontparam(family) [font actual $font -family]
9941     set fontparam(size) $fontattr($font,size)
9942     set fontparam(weight) $fontattr($font,weight)
9943     set fontparam(slant) $fontattr($font,slant)
9944     set top .gitkfont
9945     set fonttop $top
9946     if {![winfo exists $top]} {
9947         font create sample
9948         eval font config sample [font actual $font]
9949         toplevel $top
9950         make_transient $top $prefstop
9951         wm title $top [mc "Gitk font chooser"]
9952         label $top.l -textvariable fontparam(which)
9953         pack $top.l -side top
9954         set fontlist [lsort [font families]]
9955         frame $top.f
9956         listbox $top.f.fam -listvariable fontlist \
9957             -yscrollcommand [list $top.f.sb set]
9958         bind $top.f.fam <<ListboxSelect>> selfontfam
9959         scrollbar $top.f.sb -command [list $top.f.fam yview]
9960         pack $top.f.sb -side right -fill y
9961         pack $top.f.fam -side left -fill both -expand 1
9962         pack $top.f -side top -fill both -expand 1
9963         frame $top.g
9964         spinbox $top.g.size -from 4 -to 40 -width 4 \
9965             -textvariable fontparam(size) \
9966             -validatecommand {string is integer -strict %s}
9967         checkbutton $top.g.bold -padx 5 \
9968             -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9969             -variable fontparam(weight) -onvalue bold -offvalue normal
9970         checkbutton $top.g.ital -padx 5 \
9971             -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0  \
9972             -variable fontparam(slant) -onvalue italic -offvalue roman
9973         pack $top.g.size $top.g.bold $top.g.ital -side left
9974         pack $top.g -side top
9975         canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
9976             -background white
9977         $top.c create text 100 25 -anchor center -text $which -font sample \
9978             -fill black -tags text
9979         bind $top.c <Configure> [list centertext $top.c]
9980         pack $top.c -side top -fill x
9981         frame $top.buts
9982         button $top.buts.ok -text [mc "OK"] -command fontok -default active
9983         button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
9984         bind $top <Key-Return> fontok
9985         bind $top <Key-Escape> fontcan
9986         grid $top.buts.ok $top.buts.can
9987         grid columnconfigure $top.buts 0 -weight 1 -uniform a
9988         grid columnconfigure $top.buts 1 -weight 1 -uniform a
9989         pack $top.buts -side bottom -fill x
9990         trace add variable fontparam write chg_fontparam
9991     } else {
9992         raise $top
9993         $top.c itemconf text -text $which
9994     }
9995     set i [lsearch -exact $fontlist $fontparam(family)]
9996     if {$i >= 0} {
9997         $top.f.fam selection set $i
9998         $top.f.fam see $i
9999     }
10002 proc centertext {w} {
10003     $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10006 proc fontok {} {
10007     global fontparam fontpref prefstop
10009     set f $fontparam(font)
10010     set fontpref($f) [list $fontparam(family) $fontparam(size)]
10011     if {$fontparam(weight) eq "bold"} {
10012         lappend fontpref($f) "bold"
10013     }
10014     if {$fontparam(slant) eq "italic"} {
10015         lappend fontpref($f) "italic"
10016     }
10017     set w $prefstop.$f
10018     $w conf -text $fontparam(family) -font $fontpref($f)
10019         
10020     fontcan
10023 proc fontcan {} {
10024     global fonttop fontparam
10026     if {[info exists fonttop]} {
10027         catch {destroy $fonttop}
10028         catch {font delete sample}
10029         unset fonttop
10030         unset fontparam
10031     }
10034 proc selfontfam {} {
10035     global fonttop fontparam
10037     set i [$fonttop.f.fam curselection]
10038     if {$i ne {}} {
10039         set fontparam(family) [$fonttop.f.fam get $i]
10040     }
10043 proc chg_fontparam {v sub op} {
10044     global fontparam
10046     font config sample -$sub $fontparam($sub)
10049 proc doprefs {} {
10050     global maxwidth maxgraphpct
10051     global oldprefs prefstop showneartags showlocalchanges
10052     global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10053     global tabstop limitdiffs autoselect extdifftool perfile_attrs
10055     set top .gitkprefs
10056     set prefstop $top
10057     if {[winfo exists $top]} {
10058         raise $top
10059         return
10060     }
10061     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10062                    limitdiffs tabstop perfile_attrs} {
10063         set oldprefs($v) [set $v]
10064     }
10065     toplevel $top
10066     wm title $top [mc "Gitk preferences"]
10067     make_transient $top .
10068     label $top.ldisp -text [mc "Commit list display options"]
10069     grid $top.ldisp - -sticky w -pady 10
10070     label $top.spacer -text " "
10071     label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10072         -font optionfont
10073     spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10074     grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10075     label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10076         -font optionfont
10077     spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10078     grid x $top.maxpctl $top.maxpct -sticky w
10079     frame $top.showlocal
10080     label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
10081     checkbutton $top.showlocal.b -variable showlocalchanges
10082     pack $top.showlocal.b $top.showlocal.l -side left
10083     grid x $top.showlocal -sticky w
10084     frame $top.autoselect
10085     label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
10086     checkbutton $top.autoselect.b -variable autoselect
10087     pack $top.autoselect.b $top.autoselect.l -side left
10088     grid x $top.autoselect -sticky w
10090     label $top.ddisp -text [mc "Diff display options"]
10091     grid $top.ddisp - -sticky w -pady 10
10092     label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10093     spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10094     grid x $top.tabstopl $top.tabstop -sticky w
10095     frame $top.ntag
10096     label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
10097     checkbutton $top.ntag.b -variable showneartags
10098     pack $top.ntag.b $top.ntag.l -side left
10099     grid x $top.ntag -sticky w
10100     frame $top.ldiff
10101     label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
10102     checkbutton $top.ldiff.b -variable limitdiffs
10103     pack $top.ldiff.b $top.ldiff.l -side left
10104     grid x $top.ldiff -sticky w
10105     frame $top.lattr
10106     label $top.lattr.l -text [mc "Support per-file encodings"] -font optionfont
10107     checkbutton $top.lattr.b -variable perfile_attrs
10108     pack $top.lattr.b $top.lattr.l -side left
10109     grid x $top.lattr -sticky w
10111     entry $top.extdifft -textvariable extdifftool
10112     frame $top.extdifff
10113     label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10114         -padx 10
10115     button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10116         -command choose_extdiff
10117     pack $top.extdifff.l $top.extdifff.b -side left
10118     grid x $top.extdifff $top.extdifft -sticky w
10120     label $top.cdisp -text [mc "Colors: press to choose"]
10121     grid $top.cdisp - -sticky w -pady 10
10122     label $top.bg -padx 40 -relief sunk -background $bgcolor
10123     button $top.bgbut -text [mc "Background"] -font optionfont \
10124         -command [list choosecolor bgcolor {} $top.bg background setbg]
10125     grid x $top.bgbut $top.bg -sticky w
10126     label $top.fg -padx 40 -relief sunk -background $fgcolor
10127     button $top.fgbut -text [mc "Foreground"] -font optionfont \
10128         -command [list choosecolor fgcolor {} $top.fg foreground setfg]
10129     grid x $top.fgbut $top.fg -sticky w
10130     label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10131     button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10132         -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
10133                       [list $ctext tag conf d0 -foreground]]
10134     grid x $top.diffoldbut $top.diffold -sticky w
10135     label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10136     button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10137         -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
10138                       [list $ctext tag conf dresult -foreground]]
10139     grid x $top.diffnewbut $top.diffnew -sticky w
10140     label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10141     button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10142         -command [list choosecolor diffcolors 2 $top.hunksep \
10143                       "diff hunk header" \
10144                       [list $ctext tag conf hunksep -foreground]]
10145     grid x $top.hunksepbut $top.hunksep -sticky w
10146     label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10147     button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10148         -command [list choosecolor markbgcolor {} $top.markbgsep \
10149                       [mc "marked line background"] \
10150                       [list $ctext tag conf omark -background]]
10151     grid x $top.markbgbut $top.markbgsep -sticky w
10152     label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10153     button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10154         -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
10155     grid x $top.selbgbut $top.selbgsep -sticky w
10157     label $top.cfont -text [mc "Fonts: press to choose"]
10158     grid $top.cfont - -sticky w -pady 10
10159     mkfontdisp mainfont $top [mc "Main font"]
10160     mkfontdisp textfont $top [mc "Diff display font"]
10161     mkfontdisp uifont $top [mc "User interface font"]
10163     frame $top.buts
10164     button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10165     button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10166     bind $top <Key-Return> prefsok
10167     bind $top <Key-Escape> prefscan
10168     grid $top.buts.ok $top.buts.can
10169     grid columnconfigure $top.buts 0 -weight 1 -uniform a
10170     grid columnconfigure $top.buts 1 -weight 1 -uniform a
10171     grid $top.buts - - -pady 10 -sticky ew
10172     bind $top <Visibility> "focus $top.buts.ok"
10175 proc choose_extdiff {} {
10176     global extdifftool
10178     set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10179     if {$prog ne {}} {
10180         set extdifftool $prog
10181     }
10184 proc choosecolor {v vi w x cmd} {
10185     global $v
10187     set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10188                -title [mc "Gitk: choose color for %s" $x]]
10189     if {$c eq {}} return
10190     $w conf -background $c
10191     lset $v $vi $c
10192     eval $cmd $c
10195 proc setselbg {c} {
10196     global bglist cflist
10197     foreach w $bglist {
10198         $w configure -selectbackground $c
10199     }
10200     $cflist tag configure highlight \
10201         -background [$cflist cget -selectbackground]
10202     allcanvs itemconf secsel -fill $c
10205 proc setbg {c} {
10206     global bglist
10208     foreach w $bglist {
10209         $w conf -background $c
10210     }
10213 proc setfg {c} {
10214     global fglist canv
10216     foreach w $fglist {
10217         $w conf -foreground $c
10218     }
10219     allcanvs itemconf text -fill $c
10220     $canv itemconf circle -outline $c
10223 proc prefscan {} {
10224     global oldprefs prefstop
10226     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10227                    limitdiffs tabstop perfile_attrs} {
10228         global $v
10229         set $v $oldprefs($v)
10230     }
10231     catch {destroy $prefstop}
10232     unset prefstop
10233     fontcan
10236 proc prefsok {} {
10237     global maxwidth maxgraphpct
10238     global oldprefs prefstop showneartags showlocalchanges
10239     global fontpref mainfont textfont uifont
10240     global limitdiffs treediffs perfile_attrs
10242     catch {destroy $prefstop}
10243     unset prefstop
10244     fontcan
10245     set fontchanged 0
10246     if {$mainfont ne $fontpref(mainfont)} {
10247         set mainfont $fontpref(mainfont)
10248         parsefont mainfont $mainfont
10249         eval font configure mainfont [fontflags mainfont]
10250         eval font configure mainfontbold [fontflags mainfont 1]
10251         setcoords
10252         set fontchanged 1
10253     }
10254     if {$textfont ne $fontpref(textfont)} {
10255         set textfont $fontpref(textfont)
10256         parsefont textfont $textfont
10257         eval font configure textfont [fontflags textfont]
10258         eval font configure textfontbold [fontflags textfont 1]
10259     }
10260     if {$uifont ne $fontpref(uifont)} {
10261         set uifont $fontpref(uifont)
10262         parsefont uifont $uifont
10263         eval font configure uifont [fontflags uifont]
10264     }
10265     settabs
10266     if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10267         if {$showlocalchanges} {
10268             doshowlocalchanges
10269         } else {
10270             dohidelocalchanges
10271         }
10272     }
10273     if {$limitdiffs != $oldprefs(limitdiffs) ||
10274         ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10275         # treediffs elements are limited by path;
10276         # won't have encodings cached if perfile_attrs was just turned on
10277         catch {unset treediffs}
10278     }
10279     if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10280         || $maxgraphpct != $oldprefs(maxgraphpct)} {
10281         redisplay
10282     } elseif {$showneartags != $oldprefs(showneartags) ||
10283           $limitdiffs != $oldprefs(limitdiffs)} {
10284         reselectline
10285     }
10288 proc formatdate {d} {
10289     global datetimeformat
10290     if {$d ne {}} {
10291         set d [clock format $d -format $datetimeformat]
10292     }
10293     return $d
10296 # This list of encoding names and aliases is distilled from
10297 # http://www.iana.org/assignments/character-sets.
10298 # Not all of them are supported by Tcl.
10299 set encoding_aliases {
10300     { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10301       ISO646-US US-ASCII us IBM367 cp367 csASCII }
10302     { ISO-10646-UTF-1 csISO10646UTF1 }
10303     { ISO_646.basic:1983 ref csISO646basic1983 }
10304     { INVARIANT csINVARIANT }
10305     { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10306     { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10307     { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10308     { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10309     { NATS-DANO iso-ir-9-1 csNATSDANO }
10310     { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10311     { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10312     { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10313     { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10314     { ISO-2022-KR csISO2022KR }
10315     { EUC-KR csEUCKR }
10316     { ISO-2022-JP csISO2022JP }
10317     { ISO-2022-JP-2 csISO2022JP2 }
10318     { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10319       csISO13JISC6220jp }
10320     { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10321     { IT iso-ir-15 ISO646-IT csISO15Italian }
10322     { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10323     { ES iso-ir-17 ISO646-ES csISO17Spanish }
10324     { greek7-old iso-ir-18 csISO18Greek7Old }
10325     { latin-greek iso-ir-19 csISO19LatinGreek }
10326     { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10327     { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10328     { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10329     { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10330     { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10331     { BS_viewdata iso-ir-47 csISO47BSViewdata }
10332     { INIS iso-ir-49 csISO49INIS }
10333     { INIS-8 iso-ir-50 csISO50INIS8 }
10334     { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10335     { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10336     { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10337     { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10338     { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10339     { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10340       csISO60Norwegian1 }
10341     { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10342     { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10343     { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10344     { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10345     { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10346     { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10347     { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10348     { greek7 iso-ir-88 csISO88Greek7 }
10349     { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10350     { iso-ir-90 csISO90 }
10351     { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10352     { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10353       csISO92JISC62991984b }
10354     { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10355     { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10356     { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10357       csISO95JIS62291984handadd }
10358     { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10359     { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10360     { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10361     { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10362       CP819 csISOLatin1 }
10363     { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10364     { T.61-7bit iso-ir-102 csISO102T617bit }
10365     { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10366     { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10367     { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10368     { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10369     { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10370     { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10371     { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10372     { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10373       arabic csISOLatinArabic }
10374     { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10375     { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10376     { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10377       greek greek8 csISOLatinGreek }
10378     { T.101-G2 iso-ir-128 csISO128T101G2 }
10379     { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10380       csISOLatinHebrew }
10381     { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10382     { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10383     { CSN_369103 iso-ir-139 csISO139CSN369103 }
10384     { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10385     { ISO_6937-2-add iso-ir-142 csISOTextComm }
10386     { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10387     { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10388       csISOLatinCyrillic }
10389     { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10390     { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10391     { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10392     { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10393     { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10394     { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10395     { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10396     { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10397     { ISO_10367-box iso-ir-155 csISO10367Box }
10398     { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10399     { latin-lap lap iso-ir-158 csISO158Lap }
10400     { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10401     { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10402     { us-dk csUSDK }
10403     { dk-us csDKUS }
10404     { JIS_X0201 X0201 csHalfWidthKatakana }
10405     { KSC5636 ISO646-KR csKSC5636 }
10406     { ISO-10646-UCS-2 csUnicode }
10407     { ISO-10646-UCS-4 csUCS4 }
10408     { DEC-MCS dec csDECMCS }
10409     { hp-roman8 roman8 r8 csHPRoman8 }
10410     { macintosh mac csMacintosh }
10411     { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10412       csIBM037 }
10413     { IBM038 EBCDIC-INT cp038 csIBM038 }
10414     { IBM273 CP273 csIBM273 }
10415     { IBM274 EBCDIC-BE CP274 csIBM274 }
10416     { IBM275 EBCDIC-BR cp275 csIBM275 }
10417     { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10418     { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10419     { IBM280 CP280 ebcdic-cp-it csIBM280 }
10420     { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10421     { IBM284 CP284 ebcdic-cp-es csIBM284 }
10422     { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10423     { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10424     { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10425     { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10426     { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10427     { IBM424 cp424 ebcdic-cp-he csIBM424 }
10428     { IBM437 cp437 437 csPC8CodePage437 }
10429     { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10430     { IBM775 cp775 csPC775Baltic }
10431     { IBM850 cp850 850 csPC850Multilingual }
10432     { IBM851 cp851 851 csIBM851 }
10433     { IBM852 cp852 852 csPCp852 }
10434     { IBM855 cp855 855 csIBM855 }
10435     { IBM857 cp857 857 csIBM857 }
10436     { IBM860 cp860 860 csIBM860 }
10437     { IBM861 cp861 861 cp-is csIBM861 }
10438     { IBM862 cp862 862 csPC862LatinHebrew }
10439     { IBM863 cp863 863 csIBM863 }
10440     { IBM864 cp864 csIBM864 }
10441     { IBM865 cp865 865 csIBM865 }
10442     { IBM866 cp866 866 csIBM866 }
10443     { IBM868 CP868 cp-ar csIBM868 }
10444     { IBM869 cp869 869 cp-gr csIBM869 }
10445     { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10446     { IBM871 CP871 ebcdic-cp-is csIBM871 }
10447     { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10448     { IBM891 cp891 csIBM891 }
10449     { IBM903 cp903 csIBM903 }
10450     { IBM904 cp904 904 csIBBM904 }
10451     { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10452     { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10453     { IBM1026 CP1026 csIBM1026 }
10454     { EBCDIC-AT-DE csIBMEBCDICATDE }
10455     { EBCDIC-AT-DE-A csEBCDICATDEA }
10456     { EBCDIC-CA-FR csEBCDICCAFR }
10457     { EBCDIC-DK-NO csEBCDICDKNO }
10458     { EBCDIC-DK-NO-A csEBCDICDKNOA }
10459     { EBCDIC-FI-SE csEBCDICFISE }
10460     { EBCDIC-FI-SE-A csEBCDICFISEA }
10461     { EBCDIC-FR csEBCDICFR }
10462     { EBCDIC-IT csEBCDICIT }
10463     { EBCDIC-PT csEBCDICPT }
10464     { EBCDIC-ES csEBCDICES }
10465     { EBCDIC-ES-A csEBCDICESA }
10466     { EBCDIC-ES-S csEBCDICESS }
10467     { EBCDIC-UK csEBCDICUK }
10468     { EBCDIC-US csEBCDICUS }
10469     { UNKNOWN-8BIT csUnknown8BiT }
10470     { MNEMONIC csMnemonic }
10471     { MNEM csMnem }
10472     { VISCII csVISCII }
10473     { VIQR csVIQR }
10474     { KOI8-R csKOI8R }
10475     { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10476     { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10477     { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10478     { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10479     { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10480     { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10481     { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10482     { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10483     { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10484     { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10485     { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10486     { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10487     { IBM1047 IBM-1047 }
10488     { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10489     { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10490     { UNICODE-1-1 csUnicode11 }
10491     { CESU-8 csCESU-8 }
10492     { BOCU-1 csBOCU-1 }
10493     { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10494     { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10495       l8 }
10496     { ISO-8859-15 ISO_8859-15 Latin-9 }
10497     { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10498     { GBK CP936 MS936 windows-936 }
10499     { JIS_Encoding csJISEncoding }
10500     { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10501     { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10502       EUC-JP }
10503     { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10504     { ISO-10646-UCS-Basic csUnicodeASCII }
10505     { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10506     { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10507     { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10508     { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10509     { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10510     { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10511     { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10512     { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10513     { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10514     { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10515     { Adobe-Standard-Encoding csAdobeStandardEncoding }
10516     { Ventura-US csVenturaUS }
10517     { Ventura-International csVenturaInternational }
10518     { PC8-Danish-Norwegian csPC8DanishNorwegian }
10519     { PC8-Turkish csPC8Turkish }
10520     { IBM-Symbols csIBMSymbols }
10521     { IBM-Thai csIBMThai }
10522     { HP-Legal csHPLegal }
10523     { HP-Pi-font csHPPiFont }
10524     { HP-Math8 csHPMath8 }
10525     { Adobe-Symbol-Encoding csHPPSMath }
10526     { HP-DeskTop csHPDesktop }
10527     { Ventura-Math csVenturaMath }
10528     { Microsoft-Publishing csMicrosoftPublishing }
10529     { Windows-31J csWindows31J }
10530     { GB2312 csGB2312 }
10531     { Big5 csBig5 }
10534 proc tcl_encoding {enc} {
10535     global encoding_aliases tcl_encoding_cache
10536     if {[info exists tcl_encoding_cache($enc)]} {
10537         return $tcl_encoding_cache($enc)
10538     }
10539     set names [encoding names]
10540     set lcnames [string tolower $names]
10541     set enc [string tolower $enc]
10542     set i [lsearch -exact $lcnames $enc]
10543     if {$i < 0} {
10544         # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10545         if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10546             set i [lsearch -exact $lcnames $encx]
10547         }
10548     }
10549     if {$i < 0} {
10550         foreach l $encoding_aliases {
10551             set ll [string tolower $l]
10552             if {[lsearch -exact $ll $enc] < 0} continue
10553             # look through the aliases for one that tcl knows about
10554             foreach e $ll {
10555                 set i [lsearch -exact $lcnames $e]
10556                 if {$i < 0} {
10557                     if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10558                         set i [lsearch -exact $lcnames $ex]
10559                     }
10560                 }
10561                 if {$i >= 0} break
10562             }
10563             break
10564         }
10565     }
10566     set tclenc {}
10567     if {$i >= 0} {
10568         set tclenc [lindex $names $i]
10569     }
10570     set tcl_encoding_cache($enc) $tclenc
10571     return $tclenc
10574 proc gitattr {path attr default} {
10575     global path_attr_cache
10576     if {[info exists path_attr_cache($attr,$path)]} {
10577         set r $path_attr_cache($attr,$path)
10578     } else {
10579         set r "unspecified"
10580         if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10581             regexp "(.*): encoding: (.*)" $line m f r
10582         }
10583         set path_attr_cache($attr,$path) $r
10584     }
10585     if {$r eq "unspecified"} {
10586         return $default
10587     }
10588     return $r
10591 proc cache_gitattr {attr pathlist} {
10592     global path_attr_cache
10593     set newlist {}
10594     foreach path $pathlist {
10595         if {![info exists path_attr_cache($attr,$path)]} {
10596             lappend newlist $path
10597         }
10598     }
10599     set lim 1000
10600     if {[tk windowingsystem] == "win32"} {
10601         # windows has a 32k limit on the arguments to a command...
10602         set lim 30
10603     }
10604     while {$newlist ne {}} {
10605         set head [lrange $newlist 0 [expr {$lim - 1}]]
10606         set newlist [lrange $newlist $lim end]
10607         if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10608             foreach row [split $rlist "\n"] {
10609                 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10610                     if {[string index $path 0] eq "\""} {
10611                         set path [encoding convertfrom [lindex $path 0]]
10612                     }
10613                     set path_attr_cache($attr,$path) $value
10614                 }
10615             }
10616         }
10617     }
10620 proc get_path_encoding {path} {
10621     global gui_encoding perfile_attrs
10622     set tcl_enc $gui_encoding
10623     if {$path ne {} && $perfile_attrs} {
10624         set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10625         if {$enc2 ne {}} {
10626             set tcl_enc $enc2
10627         }
10628     }
10629     return $tcl_enc
10632 # First check that Tcl/Tk is recent enough
10633 if {[catch {package require Tk 8.4} err]} {
10634     show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10635                      Gitk requires at least Tcl/Tk 8.4."]
10636     exit 1
10639 # defaults...
10640 set wrcomcmd "git diff-tree --stdin -p --pretty"
10642 set gitencoding {}
10643 catch {
10644     set gitencoding [exec git config --get i18n.commitencoding]
10646 catch {
10647     set gitencoding [exec git config --get i18n.logoutputencoding]
10649 if {$gitencoding == ""} {
10650     set gitencoding "utf-8"
10652 set tclencoding [tcl_encoding $gitencoding]
10653 if {$tclencoding == {}} {
10654     puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10657 set gui_encoding [encoding system]
10658 catch {
10659     set enc [exec git config --get gui.encoding]
10660     if {$enc ne {}} {
10661         set tclenc [tcl_encoding $enc]
10662         if {$tclenc ne {}} {
10663             set gui_encoding $tclenc
10664         } else {
10665             puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10666         }
10667     }
10670 set mainfont {Helvetica 9}
10671 set textfont {Courier 9}
10672 set uifont {Helvetica 9 bold}
10673 set tabstop 8
10674 set findmergefiles 0
10675 set maxgraphpct 50
10676 set maxwidth 16
10677 set revlistorder 0
10678 set fastdate 0
10679 set uparrowlen 5
10680 set downarrowlen 5
10681 set mingaplen 100
10682 set cmitmode "patch"
10683 set wrapcomment "none"
10684 set showneartags 1
10685 set maxrefs 20
10686 set maxlinelen 200
10687 set showlocalchanges 1
10688 set limitdiffs 1
10689 set datetimeformat "%Y-%m-%d %H:%M:%S"
10690 set autoselect 1
10691 set perfile_attrs 0
10693 set extdifftool "meld"
10695 set colors {green red blue magenta darkgrey brown orange}
10696 set bgcolor white
10697 set fgcolor black
10698 set diffcolors {red "#00a000" blue}
10699 set diffcontext 3
10700 set ignorespace 0
10701 set selectbgcolor gray85
10702 set markbgcolor "#e0e0ff"
10704 set circlecolors {white blue gray blue blue}
10706 # button for popping up context menus
10707 if {[tk windowingsystem] eq "aqua"} {
10708     set ctxbut <Button-2>
10709 } else {
10710     set ctxbut <Button-3>
10713 ## For msgcat loading, first locate the installation location.
10714 if { [info exists ::env(GITK_MSGSDIR)] } {
10715     ## Msgsdir was manually set in the environment.
10716     set gitk_msgsdir $::env(GITK_MSGSDIR)
10717 } else {
10718     ## Let's guess the prefix from argv0.
10719     set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10720     set gitk_libdir [file join $gitk_prefix share gitk lib]
10721     set gitk_msgsdir [file join $gitk_libdir msgs]
10722     unset gitk_prefix
10725 ## Internationalization (i18n) through msgcat and gettext. See
10726 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10727 package require msgcat
10728 namespace import ::msgcat::mc
10729 ## And eventually load the actual message catalog
10730 ::msgcat::mcload $gitk_msgsdir
10732 catch {source ~/.gitk}
10734 font create optionfont -family sans-serif -size -12
10736 parsefont mainfont $mainfont
10737 eval font create mainfont [fontflags mainfont]
10738 eval font create mainfontbold [fontflags mainfont 1]
10740 parsefont textfont $textfont
10741 eval font create textfont [fontflags textfont]
10742 eval font create textfontbold [fontflags textfont 1]
10744 parsefont uifont $uifont
10745 eval font create uifont [fontflags uifont]
10747 setoptions
10749 # check that we can find a .git directory somewhere...
10750 if {[catch {set gitdir [gitdir]}]} {
10751     show_error {} . [mc "Cannot find a git repository here."]
10752     exit 1
10754 if {![file isdirectory $gitdir]} {
10755     show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10756     exit 1
10759 set selecthead {}
10760 set selectheadid {}
10762 set revtreeargs {}
10763 set cmdline_files {}
10764 set i 0
10765 set revtreeargscmd {}
10766 foreach arg $argv {
10767     switch -glob -- $arg {
10768         "" { }
10769         "--" {
10770             set cmdline_files [lrange $argv [expr {$i + 1}] end]
10771             break
10772         }
10773         "--select-commit=*" {
10774             set selecthead [string range $arg 16 end]
10775         }
10776         "--argscmd=*" {
10777             set revtreeargscmd [string range $arg 10 end]
10778         }
10779         default {
10780             lappend revtreeargs $arg
10781         }
10782     }
10783     incr i
10786 if {$selecthead eq "HEAD"} {
10787     set selecthead {}
10790 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10791     # no -- on command line, but some arguments (other than --argscmd)
10792     if {[catch {
10793         set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10794         set cmdline_files [split $f "\n"]
10795         set n [llength $cmdline_files]
10796         set revtreeargs [lrange $revtreeargs 0 end-$n]
10797         # Unfortunately git rev-parse doesn't produce an error when
10798         # something is both a revision and a filename.  To be consistent
10799         # with git log and git rev-list, check revtreeargs for filenames.
10800         foreach arg $revtreeargs {
10801             if {[file exists $arg]} {
10802                 show_error {} . [mc "Ambiguous argument '%s': both revision\
10803                                  and filename" $arg]
10804                 exit 1
10805             }
10806         }
10807     } err]} {
10808         # unfortunately we get both stdout and stderr in $err,
10809         # so look for "fatal:".
10810         set i [string first "fatal:" $err]
10811         if {$i > 0} {
10812             set err [string range $err [expr {$i + 6}] end]
10813         }
10814         show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10815         exit 1
10816     }
10819 set nullid "0000000000000000000000000000000000000000"
10820 set nullid2 "0000000000000000000000000000000000000001"
10821 set nullfile "/dev/null"
10823 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10825 set runq {}
10826 set history {}
10827 set historyindex 0
10828 set fh_serial 0
10829 set nhl_names {}
10830 set highlight_paths {}
10831 set findpattern {}
10832 set searchdirn -forwards
10833 set boldids {}
10834 set boldnameids {}
10835 set diffelide {0 0}
10836 set markingmatches 0
10837 set linkentercount 0
10838 set need_redisplay 0
10839 set nrows_drawn 0
10840 set firsttabstop 0
10842 set nextviewnum 1
10843 set curview 0
10844 set selectedview 0
10845 set selectedhlview [mc "None"]
10846 set highlight_related [mc "None"]
10847 set highlight_files {}
10848 set viewfiles(0) {}
10849 set viewperm(0) 0
10850 set viewargs(0) {}
10851 set viewargscmd(0) {}
10853 set selectedline {}
10854 set numcommits 0
10855 set loginstance 0
10856 set cmdlineok 0
10857 set stopped 0
10858 set stuffsaved 0
10859 set patchnum 0
10860 set lserial 0
10861 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10862 setcoords
10863 makewindow
10864 # wait for the window to become visible
10865 tkwait visibility .
10866 wm title . "[file tail $argv0]: [file tail [pwd]]"
10867 readrefs
10869 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10870     # create a view for the files/dirs specified on the command line
10871     set curview 1
10872     set selectedview 1
10873     set nextviewnum 2
10874     set viewname(1) [mc "Command line"]
10875     set viewfiles(1) $cmdline_files
10876     set viewargs(1) $revtreeargs
10877     set viewargscmd(1) $revtreeargscmd
10878     set viewperm(1) 0
10879     set vdatemode(1) 0
10880     addviewmenu 1
10881     .bar.view entryconf [mca "Edit view..."] -state normal
10882     .bar.view entryconf [mca "Delete view"] -state normal
10885 if {[info exists permviews]} {
10886     foreach v $permviews {
10887         set n $nextviewnum
10888         incr nextviewnum
10889         set viewname($n) [lindex $v 0]
10890         set viewfiles($n) [lindex $v 1]
10891         set viewargs($n) [lindex $v 2]
10892         set viewargscmd($n) [lindex $v 3]
10893         set viewperm($n) 1
10894         addviewmenu $n
10895     }
10897 getcommits {}