Code

gitk: Ensure that "Reset branch" menu entry is enabled
[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             {xx "" separator}
1915             {mc "Start git gui" command {exec git gui &}}
1916             {xx "" separator}
1917             {mc "Quit" command doquit -accelerator Meta1-Q}
1918         }}
1919         {mc "Edit" cascade {
1920             {mc "Preferences" command doprefs}
1921         }}
1922         {mc "View" cascade {
1923             {mc "New view..." command {newview 0} -accelerator Shift-F4}
1924             {mc "Edit view..." command editview -state disabled -accelerator F4}
1925             {mc "Delete view" command delview -state disabled}
1926             {xx "" separator}
1927             {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
1928         }}
1929         {mc "Help" cascade {
1930             {mc "About gitk" command about}
1931             {mc "Key bindings" command keys}
1932         }}
1933     }
1934     . configure -menu .bar
1936     # the gui has upper and lower half, parts of a paned window.
1937     panedwindow .ctop -orient vertical
1939     # possibly use assumed geometry
1940     if {![info exists geometry(pwsash0)]} {
1941         set geometry(topheight) [expr {15 * $linespc}]
1942         set geometry(topwidth) [expr {80 * $charspc}]
1943         set geometry(botheight) [expr {15 * $linespc}]
1944         set geometry(botwidth) [expr {50 * $charspc}]
1945         set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1946         set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1947     }
1949     # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1950     frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1951     frame .tf.histframe
1952     panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1954     # create three canvases
1955     set cscroll .tf.histframe.csb
1956     set canv .tf.histframe.pwclist.canv
1957     canvas $canv \
1958         -selectbackground $selectbgcolor \
1959         -background $bgcolor -bd 0 \
1960         -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1961     .tf.histframe.pwclist add $canv
1962     set canv2 .tf.histframe.pwclist.canv2
1963     canvas $canv2 \
1964         -selectbackground $selectbgcolor \
1965         -background $bgcolor -bd 0 -yscrollincr $linespc
1966     .tf.histframe.pwclist add $canv2
1967     set canv3 .tf.histframe.pwclist.canv3
1968     canvas $canv3 \
1969         -selectbackground $selectbgcolor \
1970         -background $bgcolor -bd 0 -yscrollincr $linespc
1971     .tf.histframe.pwclist add $canv3
1972     eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1973     eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1975     # a scroll bar to rule them
1976     scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1977     pack $cscroll -side right -fill y
1978     bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1979     lappend bglist $canv $canv2 $canv3
1980     pack .tf.histframe.pwclist -fill both -expand 1 -side left
1982     # we have two button bars at bottom of top frame. Bar 1
1983     frame .tf.bar
1984     frame .tf.lbar -height 15
1986     set sha1entry .tf.bar.sha1
1987     set entries $sha1entry
1988     set sha1but .tf.bar.sha1label
1989     button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
1990         -command gotocommit -width 8
1991     $sha1but conf -disabledforeground [$sha1but cget -foreground]
1992     pack .tf.bar.sha1label -side left
1993     entry $sha1entry -width 40 -font textfont -textvariable sha1string
1994     trace add variable sha1string write sha1change
1995     pack $sha1entry -side left -pady 2
1997     image create bitmap bm-left -data {
1998         #define left_width 16
1999         #define left_height 16
2000         static unsigned char left_bits[] = {
2001         0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2002         0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2003         0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2004     }
2005     image create bitmap bm-right -data {
2006         #define right_width 16
2007         #define right_height 16
2008         static unsigned char right_bits[] = {
2009         0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2010         0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2011         0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2012     }
2013     button .tf.bar.leftbut -image bm-left -command goback \
2014         -state disabled -width 26
2015     pack .tf.bar.leftbut -side left -fill y
2016     button .tf.bar.rightbut -image bm-right -command goforw \
2017         -state disabled -width 26
2018     pack .tf.bar.rightbut -side left -fill y
2020     label .tf.bar.rowlabel -text [mc "Row"]
2021     set rownumsel {}
2022     label .tf.bar.rownum -width 7 -font textfont -textvariable rownumsel \
2023         -relief sunken -anchor e
2024     label .tf.bar.rowlabel2 -text "/"
2025     label .tf.bar.numcommits -width 7 -font textfont -textvariable numcommits \
2026         -relief sunken -anchor e
2027     pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2028         -side left
2029     global selectedline
2030     trace add variable selectedline write selectedline_change
2032     # Status label and progress bar
2033     set statusw .tf.bar.status
2034     label $statusw -width 15 -relief sunken
2035     pack $statusw -side left -padx 5
2036     set h [expr {[font metrics uifont -linespace] + 2}]
2037     set progresscanv .tf.bar.progress
2038     canvas $progresscanv -relief sunken -height $h -borderwidth 2
2039     set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2040     set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2041     set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2042     pack $progresscanv -side right -expand 1 -fill x
2043     set progresscoords {0 0}
2044     set fprogcoord 0
2045     set rprogcoord 0
2046     bind $progresscanv <Configure> adjustprogress
2047     set lastprogupdate [clock clicks -milliseconds]
2048     set progupdatepending 0
2050     # build up the bottom bar of upper window
2051     label .tf.lbar.flabel -text "[mc "Find"] "
2052     button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2053     button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2054     label .tf.lbar.flab2 -text " [mc "commit"] "
2055     pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2056         -side left -fill y
2057     set gdttype [mc "containing:"]
2058     set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
2059                 [mc "containing:"] \
2060                 [mc "touching paths:"] \
2061                 [mc "adding/removing string:"]]
2062     trace add variable gdttype write gdttype_change
2063     pack .tf.lbar.gdttype -side left -fill y
2065     set findstring {}
2066     set fstring .tf.lbar.findstring
2067     lappend entries $fstring
2068     entry $fstring -width 30 -font textfont -textvariable findstring
2069     trace add variable findstring write find_change
2070     set findtype [mc "Exact"]
2071     set findtypemenu [tk_optionMenu .tf.lbar.findtype \
2072                       findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2073     trace add variable findtype write findcom_change
2074     set findloc [mc "All fields"]
2075     tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2076         [mc "Comments"] [mc "Author"] [mc "Committer"]
2077     trace add variable findloc write find_change
2078     pack .tf.lbar.findloc -side right
2079     pack .tf.lbar.findtype -side right
2080     pack $fstring -side left -expand 1 -fill x
2082     # Finish putting the upper half of the viewer together
2083     pack .tf.lbar -in .tf -side bottom -fill x
2084     pack .tf.bar -in .tf -side bottom -fill x
2085     pack .tf.histframe -fill both -side top -expand 1
2086     .ctop add .tf
2087     .ctop paneconfigure .tf -height $geometry(topheight)
2088     .ctop paneconfigure .tf -width $geometry(topwidth)
2090     # now build up the bottom
2091     panedwindow .pwbottom -orient horizontal
2093     # lower left, a text box over search bar, scroll bar to the right
2094     # if we know window height, then that will set the lower text height, otherwise
2095     # we set lower text height which will drive window height
2096     if {[info exists geometry(main)]} {
2097         frame .bleft -width $geometry(botwidth)
2098     } else {
2099         frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2100     }
2101     frame .bleft.top
2102     frame .bleft.mid
2103     frame .bleft.bottom
2105     button .bleft.top.search -text [mc "Search"] -command dosearch
2106     pack .bleft.top.search -side left -padx 5
2107     set sstring .bleft.top.sstring
2108     entry $sstring -width 20 -font textfont -textvariable searchstring
2109     lappend entries $sstring
2110     trace add variable searchstring write incrsearch
2111     pack $sstring -side left -expand 1 -fill x
2112     radiobutton .bleft.mid.diff -text [mc "Diff"] \
2113         -command changediffdisp -variable diffelide -value {0 0}
2114     radiobutton .bleft.mid.old -text [mc "Old version"] \
2115         -command changediffdisp -variable diffelide -value {0 1}
2116     radiobutton .bleft.mid.new -text [mc "New version"] \
2117         -command changediffdisp -variable diffelide -value {1 0}
2118     label .bleft.mid.labeldiffcontext -text "      [mc "Lines of context"]: "
2119     pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2120     spinbox .bleft.mid.diffcontext -width 5 -font textfont \
2121         -from 1 -increment 1 -to 10000000 \
2122         -validate all -validatecommand "diffcontextvalidate %P" \
2123         -textvariable diffcontextstring
2124     .bleft.mid.diffcontext set $diffcontext
2125     trace add variable diffcontextstring write diffcontextchange
2126     lappend entries .bleft.mid.diffcontext
2127     pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2128     checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2129         -command changeignorespace -variable ignorespace
2130     pack .bleft.mid.ignspace -side left -padx 5
2131     set ctext .bleft.bottom.ctext
2132     text $ctext -background $bgcolor -foreground $fgcolor \
2133         -state disabled -font textfont \
2134         -yscrollcommand scrolltext -wrap none \
2135         -xscrollcommand ".bleft.bottom.sbhorizontal set"
2136     if {$have_tk85} {
2137         $ctext conf -tabstyle wordprocessor
2138     }
2139     scrollbar .bleft.bottom.sb -command "$ctext yview"
2140     scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
2141         -width 10
2142     pack .bleft.top -side top -fill x
2143     pack .bleft.mid -side top -fill x
2144     grid $ctext .bleft.bottom.sb -sticky nsew
2145     grid .bleft.bottom.sbhorizontal -sticky ew
2146     grid columnconfigure .bleft.bottom 0 -weight 1
2147     grid rowconfigure .bleft.bottom 0 -weight 1
2148     grid rowconfigure .bleft.bottom 1 -weight 0
2149     pack .bleft.bottom -side top -fill both -expand 1
2150     lappend bglist $ctext
2151     lappend fglist $ctext
2153     $ctext tag conf comment -wrap $wrapcomment
2154     $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
2155     $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2156     $ctext tag conf d0 -fore [lindex $diffcolors 0]
2157     $ctext tag conf dresult -fore [lindex $diffcolors 1]
2158     $ctext tag conf m0 -fore red
2159     $ctext tag conf m1 -fore blue
2160     $ctext tag conf m2 -fore green
2161     $ctext tag conf m3 -fore purple
2162     $ctext tag conf m4 -fore brown
2163     $ctext tag conf m5 -fore "#009090"
2164     $ctext tag conf m6 -fore magenta
2165     $ctext tag conf m7 -fore "#808000"
2166     $ctext tag conf m8 -fore "#009000"
2167     $ctext tag conf m9 -fore "#ff0080"
2168     $ctext tag conf m10 -fore cyan
2169     $ctext tag conf m11 -fore "#b07070"
2170     $ctext tag conf m12 -fore "#70b0f0"
2171     $ctext tag conf m13 -fore "#70f0b0"
2172     $ctext tag conf m14 -fore "#f0b070"
2173     $ctext tag conf m15 -fore "#ff70b0"
2174     $ctext tag conf mmax -fore darkgrey
2175     set mergemax 16
2176     $ctext tag conf mresult -font textfontbold
2177     $ctext tag conf msep -font textfontbold
2178     $ctext tag conf found -back yellow
2180     .pwbottom add .bleft
2181     .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2183     # lower right
2184     frame .bright
2185     frame .bright.mode
2186     radiobutton .bright.mode.patch -text [mc "Patch"] \
2187         -command reselectline -variable cmitmode -value "patch"
2188     radiobutton .bright.mode.tree -text [mc "Tree"] \
2189         -command reselectline -variable cmitmode -value "tree"
2190     grid .bright.mode.patch .bright.mode.tree -sticky ew
2191     pack .bright.mode -side top -fill x
2192     set cflist .bright.cfiles
2193     set indent [font measure mainfont "nn"]
2194     text $cflist \
2195         -selectbackground $selectbgcolor \
2196         -background $bgcolor -foreground $fgcolor \
2197         -font mainfont \
2198         -tabs [list $indent [expr {2 * $indent}]] \
2199         -yscrollcommand ".bright.sb set" \
2200         -cursor [. cget -cursor] \
2201         -spacing1 1 -spacing3 1
2202     lappend bglist $cflist
2203     lappend fglist $cflist
2204     scrollbar .bright.sb -command "$cflist yview"
2205     pack .bright.sb -side right -fill y
2206     pack $cflist -side left -fill both -expand 1
2207     $cflist tag configure highlight \
2208         -background [$cflist cget -selectbackground]
2209     $cflist tag configure bold -font mainfontbold
2211     .pwbottom add .bright
2212     .ctop add .pwbottom
2214     # restore window width & height if known
2215     if {[info exists geometry(main)]} {
2216         if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2217             if {$w > [winfo screenwidth .]} {
2218                 set w [winfo screenwidth .]
2219             }
2220             if {$h > [winfo screenheight .]} {
2221                 set h [winfo screenheight .]
2222             }
2223             wm geometry . "${w}x$h"
2224         }
2225     }
2227     if {[tk windowingsystem] eq {aqua}} {
2228         set M1B M1
2229     } else {
2230         set M1B Control
2231     }
2233     bind .pwbottom <Configure> {resizecdetpanes %W %w}
2234     pack .ctop -fill both -expand 1
2235     bindall <1> {selcanvline %W %x %y}
2236     #bindall <B1-Motion> {selcanvline %W %x %y}
2237     if {[tk windowingsystem] == "win32"} {
2238         bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2239         bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2240     } else {
2241         bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2242         bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2243         if {[tk windowingsystem] eq "aqua"} {
2244             bindall <MouseWheel> {
2245                 set delta [expr {- (%D)}]
2246                 allcanvs yview scroll $delta units
2247             }
2248         }
2249     }
2250     bindall <2> "canvscan mark %W %x %y"
2251     bindall <B2-Motion> "canvscan dragto %W %x %y"
2252     bindkey <Home> selfirstline
2253     bindkey <End> sellastline
2254     bind . <Key-Up> "selnextline -1"
2255     bind . <Key-Down> "selnextline 1"
2256     bind . <Shift-Key-Up> "dofind -1 0"
2257     bind . <Shift-Key-Down> "dofind 1 0"
2258     bindkey <Key-Right> "goforw"
2259     bindkey <Key-Left> "goback"
2260     bind . <Key-Prior> "selnextpage -1"
2261     bind . <Key-Next> "selnextpage 1"
2262     bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2263     bind . <$M1B-End> "allcanvs yview moveto 1.0"
2264     bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2265     bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2266     bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2267     bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2268     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2269     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2270     bindkey <Key-space> "$ctext yview scroll 1 pages"
2271     bindkey p "selnextline -1"
2272     bindkey n "selnextline 1"
2273     bindkey z "goback"
2274     bindkey x "goforw"
2275     bindkey i "selnextline -1"
2276     bindkey k "selnextline 1"
2277     bindkey j "goback"
2278     bindkey l "goforw"
2279     bindkey b prevfile
2280     bindkey d "$ctext yview scroll 18 units"
2281     bindkey u "$ctext yview scroll -18 units"
2282     bindkey / {focus $fstring}
2283     bindkey <Key-Return> {dofind 1 1}
2284     bindkey ? {dofind -1 1}
2285     bindkey f nextfile
2286     bind . <F5> updatecommits
2287     bind . <$M1B-F5> reloadcommits
2288     bind . <F2> showrefs
2289     bind . <Shift-F4> {newview 0}
2290     catch { bind . <Shift-Key-XF86_Switch_VT_4> {newview 0} }
2291     bind . <F4> edit_or_newview
2292     bind . <$M1B-q> doquit
2293     bind . <$M1B-f> {dofind 1 1}
2294     bind . <$M1B-g> {dofind 1 0}
2295     bind . <$M1B-r> dosearchback
2296     bind . <$M1B-s> dosearch
2297     bind . <$M1B-equal> {incrfont 1}
2298     bind . <$M1B-plus> {incrfont 1}
2299     bind . <$M1B-KP_Add> {incrfont 1}
2300     bind . <$M1B-minus> {incrfont -1}
2301     bind . <$M1B-KP_Subtract> {incrfont -1}
2302     wm protocol . WM_DELETE_WINDOW doquit
2303     bind . <Destroy> {stop_backends}
2304     bind . <Button-1> "click %W"
2305     bind $fstring <Key-Return> {dofind 1 1}
2306     bind $sha1entry <Key-Return> {gotocommit; break}
2307     bind $sha1entry <<PasteSelection>> clearsha1
2308     bind $cflist <1> {sel_flist %W %x %y; break}
2309     bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2310     bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2311     global ctxbut
2312     bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2313     bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2315     set maincursor [. cget -cursor]
2316     set textcursor [$ctext cget -cursor]
2317     set curtextcursor $textcursor
2319     set rowctxmenu .rowctxmenu
2320     makemenu $rowctxmenu {
2321         {mc "Diff this -> selected" command {diffvssel 0}}
2322         {mc "Diff selected -> this" command {diffvssel 1}}
2323         {mc "Make patch" command mkpatch}
2324         {mc "Create tag" command mktag}
2325         {mc "Write commit to file" command writecommit}
2326         {mc "Create new branch" command mkbranch}
2327         {mc "Cherry-pick this commit" command cherrypick}
2328         {mc "Reset HEAD branch to here" command resethead}
2329     }
2330     $rowctxmenu configure -tearoff 0
2332     set fakerowmenu .fakerowmenu
2333     makemenu $fakerowmenu {
2334         {mc "Diff this -> selected" command {diffvssel 0}}
2335         {mc "Diff selected -> this" command {diffvssel 1}}
2336         {mc "Make patch" command mkpatch}
2337     }
2338     $fakerowmenu configure -tearoff 0
2340     set headctxmenu .headctxmenu
2341     makemenu $headctxmenu {
2342         {mc "Check out this branch" command cobranch}
2343         {mc "Remove this branch" command rmbranch}
2344     }
2345     $headctxmenu configure -tearoff 0
2347     global flist_menu
2348     set flist_menu .flistctxmenu
2349     makemenu $flist_menu {
2350         {mc "Highlight this too" command {flist_hl 0}}
2351         {mc "Highlight this only" command {flist_hl 1}}
2352         {mc "External diff" command {external_diff}}
2353         {mc "Blame parent commit" command {external_blame 1}}
2354     }
2355     $flist_menu configure -tearoff 0
2357     global diff_menu
2358     set diff_menu .diffctxmenu
2359     makemenu $diff_menu {
2360         {mc "Show origin of this line" command show_line_source}
2361         {mc "Run git gui blame on this line" command {external_blame_diff}}
2362     }
2363     $diff_menu configure -tearoff 0
2366 # Windows sends all mouse wheel events to the current focused window, not
2367 # the one where the mouse hovers, so bind those events here and redirect
2368 # to the correct window
2369 proc windows_mousewheel_redirector {W X Y D} {
2370     global canv canv2 canv3
2371     set w [winfo containing -displayof $W $X $Y]
2372     if {$w ne ""} {
2373         set u [expr {$D < 0 ? 5 : -5}]
2374         if {$w == $canv || $w == $canv2 || $w == $canv3} {
2375             allcanvs yview scroll $u units
2376         } else {
2377             catch {
2378                 $w yview scroll $u units
2379             }
2380         }
2381     }
2384 # Update row number label when selectedline changes
2385 proc selectedline_change {n1 n2 op} {
2386     global selectedline rownumsel
2388     if {$selectedline eq {}} {
2389         set rownumsel {}
2390     } else {
2391         set rownumsel [expr {$selectedline + 1}]
2392     }
2395 # mouse-2 makes all windows scan vertically, but only the one
2396 # the cursor is in scans horizontally
2397 proc canvscan {op w x y} {
2398     global canv canv2 canv3
2399     foreach c [list $canv $canv2 $canv3] {
2400         if {$c == $w} {
2401             $c scan $op $x $y
2402         } else {
2403             $c scan $op 0 $y
2404         }
2405     }
2408 proc scrollcanv {cscroll f0 f1} {
2409     $cscroll set $f0 $f1
2410     drawvisible
2411     flushhighlights
2414 # when we make a key binding for the toplevel, make sure
2415 # it doesn't get triggered when that key is pressed in the
2416 # find string entry widget.
2417 proc bindkey {ev script} {
2418     global entries
2419     bind . $ev $script
2420     set escript [bind Entry $ev]
2421     if {$escript == {}} {
2422         set escript [bind Entry <Key>]
2423     }
2424     foreach e $entries {
2425         bind $e $ev "$escript; break"
2426     }
2429 # set the focus back to the toplevel for any click outside
2430 # the entry widgets
2431 proc click {w} {
2432     global ctext entries
2433     foreach e [concat $entries $ctext] {
2434         if {$w == $e} return
2435     }
2436     focus .
2439 # Adjust the progress bar for a change in requested extent or canvas size
2440 proc adjustprogress {} {
2441     global progresscanv progressitem progresscoords
2442     global fprogitem fprogcoord lastprogupdate progupdatepending
2443     global rprogitem rprogcoord
2445     set w [expr {[winfo width $progresscanv] - 4}]
2446     set x0 [expr {$w * [lindex $progresscoords 0]}]
2447     set x1 [expr {$w * [lindex $progresscoords 1]}]
2448     set h [winfo height $progresscanv]
2449     $progresscanv coords $progressitem $x0 0 $x1 $h
2450     $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2451     $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2452     set now [clock clicks -milliseconds]
2453     if {$now >= $lastprogupdate + 100} {
2454         set progupdatepending 0
2455         update
2456     } elseif {!$progupdatepending} {
2457         set progupdatepending 1
2458         after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2459     }
2462 proc doprogupdate {} {
2463     global lastprogupdate progupdatepending
2465     if {$progupdatepending} {
2466         set progupdatepending 0
2467         set lastprogupdate [clock clicks -milliseconds]
2468         update
2469     }
2472 proc savestuff {w} {
2473     global canv canv2 canv3 mainfont textfont uifont tabstop
2474     global stuffsaved findmergefiles maxgraphpct
2475     global maxwidth showneartags showlocalchanges
2476     global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2477     global cmitmode wrapcomment datetimeformat limitdiffs
2478     global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2479     global autoselect extdifftool perfile_attrs markbgcolor
2481     if {$stuffsaved} return
2482     if {![winfo viewable .]} return
2483     catch {
2484         set f [open "~/.gitk-new" w]
2485         puts $f [list set mainfont $mainfont]
2486         puts $f [list set textfont $textfont]
2487         puts $f [list set uifont $uifont]
2488         puts $f [list set tabstop $tabstop]
2489         puts $f [list set findmergefiles $findmergefiles]
2490         puts $f [list set maxgraphpct $maxgraphpct]
2491         puts $f [list set maxwidth $maxwidth]
2492         puts $f [list set cmitmode $cmitmode]
2493         puts $f [list set wrapcomment $wrapcomment]
2494         puts $f [list set autoselect $autoselect]
2495         puts $f [list set showneartags $showneartags]
2496         puts $f [list set showlocalchanges $showlocalchanges]
2497         puts $f [list set datetimeformat $datetimeformat]
2498         puts $f [list set limitdiffs $limitdiffs]
2499         puts $f [list set bgcolor $bgcolor]
2500         puts $f [list set fgcolor $fgcolor]
2501         puts $f [list set colors $colors]
2502         puts $f [list set diffcolors $diffcolors]
2503         puts $f [list set markbgcolor $markbgcolor]
2504         puts $f [list set diffcontext $diffcontext]
2505         puts $f [list set selectbgcolor $selectbgcolor]
2506         puts $f [list set extdifftool $extdifftool]
2507         puts $f [list set perfile_attrs $perfile_attrs]
2509         puts $f "set geometry(main) [wm geometry .]"
2510         puts $f "set geometry(topwidth) [winfo width .tf]"
2511         puts $f "set geometry(topheight) [winfo height .tf]"
2512         puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2513         puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2514         puts $f "set geometry(botwidth) [winfo width .bleft]"
2515         puts $f "set geometry(botheight) [winfo height .bleft]"
2517         puts -nonewline $f "set permviews {"
2518         for {set v 0} {$v < $nextviewnum} {incr v} {
2519             if {$viewperm($v)} {
2520                 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2521             }
2522         }
2523         puts $f "}"
2524         close $f
2525         file rename -force "~/.gitk-new" "~/.gitk"
2526     }
2527     set stuffsaved 1
2530 proc resizeclistpanes {win w} {
2531     global oldwidth
2532     if {[info exists oldwidth($win)]} {
2533         set s0 [$win sash coord 0]
2534         set s1 [$win sash coord 1]
2535         if {$w < 60} {
2536             set sash0 [expr {int($w/2 - 2)}]
2537             set sash1 [expr {int($w*5/6 - 2)}]
2538         } else {
2539             set factor [expr {1.0 * $w / $oldwidth($win)}]
2540             set sash0 [expr {int($factor * [lindex $s0 0])}]
2541             set sash1 [expr {int($factor * [lindex $s1 0])}]
2542             if {$sash0 < 30} {
2543                 set sash0 30
2544             }
2545             if {$sash1 < $sash0 + 20} {
2546                 set sash1 [expr {$sash0 + 20}]
2547             }
2548             if {$sash1 > $w - 10} {
2549                 set sash1 [expr {$w - 10}]
2550                 if {$sash0 > $sash1 - 20} {
2551                     set sash0 [expr {$sash1 - 20}]
2552                 }
2553             }
2554         }
2555         $win sash place 0 $sash0 [lindex $s0 1]
2556         $win sash place 1 $sash1 [lindex $s1 1]
2557     }
2558     set oldwidth($win) $w
2561 proc resizecdetpanes {win w} {
2562     global oldwidth
2563     if {[info exists oldwidth($win)]} {
2564         set s0 [$win sash coord 0]
2565         if {$w < 60} {
2566             set sash0 [expr {int($w*3/4 - 2)}]
2567         } else {
2568             set factor [expr {1.0 * $w / $oldwidth($win)}]
2569             set sash0 [expr {int($factor * [lindex $s0 0])}]
2570             if {$sash0 < 45} {
2571                 set sash0 45
2572             }
2573             if {$sash0 > $w - 15} {
2574                 set sash0 [expr {$w - 15}]
2575             }
2576         }
2577         $win sash place 0 $sash0 [lindex $s0 1]
2578     }
2579     set oldwidth($win) $w
2582 proc allcanvs args {
2583     global canv canv2 canv3
2584     eval $canv $args
2585     eval $canv2 $args
2586     eval $canv3 $args
2589 proc bindall {event action} {
2590     global canv canv2 canv3
2591     bind $canv $event $action
2592     bind $canv2 $event $action
2593     bind $canv3 $event $action
2596 proc about {} {
2597     global uifont
2598     set w .about
2599     if {[winfo exists $w]} {
2600         raise $w
2601         return
2602     }
2603     toplevel $w
2604     wm title $w [mc "About gitk"]
2605     make_transient $w .
2606     message $w.m -text [mc "
2607 Gitk - a commit viewer for git
2609 Copyright © 2005-2008 Paul Mackerras
2611 Use and redistribute under the terms of the GNU General Public License"] \
2612             -justify center -aspect 400 -border 2 -bg white -relief groove
2613     pack $w.m -side top -fill x -padx 2 -pady 2
2614     button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2615     pack $w.ok -side bottom
2616     bind $w <Visibility> "focus $w.ok"
2617     bind $w <Key-Escape> "destroy $w"
2618     bind $w <Key-Return> "destroy $w"
2621 proc keys {} {
2622     set w .keys
2623     if {[winfo exists $w]} {
2624         raise $w
2625         return
2626     }
2627     if {[tk windowingsystem] eq {aqua}} {
2628         set M1T Cmd
2629     } else {
2630         set M1T Ctrl
2631     }
2632     toplevel $w
2633     wm title $w [mc "Gitk key bindings"]
2634     make_transient $w .
2635     message $w.m -text "
2636 [mc "Gitk key bindings:"]
2638 [mc "<%s-Q>             Quit" $M1T]
2639 [mc "<Home>             Move to first commit"]
2640 [mc "<End>              Move to last commit"]
2641 [mc "<Up>, p, i Move up one commit"]
2642 [mc "<Down>, n, k       Move down one commit"]
2643 [mc "<Left>, z, j       Go back in history list"]
2644 [mc "<Right>, x, l      Go forward in history list"]
2645 [mc "<PageUp>   Move up one page in commit list"]
2646 [mc "<PageDown> Move down one page in commit list"]
2647 [mc "<%s-Home>  Scroll to top of commit list" $M1T]
2648 [mc "<%s-End>   Scroll to bottom of commit list" $M1T]
2649 [mc "<%s-Up>    Scroll commit list up one line" $M1T]
2650 [mc "<%s-Down>  Scroll commit list down one line" $M1T]
2651 [mc "<%s-PageUp>        Scroll commit list up one page" $M1T]
2652 [mc "<%s-PageDown>      Scroll commit list down one page" $M1T]
2653 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2654 [mc "<Shift-Down>       Find forwards (downwards, earlier commits)"]
2655 [mc "<Delete>, b        Scroll diff view up one page"]
2656 [mc "<Backspace>        Scroll diff view up one page"]
2657 [mc "<Space>            Scroll diff view down one page"]
2658 [mc "u          Scroll diff view up 18 lines"]
2659 [mc "d          Scroll diff view down 18 lines"]
2660 [mc "<%s-F>             Find" $M1T]
2661 [mc "<%s-G>             Move to next find hit" $M1T]
2662 [mc "<Return>   Move to next find hit"]
2663 [mc "/          Focus the search box"]
2664 [mc "?          Move to previous find hit"]
2665 [mc "f          Scroll diff view to next file"]
2666 [mc "<%s-S>             Search for next hit in diff view" $M1T]
2667 [mc "<%s-R>             Search for previous hit in diff view" $M1T]
2668 [mc "<%s-KP+>   Increase font size" $M1T]
2669 [mc "<%s-plus>  Increase font size" $M1T]
2670 [mc "<%s-KP->   Decrease font size" $M1T]
2671 [mc "<%s-minus> Decrease font size" $M1T]
2672 [mc "<F5>               Update"]
2673 " \
2674             -justify left -bg white -border 2 -relief groove
2675     pack $w.m -side top -fill both -padx 2 -pady 2
2676     button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2677     bind $w <Key-Escape> [list destroy $w]
2678     pack $w.ok -side bottom
2679     bind $w <Visibility> "focus $w.ok"
2680     bind $w <Key-Escape> "destroy $w"
2681     bind $w <Key-Return> "destroy $w"
2684 # Procedures for manipulating the file list window at the
2685 # bottom right of the overall window.
2687 proc treeview {w l openlevs} {
2688     global treecontents treediropen treeheight treeparent treeindex
2690     set ix 0
2691     set treeindex() 0
2692     set lev 0
2693     set prefix {}
2694     set prefixend -1
2695     set prefendstack {}
2696     set htstack {}
2697     set ht 0
2698     set treecontents() {}
2699     $w conf -state normal
2700     foreach f $l {
2701         while {[string range $f 0 $prefixend] ne $prefix} {
2702             if {$lev <= $openlevs} {
2703                 $w mark set e:$treeindex($prefix) "end -1c"
2704                 $w mark gravity e:$treeindex($prefix) left
2705             }
2706             set treeheight($prefix) $ht
2707             incr ht [lindex $htstack end]
2708             set htstack [lreplace $htstack end end]
2709             set prefixend [lindex $prefendstack end]
2710             set prefendstack [lreplace $prefendstack end end]
2711             set prefix [string range $prefix 0 $prefixend]
2712             incr lev -1
2713         }
2714         set tail [string range $f [expr {$prefixend+1}] end]
2715         while {[set slash [string first "/" $tail]] >= 0} {
2716             lappend htstack $ht
2717             set ht 0
2718             lappend prefendstack $prefixend
2719             incr prefixend [expr {$slash + 1}]
2720             set d [string range $tail 0 $slash]
2721             lappend treecontents($prefix) $d
2722             set oldprefix $prefix
2723             append prefix $d
2724             set treecontents($prefix) {}
2725             set treeindex($prefix) [incr ix]
2726             set treeparent($prefix) $oldprefix
2727             set tail [string range $tail [expr {$slash+1}] end]
2728             if {$lev <= $openlevs} {
2729                 set ht 1
2730                 set treediropen($prefix) [expr {$lev < $openlevs}]
2731                 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2732                 $w mark set d:$ix "end -1c"
2733                 $w mark gravity d:$ix left
2734                 set str "\n"
2735                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2736                 $w insert end $str
2737                 $w image create end -align center -image $bm -padx 1 \
2738                     -name a:$ix
2739                 $w insert end $d [highlight_tag $prefix]
2740                 $w mark set s:$ix "end -1c"
2741                 $w mark gravity s:$ix left
2742             }
2743             incr lev
2744         }
2745         if {$tail ne {}} {
2746             if {$lev <= $openlevs} {
2747                 incr ht
2748                 set str "\n"
2749                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2750                 $w insert end $str
2751                 $w insert end $tail [highlight_tag $f]
2752             }
2753             lappend treecontents($prefix) $tail
2754         }
2755     }
2756     while {$htstack ne {}} {
2757         set treeheight($prefix) $ht
2758         incr ht [lindex $htstack end]
2759         set htstack [lreplace $htstack end end]
2760         set prefixend [lindex $prefendstack end]
2761         set prefendstack [lreplace $prefendstack end end]
2762         set prefix [string range $prefix 0 $prefixend]
2763     }
2764     $w conf -state disabled
2767 proc linetoelt {l} {
2768     global treeheight treecontents
2770     set y 2
2771     set prefix {}
2772     while {1} {
2773         foreach e $treecontents($prefix) {
2774             if {$y == $l} {
2775                 return "$prefix$e"
2776             }
2777             set n 1
2778             if {[string index $e end] eq "/"} {
2779                 set n $treeheight($prefix$e)
2780                 if {$y + $n > $l} {
2781                     append prefix $e
2782                     incr y
2783                     break
2784                 }
2785             }
2786             incr y $n
2787         }
2788     }
2791 proc highlight_tree {y prefix} {
2792     global treeheight treecontents cflist
2794     foreach e $treecontents($prefix) {
2795         set path $prefix$e
2796         if {[highlight_tag $path] ne {}} {
2797             $cflist tag add bold $y.0 "$y.0 lineend"
2798         }
2799         incr y
2800         if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2801             set y [highlight_tree $y $path]
2802         }
2803     }
2804     return $y
2807 proc treeclosedir {w dir} {
2808     global treediropen treeheight treeparent treeindex
2810     set ix $treeindex($dir)
2811     $w conf -state normal
2812     $w delete s:$ix e:$ix
2813     set treediropen($dir) 0
2814     $w image configure a:$ix -image tri-rt
2815     $w conf -state disabled
2816     set n [expr {1 - $treeheight($dir)}]
2817     while {$dir ne {}} {
2818         incr treeheight($dir) $n
2819         set dir $treeparent($dir)
2820     }
2823 proc treeopendir {w dir} {
2824     global treediropen treeheight treeparent treecontents treeindex
2826     set ix $treeindex($dir)
2827     $w conf -state normal
2828     $w image configure a:$ix -image tri-dn
2829     $w mark set e:$ix s:$ix
2830     $w mark gravity e:$ix right
2831     set lev 0
2832     set str "\n"
2833     set n [llength $treecontents($dir)]
2834     for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2835         incr lev
2836         append str "\t"
2837         incr treeheight($x) $n
2838     }
2839     foreach e $treecontents($dir) {
2840         set de $dir$e
2841         if {[string index $e end] eq "/"} {
2842             set iy $treeindex($de)
2843             $w mark set d:$iy e:$ix
2844             $w mark gravity d:$iy left
2845             $w insert e:$ix $str
2846             set treediropen($de) 0
2847             $w image create e:$ix -align center -image tri-rt -padx 1 \
2848                 -name a:$iy
2849             $w insert e:$ix $e [highlight_tag $de]
2850             $w mark set s:$iy e:$ix
2851             $w mark gravity s:$iy left
2852             set treeheight($de) 1
2853         } else {
2854             $w insert e:$ix $str
2855             $w insert e:$ix $e [highlight_tag $de]
2856         }
2857     }
2858     $w mark gravity e:$ix right
2859     $w conf -state disabled
2860     set treediropen($dir) 1
2861     set top [lindex [split [$w index @0,0] .] 0]
2862     set ht [$w cget -height]
2863     set l [lindex [split [$w index s:$ix] .] 0]
2864     if {$l < $top} {
2865         $w yview $l.0
2866     } elseif {$l + $n + 1 > $top + $ht} {
2867         set top [expr {$l + $n + 2 - $ht}]
2868         if {$l < $top} {
2869             set top $l
2870         }
2871         $w yview $top.0
2872     }
2875 proc treeclick {w x y} {
2876     global treediropen cmitmode ctext cflist cflist_top
2878     if {$cmitmode ne "tree"} return
2879     if {![info exists cflist_top]} return
2880     set l [lindex [split [$w index "@$x,$y"] "."] 0]
2881     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2882     $cflist tag add highlight $l.0 "$l.0 lineend"
2883     set cflist_top $l
2884     if {$l == 1} {
2885         $ctext yview 1.0
2886         return
2887     }
2888     set e [linetoelt $l]
2889     if {[string index $e end] ne "/"} {
2890         showfile $e
2891     } elseif {$treediropen($e)} {
2892         treeclosedir $w $e
2893     } else {
2894         treeopendir $w $e
2895     }
2898 proc setfilelist {id} {
2899     global treefilelist cflist jump_to_here
2901     treeview $cflist $treefilelist($id) 0
2902     if {$jump_to_here ne {}} {
2903         set f [lindex $jump_to_here 0]
2904         if {[lsearch -exact $treefilelist($id) $f] >= 0} {
2905             showfile $f
2906         }
2907     }
2910 image create bitmap tri-rt -background black -foreground blue -data {
2911     #define tri-rt_width 13
2912     #define tri-rt_height 13
2913     static unsigned char tri-rt_bits[] = {
2914        0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2915        0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2916        0x00, 0x00};
2917 } -maskdata {
2918     #define tri-rt-mask_width 13
2919     #define tri-rt-mask_height 13
2920     static unsigned char tri-rt-mask_bits[] = {
2921        0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2922        0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2923        0x08, 0x00};
2925 image create bitmap tri-dn -background black -foreground blue -data {
2926     #define tri-dn_width 13
2927     #define tri-dn_height 13
2928     static unsigned char tri-dn_bits[] = {
2929        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2930        0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2931        0x00, 0x00};
2932 } -maskdata {
2933     #define tri-dn-mask_width 13
2934     #define tri-dn-mask_height 13
2935     static unsigned char tri-dn-mask_bits[] = {
2936        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2937        0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2938        0x00, 0x00};
2941 image create bitmap reficon-T -background black -foreground yellow -data {
2942     #define tagicon_width 13
2943     #define tagicon_height 9
2944     static unsigned char tagicon_bits[] = {
2945        0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2946        0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2947 } -maskdata {
2948     #define tagicon-mask_width 13
2949     #define tagicon-mask_height 9
2950     static unsigned char tagicon-mask_bits[] = {
2951        0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2952        0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2954 set rectdata {
2955     #define headicon_width 13
2956     #define headicon_height 9
2957     static unsigned char headicon_bits[] = {
2958        0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2959        0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2961 set rectmask {
2962     #define headicon-mask_width 13
2963     #define headicon-mask_height 9
2964     static unsigned char headicon-mask_bits[] = {
2965        0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2966        0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2968 image create bitmap reficon-H -background black -foreground green \
2969     -data $rectdata -maskdata $rectmask
2970 image create bitmap reficon-o -background black -foreground "#ddddff" \
2971     -data $rectdata -maskdata $rectmask
2973 proc init_flist {first} {
2974     global cflist cflist_top difffilestart
2976     $cflist conf -state normal
2977     $cflist delete 0.0 end
2978     if {$first ne {}} {
2979         $cflist insert end $first
2980         set cflist_top 1
2981         $cflist tag add highlight 1.0 "1.0 lineend"
2982     } else {
2983         catch {unset cflist_top}
2984     }
2985     $cflist conf -state disabled
2986     set difffilestart {}
2989 proc highlight_tag {f} {
2990     global highlight_paths
2992     foreach p $highlight_paths {
2993         if {[string match $p $f]} {
2994             return "bold"
2995         }
2996     }
2997     return {}
3000 proc highlight_filelist {} {
3001     global cmitmode cflist
3003     $cflist conf -state normal
3004     if {$cmitmode ne "tree"} {
3005         set end [lindex [split [$cflist index end] .] 0]
3006         for {set l 2} {$l < $end} {incr l} {
3007             set line [$cflist get $l.0 "$l.0 lineend"]
3008             if {[highlight_tag $line] ne {}} {
3009                 $cflist tag add bold $l.0 "$l.0 lineend"
3010             }
3011         }
3012     } else {
3013         highlight_tree 2 {}
3014     }
3015     $cflist conf -state disabled
3018 proc unhighlight_filelist {} {
3019     global cflist
3021     $cflist conf -state normal
3022     $cflist tag remove bold 1.0 end
3023     $cflist conf -state disabled
3026 proc add_flist {fl} {
3027     global cflist
3029     $cflist conf -state normal
3030     foreach f $fl {
3031         $cflist insert end "\n"
3032         $cflist insert end $f [highlight_tag $f]
3033     }
3034     $cflist conf -state disabled
3037 proc sel_flist {w x y} {
3038     global ctext difffilestart cflist cflist_top cmitmode
3040     if {$cmitmode eq "tree"} return
3041     if {![info exists cflist_top]} return
3042     set l [lindex [split [$w index "@$x,$y"] "."] 0]
3043     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3044     $cflist tag add highlight $l.0 "$l.0 lineend"
3045     set cflist_top $l
3046     if {$l == 1} {
3047         $ctext yview 1.0
3048     } else {
3049         catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3050     }
3053 proc pop_flist_menu {w X Y x y} {
3054     global ctext cflist cmitmode flist_menu flist_menu_file
3055     global treediffs diffids
3057     stopfinding
3058     set l [lindex [split [$w index "@$x,$y"] "."] 0]
3059     if {$l <= 1} return
3060     if {$cmitmode eq "tree"} {
3061         set e [linetoelt $l]
3062         if {[string index $e end] eq "/"} return
3063     } else {
3064         set e [lindex $treediffs($diffids) [expr {$l-2}]]
3065     }
3066     set flist_menu_file $e
3067     set xdiffstate "normal"
3068     if {$cmitmode eq "tree"} {
3069         set xdiffstate "disabled"
3070     }
3071     # Disable "External diff" item in tree mode
3072     $flist_menu entryconf 2 -state $xdiffstate
3073     tk_popup $flist_menu $X $Y
3076 proc find_ctext_fileinfo {line} {
3077     global ctext_file_names ctext_file_lines
3079     set ok [bsearch $ctext_file_lines $line]
3080     set tline [lindex $ctext_file_lines $ok]
3082     if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3083         return {}
3084     } else {
3085         return [list [lindex $ctext_file_names $ok] $tline]
3086     }
3089 proc pop_diff_menu {w X Y x y} {
3090     global ctext diff_menu flist_menu_file
3091     global diff_menu_txtpos diff_menu_line
3092     global diff_menu_filebase
3094     set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3095     set diff_menu_line [lindex $diff_menu_txtpos 0]
3096     # don't pop up the menu on hunk-separator or file-separator lines
3097     if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3098         return
3099     }
3100     stopfinding
3101     set f [find_ctext_fileinfo $diff_menu_line]
3102     if {$f eq {}} return
3103     set flist_menu_file [lindex $f 0]
3104     set diff_menu_filebase [lindex $f 1]
3105     tk_popup $diff_menu $X $Y
3108 proc flist_hl {only} {
3109     global flist_menu_file findstring gdttype
3111     set x [shellquote $flist_menu_file]
3112     if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3113         set findstring $x
3114     } else {
3115         append findstring " " $x
3116     }
3117     set gdttype [mc "touching paths:"]
3120 proc save_file_from_commit {filename output what} {
3121     global nullfile
3123     if {[catch {exec git show $filename -- > $output} err]} {
3124         if {[string match "fatal: bad revision *" $err]} {
3125             return $nullfile
3126         }
3127         error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3128         return {}
3129     }
3130     return $output
3133 proc external_diff_get_one_file {diffid filename diffdir} {
3134     global nullid nullid2 nullfile
3135     global gitdir
3137     if {$diffid == $nullid} {
3138         set difffile [file join [file dirname $gitdir] $filename]
3139         if {[file exists $difffile]} {
3140             return $difffile
3141         }
3142         return $nullfile
3143     }
3144     if {$diffid == $nullid2} {
3145         set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3146         return [save_file_from_commit :$filename $difffile index]
3147     }
3148     set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3149     return [save_file_from_commit $diffid:$filename $difffile \
3150                "revision $diffid"]
3153 proc external_diff {} {
3154     global gitktmpdir nullid nullid2
3155     global flist_menu_file
3156     global diffids
3157     global diffnum
3158     global gitdir extdifftool
3160     if {[llength $diffids] == 1} {
3161         # no reference commit given
3162         set diffidto [lindex $diffids 0]
3163         if {$diffidto eq $nullid} {
3164             # diffing working copy with index
3165             set diffidfrom $nullid2
3166         } elseif {$diffidto eq $nullid2} {
3167             # diffing index with HEAD
3168             set diffidfrom "HEAD"
3169         } else {
3170             # use first parent commit
3171             global parentlist selectedline
3172             set diffidfrom [lindex $parentlist $selectedline 0]
3173         }
3174     } else {
3175         set diffidfrom [lindex $diffids 0]
3176         set diffidto [lindex $diffids 1]
3177     }
3179     # make sure that several diffs wont collide
3180     if {![info exists gitktmpdir]} {
3181         set gitktmpdir [file join [file dirname $gitdir] \
3182                             [format ".gitk-tmp.%s" [pid]]]
3183         if {[catch {file mkdir $gitktmpdir} err]} {
3184             error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3185             unset gitktmpdir
3186             return
3187         }
3188         set diffnum 0
3189     }
3190     incr diffnum
3191     set diffdir [file join $gitktmpdir $diffnum]
3192     if {[catch {file mkdir $diffdir} err]} {
3193         error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3194         return
3195     }
3197     # gather files to diff
3198     set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3199     set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3201     if {$difffromfile ne {} && $difftofile ne {}} {
3202         set cmd [concat | [shellsplit $extdifftool] \
3203                      [list $difffromfile $difftofile]]
3204         if {[catch {set fl [open $cmd r]} err]} {
3205             file delete -force $diffdir
3206             error_popup "$extdifftool: [mc "command failed:"] $err"
3207         } else {
3208             fconfigure $fl -blocking 0
3209             filerun $fl [list delete_at_eof $fl $diffdir]
3210         }
3211     }
3214 proc find_hunk_blamespec {base line} {
3215     global ctext
3217     # Find and parse the hunk header
3218     set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3219     if {$s_lix eq {}} return
3221     set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3222     if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3223             s_line old_specs osz osz1 new_line nsz]} {
3224         return
3225     }
3227     # base lines for the parents
3228     set base_lines [list $new_line]
3229     foreach old_spec [lrange [split $old_specs " "] 1 end] {
3230         if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3231                 old_spec old_line osz]} {
3232             return
3233         }
3234         lappend base_lines $old_line
3235     }
3237     # Now scan the lines to determine offset within the hunk
3238     set max_parent [expr {[llength $base_lines]-2}]
3239     set dline 0
3240     set s_lno [lindex [split $s_lix "."] 0]
3242     # Determine if the line is removed
3243     set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3244     if {[string match {[-+ ]*} $chunk]} {
3245         set removed_idx [string first "-" $chunk]
3246         # Choose a parent index
3247         if {$removed_idx >= 0} {
3248             set parent $removed_idx
3249         } else {
3250             set unchanged_idx [string first " " $chunk]
3251             if {$unchanged_idx >= 0} {
3252                 set parent $unchanged_idx
3253             } else {
3254                 # blame the current commit
3255                 set parent -1
3256             }
3257         }
3258         # then count other lines that belong to it
3259         for {set i $line} {[incr i -1] > $s_lno} {} {
3260             set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3261             # Determine if the line is removed
3262             set removed_idx [string first "-" $chunk]
3263             if {$parent >= 0} {
3264                 set code [string index $chunk $parent]
3265                 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3266                     incr dline
3267                 }
3268             } else {
3269                 if {$removed_idx < 0} {
3270                     incr dline
3271                 }
3272             }
3273         }
3274         incr parent
3275     } else {
3276         set parent 0
3277     }
3279     incr dline [lindex $base_lines $parent]
3280     return [list $parent $dline]
3283 proc external_blame_diff {} {
3284     global currentid cmitmode
3285     global diff_menu_txtpos diff_menu_line
3286     global diff_menu_filebase flist_menu_file
3288     if {$cmitmode eq "tree"} {
3289         set parent_idx 0
3290         set line [expr {$diff_menu_line - $diff_menu_filebase}]
3291     } else {
3292         set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3293         if {$hinfo ne {}} {
3294             set parent_idx [lindex $hinfo 0]
3295             set line [lindex $hinfo 1]
3296         } else {
3297             set parent_idx 0
3298             set line 0
3299         }
3300     }
3302     external_blame $parent_idx $line
3305 # Find the SHA1 ID of the blob for file $fname in the index
3306 # at stage 0 or 2
3307 proc index_sha1 {fname} {
3308     set f [open [list | git ls-files -s $fname] r]
3309     while {[gets $f line] >= 0} {
3310         set info [lindex [split $line "\t"] 0]
3311         set stage [lindex $info 2]
3312         if {$stage eq "0" || $stage eq "2"} {
3313             close $f
3314             return [lindex $info 1]
3315         }
3316     }
3317     close $f
3318     return {}
3321 # Turn an absolute path into one relative to the current directory
3322 proc make_relative {f} {
3323     set elts [file split $f]
3324     set here [file split [pwd]]
3325     set ei 0
3326     set hi 0
3327     set res {}
3328     foreach d $here {
3329         if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3330             lappend res ".."
3331         } else {
3332             incr ei
3333         }
3334         incr hi
3335     }
3336     set elts [concat $res [lrange $elts $ei end]]
3337     return [eval file join $elts]
3340 proc external_blame {parent_idx {line {}}} {
3341     global flist_menu_file gitdir
3342     global nullid nullid2
3343     global parentlist selectedline currentid
3345     if {$parent_idx > 0} {
3346         set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3347     } else {
3348         set base_commit $currentid
3349     }
3351     if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3352         error_popup [mc "No such commit"]
3353         return
3354     }
3356     set cmdline [list git gui blame]
3357     if {$line ne {} && $line > 1} {
3358         lappend cmdline "--line=$line"
3359     }
3360     set f [file join [file dirname $gitdir] $flist_menu_file]
3361     # Unfortunately it seems git gui blame doesn't like
3362     # being given an absolute path...
3363     set f [make_relative $f]
3364     lappend cmdline $base_commit $f
3365     puts "cmdline={$cmdline}"
3366     if {[catch {eval exec $cmdline &} err]} {
3367         error_popup "[mc "git gui blame: command failed:"] $err"
3368     }
3371 proc show_line_source {} {
3372     global cmitmode currentid parents curview blamestuff blameinst
3373     global diff_menu_line diff_menu_filebase flist_menu_file
3374     global nullid nullid2 gitdir
3376     set from_index {}
3377     if {$cmitmode eq "tree"} {
3378         set id $currentid
3379         set line [expr {$diff_menu_line - $diff_menu_filebase}]
3380     } else {
3381         set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3382         if {$h eq {}} return
3383         set pi [lindex $h 0]
3384         if {$pi == 0} {
3385             mark_ctext_line $diff_menu_line
3386             return
3387         }
3388         incr pi -1
3389         if {$currentid eq $nullid} {
3390             if {$pi > 0} {
3391                 # must be a merge in progress...
3392                 if {[catch {
3393                     # get the last line from .git/MERGE_HEAD
3394                     set f [open [file join $gitdir MERGE_HEAD] r]
3395                     set id [lindex [split [read $f] "\n"] end-1]
3396                     close $f
3397                 } err]} {
3398                     error_popup [mc "Couldn't read merge head: %s" $err]
3399                     return
3400                 }
3401             } elseif {$parents($curview,$currentid) eq $nullid2} {
3402                 # need to do the blame from the index
3403                 if {[catch {
3404                     set from_index [index_sha1 $flist_menu_file]
3405                 } err]} {
3406                     error_popup [mc "Error reading index: %s" $err]
3407                     return
3408                 }
3409             } else {
3410                 set id $parents($curview,$currentid)
3411             }
3412         } else {
3413             set id [lindex $parents($curview,$currentid) $pi]
3414         }
3415         set line [lindex $h 1]
3416     }
3417     set blameargs {}
3418     if {$from_index ne {}} {
3419         lappend blameargs | git cat-file blob $from_index
3420     }
3421     lappend blameargs | git blame -p -L$line,+1
3422     if {$from_index ne {}} {
3423         lappend blameargs --contents -
3424     } else {
3425         lappend blameargs $id
3426     }
3427     lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3428     if {[catch {
3429         set f [open $blameargs r]
3430     } err]} {
3431         error_popup [mc "Couldn't start git blame: %s" $err]
3432         return
3433     }
3434     nowbusy blaming [mc "Searching"]
3435     fconfigure $f -blocking 0
3436     set i [reg_instance $f]
3437     set blamestuff($i) {}
3438     set blameinst $i
3439     filerun $f [list read_line_source $f $i]
3442 proc stopblaming {} {
3443     global blameinst
3445     if {[info exists blameinst]} {
3446         stop_instance $blameinst
3447         unset blameinst
3448         notbusy blaming
3449     }
3452 proc read_line_source {fd inst} {
3453     global blamestuff curview commfd blameinst nullid nullid2
3455     while {[gets $fd line] >= 0} {
3456         lappend blamestuff($inst) $line
3457     }
3458     if {![eof $fd]} {
3459         return 1
3460     }
3461     unset commfd($inst)
3462     unset blameinst
3463     notbusy blaming
3464     fconfigure $fd -blocking 1
3465     if {[catch {close $fd} err]} {
3466         error_popup [mc "Error running git blame: %s" $err]
3467         return 0
3468     }
3470     set fname {}
3471     set line [split [lindex $blamestuff($inst) 0] " "]
3472     set id [lindex $line 0]
3473     set lnum [lindex $line 1]
3474     if {[string length $id] == 40 && [string is xdigit $id] &&
3475         [string is digit -strict $lnum]} {
3476         # look for "filename" line
3477         foreach l $blamestuff($inst) {
3478             if {[string match "filename *" $l]} {
3479                 set fname [string range $l 9 end]
3480                 break
3481             }
3482         }
3483     }
3484     if {$fname ne {}} {
3485         # all looks good, select it
3486         if {$id eq $nullid} {
3487             # blame uses all-zeroes to mean not committed,
3488             # which would mean a change in the index
3489             set id $nullid2
3490         }
3491         if {[commitinview $id $curview]} {
3492             selectline [rowofcommit $id] 1 [list $fname $lnum]
3493         } else {
3494             error_popup [mc "That line comes from commit %s, \
3495                              which is not in this view" [shortids $id]]
3496         }
3497     } else {
3498         puts "oops couldn't parse git blame output"
3499     }
3500     return 0
3503 # delete $dir when we see eof on $f (presumably because the child has exited)
3504 proc delete_at_eof {f dir} {
3505     while {[gets $f line] >= 0} {}
3506     if {[eof $f]} {
3507         if {[catch {close $f} err]} {
3508             error_popup "[mc "External diff viewer failed:"] $err"
3509         }
3510         file delete -force $dir
3511         return 0
3512     }
3513     return 1
3516 # Functions for adding and removing shell-type quoting
3518 proc shellquote {str} {
3519     if {![string match "*\['\"\\ \t]*" $str]} {
3520         return $str
3521     }
3522     if {![string match "*\['\"\\]*" $str]} {
3523         return "\"$str\""
3524     }
3525     if {![string match "*'*" $str]} {
3526         return "'$str'"
3527     }
3528     return "\"[string map {\" \\\" \\ \\\\} $str]\""
3531 proc shellarglist {l} {
3532     set str {}
3533     foreach a $l {
3534         if {$str ne {}} {
3535             append str " "
3536         }
3537         append str [shellquote $a]
3538     }
3539     return $str
3542 proc shelldequote {str} {
3543     set ret {}
3544     set used -1
3545     while {1} {
3546         incr used
3547         if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3548             append ret [string range $str $used end]
3549             set used [string length $str]
3550             break
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 " " || $ch eq "\t"} break
3559         incr used
3560         if {$ch eq "'"} {
3561             set first [string first "'" $str $used]
3562             if {$first < 0} {
3563                 error "unmatched single-quote"
3564             }
3565             append ret [string range $str $used [expr {$first - 1}]]
3566             set used $first
3567             continue
3568         }
3569         if {$ch eq "\\"} {
3570             if {$used >= [string length $str]} {
3571                 error "trailing backslash"
3572             }
3573             append ret [string index $str $used]
3574             continue
3575         }
3576         # here ch == "\""
3577         while {1} {
3578             if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3579                 error "unmatched double-quote"
3580             }
3581             set first [lindex $first 0]
3582             set ch [string index $str $first]
3583             if {$first > $used} {
3584                 append ret [string range $str $used [expr {$first - 1}]]
3585                 set used $first
3586             }
3587             if {$ch eq "\""} break
3588             incr used
3589             append ret [string index $str $used]
3590             incr used
3591         }
3592     }
3593     return [list $used $ret]
3596 proc shellsplit {str} {
3597     set l {}
3598     while {1} {
3599         set str [string trimleft $str]
3600         if {$str eq {}} break
3601         set dq [shelldequote $str]
3602         set n [lindex $dq 0]
3603         set word [lindex $dq 1]
3604         set str [string range $str $n end]
3605         lappend l $word
3606     }
3607     return $l
3610 # Code to implement multiple views
3612 proc newview {ishighlight} {
3613     global nextviewnum newviewname newishighlight
3614     global revtreeargs viewargscmd newviewopts curview
3616     set newishighlight $ishighlight
3617     set top .gitkview
3618     if {[winfo exists $top]} {
3619         raise $top
3620         return
3621     }
3622     set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3623     set newviewopts($nextviewnum,perm) 0
3624     set newviewopts($nextviewnum,cmd)  $viewargscmd($curview)
3625     decode_view_opts $nextviewnum $revtreeargs
3626     vieweditor $top $nextviewnum [mc "Gitk view definition"]
3629 set known_view_options {
3630     {perm    b    . {}               {mc "Remember this view"}}
3631     {args    t50= + {}               {mc "Commits to include (arguments to git log):"}}
3632     {all     b    * "--all"          {mc "Use all refs"}}
3633     {dorder  b    . {"--date-order" "-d"}      {mc "Strictly sort by date"}}
3634     {lright  b    . "--left-right"   {mc "Mark branch sides"}}
3635     {since   t15  + {"--since=*" "--after=*"}  {mc "Since date:"}}
3636     {until   t15  . {"--until=*" "--before=*"} {mc "Until date:"}}
3637     {limit   t10  + "--max-count=*"  {mc "Max count:"}}
3638     {skip    t10  . "--skip=*"       {mc "Skip:"}}
3639     {first   b    . "--first-parent" {mc "Limit to first parent"}}
3640     {cmd     t50= + {}               {mc "Command to generate more commits to include:"}}
3641     }
3643 proc encode_view_opts {n} {
3644     global known_view_options newviewopts
3646     set rargs [list]
3647     foreach opt $known_view_options {
3648         set patterns [lindex $opt 3]
3649         if {$patterns eq {}} continue
3650         set pattern [lindex $patterns 0]
3652         set val $newviewopts($n,[lindex $opt 0])
3653         
3654         if {[lindex $opt 1] eq "b"} {
3655             if {$val} {
3656                 lappend rargs $pattern
3657             }
3658         } else {
3659             set val [string trim $val]
3660             if {$val ne {}} {
3661                 set pfix [string range $pattern 0 end-1]
3662                 lappend rargs $pfix$val
3663             }
3664         }
3665     }
3666     return [concat $rargs [shellsplit $newviewopts($n,args)]]
3669 proc decode_view_opts {n view_args} {
3670     global known_view_options newviewopts
3672     foreach opt $known_view_options {
3673         if {[lindex $opt 1] eq "b"} {
3674             set val 0
3675         } else {
3676             set val {}
3677         }
3678         set newviewopts($n,[lindex $opt 0]) $val
3679     }
3680     set oargs [list]
3681     foreach arg $view_args {
3682         if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3683             && ![info exists found(limit)]} {
3684             set newviewopts($n,limit) $cnt
3685             set found(limit) 1
3686             continue
3687         }
3688         catch { unset val }
3689         foreach opt $known_view_options {
3690             set id [lindex $opt 0]
3691             if {[info exists found($id)]} continue
3692             foreach pattern [lindex $opt 3] {
3693                 if {![string match $pattern $arg]} continue
3694                 if {[lindex $opt 1] ne "b"} {
3695                     set size [string length $pattern]
3696                     set val [string range $arg [expr {$size-1}] end]
3697                 } else {
3698                     set val 1
3699                 }
3700                 set newviewopts($n,$id) $val
3701                 set found($id) 1
3702                 break
3703             }
3704             if {[info exists val]} break
3705         }
3706         if {[info exists val]} continue
3707         lappend oargs $arg
3708     }
3709     set newviewopts($n,args) [shellarglist $oargs]
3712 proc edit_or_newview {} {
3713     global curview
3715     if {$curview > 0} {
3716         editview
3717     } else {
3718         newview 0
3719     }
3722 proc editview {} {
3723     global curview
3724     global viewname viewperm newviewname newviewopts
3725     global viewargs viewargscmd
3727     set top .gitkvedit-$curview
3728     if {[winfo exists $top]} {
3729         raise $top
3730         return
3731     }
3732     set newviewname($curview)      $viewname($curview)
3733     set newviewopts($curview,perm) $viewperm($curview)
3734     set newviewopts($curview,cmd)  $viewargscmd($curview)
3735     decode_view_opts $curview $viewargs($curview)
3736     vieweditor $top $curview "Gitk: edit view $viewname($curview)"
3739 proc vieweditor {top n title} {
3740     global newviewname newviewopts viewfiles bgcolor
3741     global known_view_options
3743     toplevel $top
3744     wm title $top $title
3745     make_transient $top .
3747     # View name
3748     frame $top.nfr
3749     label $top.nl -text [mc "Name"]
3750     entry $top.name -width 20 -textvariable newviewname($n)
3751     pack $top.nfr -in $top -fill x -pady 5 -padx 3
3752     pack $top.nl -in $top.nfr -side left -padx {0 30}
3753     pack $top.name -in $top.nfr -side left
3755     # View options
3756     set cframe $top.nfr
3757     set cexpand 0
3758     set cnt 0
3759     foreach opt $known_view_options {
3760         set id [lindex $opt 0]
3761         set type [lindex $opt 1]
3762         set flags [lindex $opt 2]
3763         set title [eval [lindex $opt 4]]
3764         set lxpad 0
3766         if {$flags eq "+" || $flags eq "*"} {
3767             set cframe $top.fr$cnt
3768             incr cnt
3769             frame $cframe
3770             pack $cframe -in $top -fill x -pady 3 -padx 3
3771             set cexpand [expr {$flags eq "*"}]
3772         } else {
3773             set lxpad 5
3774         }
3776         if {$type eq "b"} {
3777             checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3778             pack $cframe.c_$id -in $cframe -side left \
3779                 -padx [list $lxpad 0] -expand $cexpand -anchor w
3780         } elseif {[regexp {^t(\d+)$} $type type sz]} {
3781             message $cframe.l_$id -aspect 1500 -text $title
3782             entry $cframe.e_$id -width $sz -background $bgcolor \
3783                 -textvariable newviewopts($n,$id)
3784             pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3785             pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3786         } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3787             message $cframe.l_$id -aspect 1500 -text $title
3788             entry $cframe.e_$id -width $sz -background $bgcolor \
3789                 -textvariable newviewopts($n,$id)
3790             pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3791             pack $cframe.e_$id -in $cframe -side top -fill x
3792         }
3793     }
3795     # Path list
3796     message $top.l -aspect 1500 \
3797         -text [mc "Enter files and directories to include, one per line:"]
3798     pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3799     text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3800     if {[info exists viewfiles($n)]} {
3801         foreach f $viewfiles($n) {
3802             $top.t insert end $f
3803             $top.t insert end "\n"
3804         }
3805         $top.t delete {end - 1c} end
3806         $top.t mark set insert 0.0
3807     }
3808     pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3809     frame $top.buts
3810     button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3811     button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3812     button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3813     bind $top <Control-Return> [list newviewok $top $n]
3814     bind $top <F5> [list newviewok $top $n 1]
3815     bind $top <Escape> [list destroy $top]
3816     grid $top.buts.ok $top.buts.apply $top.buts.can
3817     grid columnconfigure $top.buts 0 -weight 1 -uniform a
3818     grid columnconfigure $top.buts 1 -weight 1 -uniform a
3819     grid columnconfigure $top.buts 2 -weight 1 -uniform a
3820     pack $top.buts -in $top -side top -fill x
3821     focus $top.t
3824 proc doviewmenu {m first cmd op argv} {
3825     set nmenu [$m index end]
3826     for {set i $first} {$i <= $nmenu} {incr i} {
3827         if {[$m entrycget $i -command] eq $cmd} {
3828             eval $m $op $i $argv
3829             break
3830         }
3831     }
3834 proc allviewmenus {n op args} {
3835     # global viewhlmenu
3837     doviewmenu .bar.view 5 [list showview $n] $op $args
3838     # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3841 proc newviewok {top n {apply 0}} {
3842     global nextviewnum newviewperm newviewname newishighlight
3843     global viewname viewfiles viewperm selectedview curview
3844     global viewargs viewargscmd newviewopts viewhlmenu
3846     if {[catch {
3847         set newargs [encode_view_opts $n]
3848     } err]} {
3849         error_popup "[mc "Error in commit selection arguments:"] $err" $top
3850         return
3851     }
3852     set files {}
3853     foreach f [split [$top.t get 0.0 end] "\n"] {
3854         set ft [string trim $f]
3855         if {$ft ne {}} {
3856             lappend files $ft
3857         }
3858     }
3859     if {![info exists viewfiles($n)]} {
3860         # creating a new view
3861         incr nextviewnum
3862         set viewname($n) $newviewname($n)
3863         set viewperm($n) $newviewopts($n,perm)
3864         set viewfiles($n) $files
3865         set viewargs($n) $newargs
3866         set viewargscmd($n) $newviewopts($n,cmd)
3867         addviewmenu $n
3868         if {!$newishighlight} {
3869             run showview $n
3870         } else {
3871             run addvhighlight $n
3872         }
3873     } else {
3874         # editing an existing view
3875         set viewperm($n) $newviewopts($n,perm)
3876         if {$newviewname($n) ne $viewname($n)} {
3877             set viewname($n) $newviewname($n)
3878             doviewmenu .bar.view 5 [list showview $n] \
3879                 entryconf [list -label $viewname($n)]
3880             # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
3881                 # entryconf [list -label $viewname($n) -value $viewname($n)]
3882         }
3883         if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
3884                 $newviewopts($n,cmd) ne $viewargscmd($n)} {
3885             set viewfiles($n) $files
3886             set viewargs($n) $newargs
3887             set viewargscmd($n) $newviewopts($n,cmd)
3888             if {$curview == $n} {
3889                 run reloadcommits
3890             }
3891         }
3892     }
3893     if {$apply} return
3894     catch {destroy $top}
3897 proc delview {} {
3898     global curview viewperm hlview selectedhlview
3900     if {$curview == 0} return
3901     if {[info exists hlview] && $hlview == $curview} {
3902         set selectedhlview [mc "None"]
3903         unset hlview
3904     }
3905     allviewmenus $curview delete
3906     set viewperm($curview) 0
3907     showview 0
3910 proc addviewmenu {n} {
3911     global viewname viewhlmenu
3913     .bar.view add radiobutton -label $viewname($n) \
3914         -command [list showview $n] -variable selectedview -value $n
3915     #$viewhlmenu add radiobutton -label $viewname($n) \
3916     #   -command [list addvhighlight $n] -variable selectedhlview
3919 proc showview {n} {
3920     global curview cached_commitrow ordertok
3921     global displayorder parentlist rowidlist rowisopt rowfinal
3922     global colormap rowtextx nextcolor canvxmax
3923     global numcommits viewcomplete
3924     global selectedline currentid canv canvy0
3925     global treediffs
3926     global pending_select mainheadid
3927     global commitidx
3928     global selectedview
3929     global hlview selectedhlview commitinterest
3931     if {$n == $curview} return
3932     set selid {}
3933     set ymax [lindex [$canv cget -scrollregion] 3]
3934     set span [$canv yview]
3935     set ytop [expr {[lindex $span 0] * $ymax}]
3936     set ybot [expr {[lindex $span 1] * $ymax}]
3937     set yscreen [expr {($ybot - $ytop) / 2}]
3938     if {$selectedline ne {}} {
3939         set selid $currentid
3940         set y [yc $selectedline]
3941         if {$ytop < $y && $y < $ybot} {
3942             set yscreen [expr {$y - $ytop}]
3943         }
3944     } elseif {[info exists pending_select]} {
3945         set selid $pending_select
3946         unset pending_select
3947     }
3948     unselectline
3949     normalline
3950     catch {unset treediffs}
3951     clear_display
3952     if {[info exists hlview] && $hlview == $n} {
3953         unset hlview
3954         set selectedhlview [mc "None"]
3955     }
3956     catch {unset commitinterest}
3957     catch {unset cached_commitrow}
3958     catch {unset ordertok}
3960     set curview $n
3961     set selectedview $n
3962     .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
3963     .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
3965     run refill_reflist
3966     if {![info exists viewcomplete($n)]} {
3967         getcommits $selid
3968         return
3969     }
3971     set displayorder {}
3972     set parentlist {}
3973     set rowidlist {}
3974     set rowisopt {}
3975     set rowfinal {}
3976     set numcommits $commitidx($n)
3978     catch {unset colormap}
3979     catch {unset rowtextx}
3980     set nextcolor 0
3981     set canvxmax [$canv cget -width]
3982     set curview $n
3983     set row 0
3984     setcanvscroll
3985     set yf 0
3986     set row {}
3987     if {$selid ne {} && [commitinview $selid $n]} {
3988         set row [rowofcommit $selid]
3989         # try to get the selected row in the same position on the screen
3990         set ymax [lindex [$canv cget -scrollregion] 3]
3991         set ytop [expr {[yc $row] - $yscreen}]
3992         if {$ytop < 0} {
3993             set ytop 0
3994         }
3995         set yf [expr {$ytop * 1.0 / $ymax}]
3996     }
3997     allcanvs yview moveto $yf
3998     drawvisible
3999     if {$row ne {}} {
4000         selectline $row 0
4001     } elseif {!$viewcomplete($n)} {
4002         reset_pending_select $selid
4003     } else {
4004         reset_pending_select {}
4006         if {[commitinview $pending_select $curview]} {
4007             selectline [rowofcommit $pending_select] 1
4008         } else {
4009             set row [first_real_row]
4010             if {$row < $numcommits} {
4011                 selectline $row 0
4012             }
4013         }
4014     }
4015     if {!$viewcomplete($n)} {
4016         if {$numcommits == 0} {
4017             show_status [mc "Reading commits..."]
4018         }
4019     } elseif {$numcommits == 0} {
4020         show_status [mc "No commits selected"]
4021     }
4024 # Stuff relating to the highlighting facility
4026 proc ishighlighted {id} {
4027     global vhighlights fhighlights nhighlights rhighlights
4029     if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4030         return $nhighlights($id)
4031     }
4032     if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4033         return $vhighlights($id)
4034     }
4035     if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4036         return $fhighlights($id)
4037     }
4038     if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4039         return $rhighlights($id)
4040     }
4041     return 0
4044 proc bolden {id font} {
4045     global canv linehtag currentid boldids need_redisplay
4047     # need_redisplay = 1 means the display is stale and about to be redrawn
4048     if {$need_redisplay} return
4049     lappend boldids $id
4050     $canv itemconf $linehtag($id) -font $font
4051     if {[info exists currentid] && $id eq $currentid} {
4052         $canv delete secsel
4053         set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4054                    -outline {{}} -tags secsel \
4055                    -fill [$canv cget -selectbackground]]
4056         $canv lower $t
4057     }
4060 proc bolden_name {id font} {
4061     global canv2 linentag currentid boldnameids need_redisplay
4063     if {$need_redisplay} return
4064     lappend boldnameids $id
4065     $canv2 itemconf $linentag($id) -font $font
4066     if {[info exists currentid] && $id eq $currentid} {
4067         $canv2 delete secsel
4068         set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4069                    -outline {{}} -tags secsel \
4070                    -fill [$canv2 cget -selectbackground]]
4071         $canv2 lower $t
4072     }
4075 proc unbolden {} {
4076     global boldids
4078     set stillbold {}
4079     foreach id $boldids {
4080         if {![ishighlighted $id]} {
4081             bolden $id mainfont
4082         } else {
4083             lappend stillbold $id
4084         }
4085     }
4086     set boldids $stillbold
4089 proc addvhighlight {n} {
4090     global hlview viewcomplete curview vhl_done commitidx
4092     if {[info exists hlview]} {
4093         delvhighlight
4094     }
4095     set hlview $n
4096     if {$n != $curview && ![info exists viewcomplete($n)]} {
4097         start_rev_list $n
4098     }
4099     set vhl_done $commitidx($hlview)
4100     if {$vhl_done > 0} {
4101         drawvisible
4102     }
4105 proc delvhighlight {} {
4106     global hlview vhighlights
4108     if {![info exists hlview]} return
4109     unset hlview
4110     catch {unset vhighlights}
4111     unbolden
4114 proc vhighlightmore {} {
4115     global hlview vhl_done commitidx vhighlights curview
4117     set max $commitidx($hlview)
4118     set vr [visiblerows]
4119     set r0 [lindex $vr 0]
4120     set r1 [lindex $vr 1]
4121     for {set i $vhl_done} {$i < $max} {incr i} {
4122         set id [commitonrow $i $hlview]
4123         if {[commitinview $id $curview]} {
4124             set row [rowofcommit $id]
4125             if {$r0 <= $row && $row <= $r1} {
4126                 if {![highlighted $row]} {
4127                     bolden $id mainfontbold
4128                 }
4129                 set vhighlights($id) 1
4130             }
4131         }
4132     }
4133     set vhl_done $max
4134     return 0
4137 proc askvhighlight {row id} {
4138     global hlview vhighlights iddrawn
4140     if {[commitinview $id $hlview]} {
4141         if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4142             bolden $id mainfontbold
4143         }
4144         set vhighlights($id) 1
4145     } else {
4146         set vhighlights($id) 0
4147     }
4150 proc hfiles_change {} {
4151     global highlight_files filehighlight fhighlights fh_serial
4152     global highlight_paths
4154     if {[info exists filehighlight]} {
4155         # delete previous highlights
4156         catch {close $filehighlight}
4157         unset filehighlight
4158         catch {unset fhighlights}
4159         unbolden
4160         unhighlight_filelist
4161     }
4162     set highlight_paths {}
4163     after cancel do_file_hl $fh_serial
4164     incr fh_serial
4165     if {$highlight_files ne {}} {
4166         after 300 do_file_hl $fh_serial
4167     }
4170 proc gdttype_change {name ix op} {
4171     global gdttype highlight_files findstring findpattern
4173     stopfinding
4174     if {$findstring ne {}} {
4175         if {$gdttype eq [mc "containing:"]} {
4176             if {$highlight_files ne {}} {
4177                 set highlight_files {}
4178                 hfiles_change
4179             }
4180             findcom_change
4181         } else {
4182             if {$findpattern ne {}} {
4183                 set findpattern {}
4184                 findcom_change
4185             }
4186             set highlight_files $findstring
4187             hfiles_change
4188         }
4189         drawvisible
4190     }
4191     # enable/disable findtype/findloc menus too
4194 proc find_change {name ix op} {
4195     global gdttype findstring highlight_files
4197     stopfinding
4198     if {$gdttype eq [mc "containing:"]} {
4199         findcom_change
4200     } else {
4201         if {$highlight_files ne $findstring} {
4202             set highlight_files $findstring
4203             hfiles_change
4204         }
4205     }
4206     drawvisible
4209 proc findcom_change args {
4210     global nhighlights boldnameids
4211     global findpattern findtype findstring gdttype
4213     stopfinding
4214     # delete previous highlights, if any
4215     foreach id $boldnameids {
4216         bolden_name $id mainfont
4217     }
4218     set boldnameids {}
4219     catch {unset nhighlights}
4220     unbolden
4221     unmarkmatches
4222     if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4223         set findpattern {}
4224     } elseif {$findtype eq [mc "Regexp"]} {
4225         set findpattern $findstring
4226     } else {
4227         set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4228                    $findstring]
4229         set findpattern "*$e*"
4230     }
4233 proc makepatterns {l} {
4234     set ret {}
4235     foreach e $l {
4236         set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4237         if {[string index $ee end] eq "/"} {
4238             lappend ret "$ee*"
4239         } else {
4240             lappend ret $ee
4241             lappend ret "$ee/*"
4242         }
4243     }
4244     return $ret
4247 proc do_file_hl {serial} {
4248     global highlight_files filehighlight highlight_paths gdttype fhl_list
4250     if {$gdttype eq [mc "touching paths:"]} {
4251         if {[catch {set paths [shellsplit $highlight_files]}]} return
4252         set highlight_paths [makepatterns $paths]
4253         highlight_filelist
4254         set gdtargs [concat -- $paths]
4255     } elseif {$gdttype eq [mc "adding/removing string:"]} {
4256         set gdtargs [list "-S$highlight_files"]
4257     } else {
4258         # must be "containing:", i.e. we're searching commit info
4259         return
4260     }
4261     set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4262     set filehighlight [open $cmd r+]
4263     fconfigure $filehighlight -blocking 0
4264     filerun $filehighlight readfhighlight
4265     set fhl_list {}
4266     drawvisible
4267     flushhighlights
4270 proc flushhighlights {} {
4271     global filehighlight fhl_list
4273     if {[info exists filehighlight]} {
4274         lappend fhl_list {}
4275         puts $filehighlight ""
4276         flush $filehighlight
4277     }
4280 proc askfilehighlight {row id} {
4281     global filehighlight fhighlights fhl_list
4283     lappend fhl_list $id
4284     set fhighlights($id) -1
4285     puts $filehighlight $id
4288 proc readfhighlight {} {
4289     global filehighlight fhighlights curview iddrawn
4290     global fhl_list find_dirn
4292     if {![info exists filehighlight]} {
4293         return 0
4294     }
4295     set nr 0
4296     while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4297         set line [string trim $line]
4298         set i [lsearch -exact $fhl_list $line]
4299         if {$i < 0} continue
4300         for {set j 0} {$j < $i} {incr j} {
4301             set id [lindex $fhl_list $j]
4302             set fhighlights($id) 0
4303         }
4304         set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4305         if {$line eq {}} continue
4306         if {![commitinview $line $curview]} continue
4307         if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4308             bolden $line mainfontbold
4309         }
4310         set fhighlights($line) 1
4311     }
4312     if {[eof $filehighlight]} {
4313         # strange...
4314         puts "oops, git diff-tree died"
4315         catch {close $filehighlight}
4316         unset filehighlight
4317         return 0
4318     }
4319     if {[info exists find_dirn]} {
4320         run findmore
4321     }
4322     return 1
4325 proc doesmatch {f} {
4326     global findtype findpattern
4328     if {$findtype eq [mc "Regexp"]} {
4329         return [regexp $findpattern $f]
4330     } elseif {$findtype eq [mc "IgnCase"]} {
4331         return [string match -nocase $findpattern $f]
4332     } else {
4333         return [string match $findpattern $f]
4334     }
4337 proc askfindhighlight {row id} {
4338     global nhighlights commitinfo iddrawn
4339     global findloc
4340     global markingmatches
4342     if {![info exists commitinfo($id)]} {
4343         getcommit $id
4344     }
4345     set info $commitinfo($id)
4346     set isbold 0
4347     set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4348     foreach f $info ty $fldtypes {
4349         if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4350             [doesmatch $f]} {
4351             if {$ty eq [mc "Author"]} {
4352                 set isbold 2
4353                 break
4354             }
4355             set isbold 1
4356         }
4357     }
4358     if {$isbold && [info exists iddrawn($id)]} {
4359         if {![ishighlighted $id]} {
4360             bolden $id mainfontbold
4361             if {$isbold > 1} {
4362                 bolden_name $id mainfontbold
4363             }
4364         }
4365         if {$markingmatches} {
4366             markrowmatches $row $id
4367         }
4368     }
4369     set nhighlights($id) $isbold
4372 proc markrowmatches {row id} {
4373     global canv canv2 linehtag linentag commitinfo findloc
4375     set headline [lindex $commitinfo($id) 0]
4376     set author [lindex $commitinfo($id) 1]
4377     $canv delete match$row
4378     $canv2 delete match$row
4379     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4380         set m [findmatches $headline]
4381         if {$m ne {}} {
4382             markmatches $canv $row $headline $linehtag($id) $m \
4383                 [$canv itemcget $linehtag($id) -font] $row
4384         }
4385     }
4386     if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4387         set m [findmatches $author]
4388         if {$m ne {}} {
4389             markmatches $canv2 $row $author $linentag($id) $m \
4390                 [$canv2 itemcget $linentag($id) -font] $row
4391         }
4392     }
4395 proc vrel_change {name ix op} {
4396     global highlight_related
4398     rhighlight_none
4399     if {$highlight_related ne [mc "None"]} {
4400         run drawvisible
4401     }
4404 # prepare for testing whether commits are descendents or ancestors of a
4405 proc rhighlight_sel {a} {
4406     global descendent desc_todo ancestor anc_todo
4407     global highlight_related
4409     catch {unset descendent}
4410     set desc_todo [list $a]
4411     catch {unset ancestor}
4412     set anc_todo [list $a]
4413     if {$highlight_related ne [mc "None"]} {
4414         rhighlight_none
4415         run drawvisible
4416     }
4419 proc rhighlight_none {} {
4420     global rhighlights
4422     catch {unset rhighlights}
4423     unbolden
4426 proc is_descendent {a} {
4427     global curview children descendent desc_todo
4429     set v $curview
4430     set la [rowofcommit $a]
4431     set todo $desc_todo
4432     set leftover {}
4433     set done 0
4434     for {set i 0} {$i < [llength $todo]} {incr i} {
4435         set do [lindex $todo $i]
4436         if {[rowofcommit $do] < $la} {
4437             lappend leftover $do
4438             continue
4439         }
4440         foreach nk $children($v,$do) {
4441             if {![info exists descendent($nk)]} {
4442                 set descendent($nk) 1
4443                 lappend todo $nk
4444                 if {$nk eq $a} {
4445                     set done 1
4446                 }
4447             }
4448         }
4449         if {$done} {
4450             set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4451             return
4452         }
4453     }
4454     set descendent($a) 0
4455     set desc_todo $leftover
4458 proc is_ancestor {a} {
4459     global curview parents ancestor anc_todo
4461     set v $curview
4462     set la [rowofcommit $a]
4463     set todo $anc_todo
4464     set leftover {}
4465     set done 0
4466     for {set i 0} {$i < [llength $todo]} {incr i} {
4467         set do [lindex $todo $i]
4468         if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4469             lappend leftover $do
4470             continue
4471         }
4472         foreach np $parents($v,$do) {
4473             if {![info exists ancestor($np)]} {
4474                 set ancestor($np) 1
4475                 lappend todo $np
4476                 if {$np eq $a} {
4477                     set done 1
4478                 }
4479             }
4480         }
4481         if {$done} {
4482             set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4483             return
4484         }
4485     }
4486     set ancestor($a) 0
4487     set anc_todo $leftover
4490 proc askrelhighlight {row id} {
4491     global descendent highlight_related iddrawn rhighlights
4492     global selectedline ancestor
4494     if {$selectedline eq {}} return
4495     set isbold 0
4496     if {$highlight_related eq [mc "Descendant"] ||
4497         $highlight_related eq [mc "Not descendant"]} {
4498         if {![info exists descendent($id)]} {
4499             is_descendent $id
4500         }
4501         if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4502             set isbold 1
4503         }
4504     } elseif {$highlight_related eq [mc "Ancestor"] ||
4505               $highlight_related eq [mc "Not ancestor"]} {
4506         if {![info exists ancestor($id)]} {
4507             is_ancestor $id
4508         }
4509         if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4510             set isbold 1
4511         }
4512     }
4513     if {[info exists iddrawn($id)]} {
4514         if {$isbold && ![ishighlighted $id]} {
4515             bolden $id mainfontbold
4516         }
4517     }
4518     set rhighlights($id) $isbold
4521 # Graph layout functions
4523 proc shortids {ids} {
4524     set res {}
4525     foreach id $ids {
4526         if {[llength $id] > 1} {
4527             lappend res [shortids $id]
4528         } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4529             lappend res [string range $id 0 7]
4530         } else {
4531             lappend res $id
4532         }
4533     }
4534     return $res
4537 proc ntimes {n o} {
4538     set ret {}
4539     set o [list $o]
4540     for {set mask 1} {$mask <= $n} {incr mask $mask} {
4541         if {($n & $mask) != 0} {
4542             set ret [concat $ret $o]
4543         }
4544         set o [concat $o $o]
4545     }
4546     return $ret
4549 proc ordertoken {id} {
4550     global ordertok curview varcid varcstart varctok curview parents children
4551     global nullid nullid2
4553     if {[info exists ordertok($id)]} {
4554         return $ordertok($id)
4555     }
4556     set origid $id
4557     set todo {}
4558     while {1} {
4559         if {[info exists varcid($curview,$id)]} {
4560             set a $varcid($curview,$id)
4561             set p [lindex $varcstart($curview) $a]
4562         } else {
4563             set p [lindex $children($curview,$id) 0]
4564         }
4565         if {[info exists ordertok($p)]} {
4566             set tok $ordertok($p)
4567             break
4568         }
4569         set id [first_real_child $curview,$p]
4570         if {$id eq {}} {
4571             # it's a root
4572             set tok [lindex $varctok($curview) $varcid($curview,$p)]
4573             break
4574         }
4575         if {[llength $parents($curview,$id)] == 1} {
4576             lappend todo [list $p {}]
4577         } else {
4578             set j [lsearch -exact $parents($curview,$id) $p]
4579             if {$j < 0} {
4580                 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4581             }
4582             lappend todo [list $p [strrep $j]]
4583         }
4584     }
4585     for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4586         set p [lindex $todo $i 0]
4587         append tok [lindex $todo $i 1]
4588         set ordertok($p) $tok
4589     }
4590     set ordertok($origid) $tok
4591     return $tok
4594 # Work out where id should go in idlist so that order-token
4595 # values increase from left to right
4596 proc idcol {idlist id {i 0}} {
4597     set t [ordertoken $id]
4598     if {$i < 0} {
4599         set i 0
4600     }
4601     if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4602         if {$i > [llength $idlist]} {
4603             set i [llength $idlist]
4604         }
4605         while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4606         incr i
4607     } else {
4608         if {$t > [ordertoken [lindex $idlist $i]]} {
4609             while {[incr i] < [llength $idlist] &&
4610                    $t >= [ordertoken [lindex $idlist $i]]} {}
4611         }
4612     }
4613     return $i
4616 proc initlayout {} {
4617     global rowidlist rowisopt rowfinal displayorder parentlist
4618     global numcommits canvxmax canv
4619     global nextcolor
4620     global colormap rowtextx
4622     set numcommits 0
4623     set displayorder {}
4624     set parentlist {}
4625     set nextcolor 0
4626     set rowidlist {}
4627     set rowisopt {}
4628     set rowfinal {}
4629     set canvxmax [$canv cget -width]
4630     catch {unset colormap}
4631     catch {unset rowtextx}
4632     setcanvscroll
4635 proc setcanvscroll {} {
4636     global canv canv2 canv3 numcommits linespc canvxmax canvy0
4637     global lastscrollset lastscrollrows
4639     set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4640     $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4641     $canv2 conf -scrollregion [list 0 0 0 $ymax]
4642     $canv3 conf -scrollregion [list 0 0 0 $ymax]
4643     set lastscrollset [clock clicks -milliseconds]
4644     set lastscrollrows $numcommits
4647 proc visiblerows {} {
4648     global canv numcommits linespc
4650     set ymax [lindex [$canv cget -scrollregion] 3]
4651     if {$ymax eq {} || $ymax == 0} return
4652     set f [$canv yview]
4653     set y0 [expr {int([lindex $f 0] * $ymax)}]
4654     set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4655     if {$r0 < 0} {
4656         set r0 0
4657     }
4658     set y1 [expr {int([lindex $f 1] * $ymax)}]
4659     set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4660     if {$r1 >= $numcommits} {
4661         set r1 [expr {$numcommits - 1}]
4662     }
4663     return [list $r0 $r1]
4666 proc layoutmore {} {
4667     global commitidx viewcomplete curview
4668     global numcommits pending_select curview
4669     global lastscrollset lastscrollrows
4671     if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4672         [clock clicks -milliseconds] - $lastscrollset > 500} {
4673         setcanvscroll
4674     }
4675     if {[info exists pending_select] &&
4676         [commitinview $pending_select $curview]} {
4677         update
4678         selectline [rowofcommit $pending_select] 1
4679     }
4680     drawvisible
4683 # With path limiting, we mightn't get the actual HEAD commit,
4684 # so ask git rev-list what is the first ancestor of HEAD that
4685 # touches a file in the path limit.
4686 proc get_viewmainhead {view} {
4687     global viewmainheadid vfilelimit viewinstances mainheadid
4689     catch {
4690         set rfd [open [concat | git rev-list -1 $mainheadid \
4691                            -- $vfilelimit($view)] r]
4692         set j [reg_instance $rfd]
4693         lappend viewinstances($view) $j
4694         fconfigure $rfd -blocking 0
4695         filerun $rfd [list getviewhead $rfd $j $view]
4696         set viewmainheadid($curview) {}
4697     }
4700 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4701 proc getviewhead {fd inst view} {
4702     global viewmainheadid commfd curview viewinstances showlocalchanges
4704     set id {}
4705     if {[gets $fd line] < 0} {
4706         if {![eof $fd]} {
4707             return 1
4708         }
4709     } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4710         set id $line
4711     }
4712     set viewmainheadid($view) $id
4713     close $fd
4714     unset commfd($inst)
4715     set i [lsearch -exact $viewinstances($view) $inst]
4716     if {$i >= 0} {
4717         set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4718     }
4719     if {$showlocalchanges && $id ne {} && $view == $curview} {
4720         doshowlocalchanges
4721     }
4722     return 0
4725 proc doshowlocalchanges {} {
4726     global curview viewmainheadid
4728     if {$viewmainheadid($curview) eq {}} return
4729     if {[commitinview $viewmainheadid($curview) $curview]} {
4730         dodiffindex
4731     } else {
4732         interestedin $viewmainheadid($curview) dodiffindex
4733     }
4736 proc dohidelocalchanges {} {
4737     global nullid nullid2 lserial curview
4739     if {[commitinview $nullid $curview]} {
4740         removefakerow $nullid
4741     }
4742     if {[commitinview $nullid2 $curview]} {
4743         removefakerow $nullid2
4744     }
4745     incr lserial
4748 # spawn off a process to do git diff-index --cached HEAD
4749 proc dodiffindex {} {
4750     global lserial showlocalchanges vfilelimit curview
4751     global isworktree
4753     if {!$showlocalchanges || !$isworktree} return
4754     incr lserial
4755     set cmd "|git diff-index --cached HEAD"
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 readdiffindex $fd $lserial $i]
4765 proc readdiffindex {fd serial inst} {
4766     global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4767     global vfilelimit
4769     set isdiff 1
4770     if {[gets $fd line] < 0} {
4771         if {![eof $fd]} {
4772             return 1
4773         }
4774         set isdiff 0
4775     }
4776     # we only need to see one line and we don't really care what it says...
4777     stop_instance $inst
4779     if {$serial != $lserial} {
4780         return 0
4781     }
4783     # now see if there are any local changes not checked in to the index
4784     set cmd "|git diff-files"
4785     if {$vfilelimit($curview) ne {}} {
4786         set cmd [concat $cmd -- $vfilelimit($curview)]
4787     }
4788     set fd [open $cmd r]
4789     fconfigure $fd -blocking 0
4790     set i [reg_instance $fd]
4791     filerun $fd [list readdifffiles $fd $serial $i]
4793     if {$isdiff && ![commitinview $nullid2 $curview]} {
4794         # add the line for the changes in the index to the graph
4795         set hl [mc "Local changes checked in to index but not committed"]
4796         set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
4797         set commitdata($nullid2) "\n    $hl\n"
4798         if {[commitinview $nullid $curview]} {
4799             removefakerow $nullid
4800         }
4801         insertfakerow $nullid2 $viewmainheadid($curview)
4802     } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4803         if {[commitinview $nullid $curview]} {
4804             removefakerow $nullid
4805         }
4806         removefakerow $nullid2
4807     }
4808     return 0
4811 proc readdifffiles {fd serial inst} {
4812     global viewmainheadid nullid nullid2 curview
4813     global commitinfo commitdata lserial
4815     set isdiff 1
4816     if {[gets $fd line] < 0} {
4817         if {![eof $fd]} {
4818             return 1
4819         }
4820         set isdiff 0
4821     }
4822     # we only need to see one line and we don't really care what it says...
4823     stop_instance $inst
4825     if {$serial != $lserial} {
4826         return 0
4827     }
4829     if {$isdiff && ![commitinview $nullid $curview]} {
4830         # add the line for the local diff to the graph
4831         set hl [mc "Local uncommitted changes, not checked in to index"]
4832         set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
4833         set commitdata($nullid) "\n    $hl\n"
4834         if {[commitinview $nullid2 $curview]} {
4835             set p $nullid2
4836         } else {
4837             set p $viewmainheadid($curview)
4838         }
4839         insertfakerow $nullid $p
4840     } elseif {!$isdiff && [commitinview $nullid $curview]} {
4841         removefakerow $nullid
4842     }
4843     return 0
4846 proc nextuse {id row} {
4847     global curview children
4849     if {[info exists children($curview,$id)]} {
4850         foreach kid $children($curview,$id) {
4851             if {![commitinview $kid $curview]} {
4852                 return -1
4853             }
4854             if {[rowofcommit $kid] > $row} {
4855                 return [rowofcommit $kid]
4856             }
4857         }
4858     }
4859     if {[commitinview $id $curview]} {
4860         return [rowofcommit $id]
4861     }
4862     return -1
4865 proc prevuse {id row} {
4866     global curview children
4868     set ret -1
4869     if {[info exists children($curview,$id)]} {
4870         foreach kid $children($curview,$id) {
4871             if {![commitinview $kid $curview]} break
4872             if {[rowofcommit $kid] < $row} {
4873                 set ret [rowofcommit $kid]
4874             }
4875         }
4876     }
4877     return $ret
4880 proc make_idlist {row} {
4881     global displayorder parentlist uparrowlen downarrowlen mingaplen
4882     global commitidx curview children
4884     set r [expr {$row - $mingaplen - $downarrowlen - 1}]
4885     if {$r < 0} {
4886         set r 0
4887     }
4888     set ra [expr {$row - $downarrowlen}]
4889     if {$ra < 0} {
4890         set ra 0
4891     }
4892     set rb [expr {$row + $uparrowlen}]
4893     if {$rb > $commitidx($curview)} {
4894         set rb $commitidx($curview)
4895     }
4896     make_disporder $r [expr {$rb + 1}]
4897     set ids {}
4898     for {} {$r < $ra} {incr r} {
4899         set nextid [lindex $displayorder [expr {$r + 1}]]
4900         foreach p [lindex $parentlist $r] {
4901             if {$p eq $nextid} continue
4902             set rn [nextuse $p $r]
4903             if {$rn >= $row &&
4904                 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
4905                 lappend ids [list [ordertoken $p] $p]
4906             }
4907         }
4908     }
4909     for {} {$r < $row} {incr r} {
4910         set nextid [lindex $displayorder [expr {$r + 1}]]
4911         foreach p [lindex $parentlist $r] {
4912             if {$p eq $nextid} continue
4913             set rn [nextuse $p $r]
4914             if {$rn < 0 || $rn >= $row} {
4915                 lappend ids [list [ordertoken $p] $p]
4916             }
4917         }
4918     }
4919     set id [lindex $displayorder $row]
4920     lappend ids [list [ordertoken $id] $id]
4921     while {$r < $rb} {
4922         foreach p [lindex $parentlist $r] {
4923             set firstkid [lindex $children($curview,$p) 0]
4924             if {[rowofcommit $firstkid] < $row} {
4925                 lappend ids [list [ordertoken $p] $p]
4926             }
4927         }
4928         incr r
4929         set id [lindex $displayorder $r]
4930         if {$id ne {}} {
4931             set firstkid [lindex $children($curview,$id) 0]
4932             if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
4933                 lappend ids [list [ordertoken $id] $id]
4934             }
4935         }
4936     }
4937     set idlist {}
4938     foreach idx [lsort -unique $ids] {
4939         lappend idlist [lindex $idx 1]
4940     }
4941     return $idlist
4944 proc rowsequal {a b} {
4945     while {[set i [lsearch -exact $a {}]] >= 0} {
4946         set a [lreplace $a $i $i]
4947     }
4948     while {[set i [lsearch -exact $b {}]] >= 0} {
4949         set b [lreplace $b $i $i]
4950     }
4951     return [expr {$a eq $b}]
4954 proc makeupline {id row rend col} {
4955     global rowidlist uparrowlen downarrowlen mingaplen
4957     for {set r $rend} {1} {set r $rstart} {
4958         set rstart [prevuse $id $r]
4959         if {$rstart < 0} return
4960         if {$rstart < $row} break
4961     }
4962     if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
4963         set rstart [expr {$rend - $uparrowlen - 1}]
4964     }
4965     for {set r $rstart} {[incr r] <= $row} {} {
4966         set idlist [lindex $rowidlist $r]
4967         if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
4968             set col [idcol $idlist $id $col]
4969             lset rowidlist $r [linsert $idlist $col $id]
4970             changedrow $r
4971         }
4972     }
4975 proc layoutrows {row endrow} {
4976     global rowidlist rowisopt rowfinal displayorder
4977     global uparrowlen downarrowlen maxwidth mingaplen
4978     global children parentlist
4979     global commitidx viewcomplete curview
4981     make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
4982     set idlist {}
4983     if {$row > 0} {
4984         set rm1 [expr {$row - 1}]
4985         foreach id [lindex $rowidlist $rm1] {
4986             if {$id ne {}} {
4987                 lappend idlist $id
4988             }
4989         }
4990         set final [lindex $rowfinal $rm1]
4991     }
4992     for {} {$row < $endrow} {incr row} {
4993         set rm1 [expr {$row - 1}]
4994         if {$rm1 < 0 || $idlist eq {}} {
4995             set idlist [make_idlist $row]
4996             set final 1
4997         } else {
4998             set id [lindex $displayorder $rm1]
4999             set col [lsearch -exact $idlist $id]
5000             set idlist [lreplace $idlist $col $col]
5001             foreach p [lindex $parentlist $rm1] {
5002                 if {[lsearch -exact $idlist $p] < 0} {
5003                     set col [idcol $idlist $p $col]
5004                     set idlist [linsert $idlist $col $p]
5005                     # if not the first child, we have to insert a line going up
5006                     if {$id ne [lindex $children($curview,$p) 0]} {
5007                         makeupline $p $rm1 $row $col
5008                     }
5009                 }
5010             }
5011             set id [lindex $displayorder $row]
5012             if {$row > $downarrowlen} {
5013                 set termrow [expr {$row - $downarrowlen - 1}]
5014                 foreach p [lindex $parentlist $termrow] {
5015                     set i [lsearch -exact $idlist $p]
5016                     if {$i < 0} continue
5017                     set nr [nextuse $p $termrow]
5018                     if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5019                         set idlist [lreplace $idlist $i $i]
5020                     }
5021                 }
5022             }
5023             set col [lsearch -exact $idlist $id]
5024             if {$col < 0} {
5025                 set col [idcol $idlist $id]
5026                 set idlist [linsert $idlist $col $id]
5027                 if {$children($curview,$id) ne {}} {
5028                     makeupline $id $rm1 $row $col
5029                 }
5030             }
5031             set r [expr {$row + $uparrowlen - 1}]
5032             if {$r < $commitidx($curview)} {
5033                 set x $col
5034                 foreach p [lindex $parentlist $r] {
5035                     if {[lsearch -exact $idlist $p] >= 0} continue
5036                     set fk [lindex $children($curview,$p) 0]
5037                     if {[rowofcommit $fk] < $row} {
5038                         set x [idcol $idlist $p $x]
5039                         set idlist [linsert $idlist $x $p]
5040                     }
5041                 }
5042                 if {[incr r] < $commitidx($curview)} {
5043                     set p [lindex $displayorder $r]
5044                     if {[lsearch -exact $idlist $p] < 0} {
5045                         set fk [lindex $children($curview,$p) 0]
5046                         if {$fk ne {} && [rowofcommit $fk] < $row} {
5047                             set x [idcol $idlist $p $x]
5048                             set idlist [linsert $idlist $x $p]
5049                         }
5050                     }
5051                 }
5052             }
5053         }
5054         if {$final && !$viewcomplete($curview) &&
5055             $row + $uparrowlen + $mingaplen + $downarrowlen
5056                 >= $commitidx($curview)} {
5057             set final 0
5058         }
5059         set l [llength $rowidlist]
5060         if {$row == $l} {
5061             lappend rowidlist $idlist
5062             lappend rowisopt 0
5063             lappend rowfinal $final
5064         } elseif {$row < $l} {
5065             if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5066                 lset rowidlist $row $idlist
5067                 changedrow $row
5068             }
5069             lset rowfinal $row $final
5070         } else {
5071             set pad [ntimes [expr {$row - $l}] {}]
5072             set rowidlist [concat $rowidlist $pad]
5073             lappend rowidlist $idlist
5074             set rowfinal [concat $rowfinal $pad]
5075             lappend rowfinal $final
5076             set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5077         }
5078     }
5079     return $row
5082 proc changedrow {row} {
5083     global displayorder iddrawn rowisopt need_redisplay
5085     set l [llength $rowisopt]
5086     if {$row < $l} {
5087         lset rowisopt $row 0
5088         if {$row + 1 < $l} {
5089             lset rowisopt [expr {$row + 1}] 0
5090             if {$row + 2 < $l} {
5091                 lset rowisopt [expr {$row + 2}] 0
5092             }
5093         }
5094     }
5095     set id [lindex $displayorder $row]
5096     if {[info exists iddrawn($id)]} {
5097         set need_redisplay 1
5098     }
5101 proc insert_pad {row col npad} {
5102     global rowidlist
5104     set pad [ntimes $npad {}]
5105     set idlist [lindex $rowidlist $row]
5106     set bef [lrange $idlist 0 [expr {$col - 1}]]
5107     set aft [lrange $idlist $col end]
5108     set i [lsearch -exact $aft {}]
5109     if {$i > 0} {
5110         set aft [lreplace $aft $i $i]
5111     }
5112     lset rowidlist $row [concat $bef $pad $aft]
5113     changedrow $row
5116 proc optimize_rows {row col endrow} {
5117     global rowidlist rowisopt displayorder curview children
5119     if {$row < 1} {
5120         set row 1
5121     }
5122     for {} {$row < $endrow} {incr row; set col 0} {
5123         if {[lindex $rowisopt $row]} continue
5124         set haspad 0
5125         set y0 [expr {$row - 1}]
5126         set ym [expr {$row - 2}]
5127         set idlist [lindex $rowidlist $row]
5128         set previdlist [lindex $rowidlist $y0]
5129         if {$idlist eq {} || $previdlist eq {}} continue
5130         if {$ym >= 0} {
5131             set pprevidlist [lindex $rowidlist $ym]
5132             if {$pprevidlist eq {}} continue
5133         } else {
5134             set pprevidlist {}
5135         }
5136         set x0 -1
5137         set xm -1
5138         for {} {$col < [llength $idlist]} {incr col} {
5139             set id [lindex $idlist $col]
5140             if {[lindex $previdlist $col] eq $id} continue
5141             if {$id eq {}} {
5142                 set haspad 1
5143                 continue
5144             }
5145             set x0 [lsearch -exact $previdlist $id]
5146             if {$x0 < 0} continue
5147             set z [expr {$x0 - $col}]
5148             set isarrow 0
5149             set z0 {}
5150             if {$ym >= 0} {
5151                 set xm [lsearch -exact $pprevidlist $id]
5152                 if {$xm >= 0} {
5153                     set z0 [expr {$xm - $x0}]
5154                 }
5155             }
5156             if {$z0 eq {}} {
5157                 # if row y0 is the first child of $id then it's not an arrow
5158                 if {[lindex $children($curview,$id) 0] ne
5159                     [lindex $displayorder $y0]} {
5160                     set isarrow 1
5161                 }
5162             }
5163             if {!$isarrow && $id ne [lindex $displayorder $row] &&
5164                 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5165                 set isarrow 1
5166             }
5167             # Looking at lines from this row to the previous row,
5168             # make them go straight up if they end in an arrow on
5169             # the previous row; otherwise make them go straight up
5170             # or at 45 degrees.
5171             if {$z < -1 || ($z < 0 && $isarrow)} {
5172                 # Line currently goes left too much;
5173                 # insert pads in the previous row, then optimize it
5174                 set npad [expr {-1 - $z + $isarrow}]
5175                 insert_pad $y0 $x0 $npad
5176                 if {$y0 > 0} {
5177                     optimize_rows $y0 $x0 $row
5178                 }
5179                 set previdlist [lindex $rowidlist $y0]
5180                 set x0 [lsearch -exact $previdlist $id]
5181                 set z [expr {$x0 - $col}]
5182                 if {$z0 ne {}} {
5183                     set pprevidlist [lindex $rowidlist $ym]
5184                     set xm [lsearch -exact $pprevidlist $id]
5185                     set z0 [expr {$xm - $x0}]
5186                 }
5187             } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5188                 # Line currently goes right too much;
5189                 # insert pads in this line
5190                 set npad [expr {$z - 1 + $isarrow}]
5191                 insert_pad $row $col $npad
5192                 set idlist [lindex $rowidlist $row]
5193                 incr col $npad
5194                 set z [expr {$x0 - $col}]
5195                 set haspad 1
5196             }
5197             if {$z0 eq {} && !$isarrow && $ym >= 0} {
5198                 # this line links to its first child on row $row-2
5199                 set id [lindex $displayorder $ym]
5200                 set xc [lsearch -exact $pprevidlist $id]
5201                 if {$xc >= 0} {
5202                     set z0 [expr {$xc - $x0}]
5203                 }
5204             }
5205             # avoid lines jigging left then immediately right
5206             if {$z0 ne {} && $z < 0 && $z0 > 0} {
5207                 insert_pad $y0 $x0 1
5208                 incr x0
5209                 optimize_rows $y0 $x0 $row
5210                 set previdlist [lindex $rowidlist $y0]
5211             }
5212         }
5213         if {!$haspad} {
5214             # Find the first column that doesn't have a line going right
5215             for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5216                 set id [lindex $idlist $col]
5217                 if {$id eq {}} break
5218                 set x0 [lsearch -exact $previdlist $id]
5219                 if {$x0 < 0} {
5220                     # check if this is the link to the first child
5221                     set kid [lindex $displayorder $y0]
5222                     if {[lindex $children($curview,$id) 0] eq $kid} {
5223                         # it is, work out offset to child
5224                         set x0 [lsearch -exact $previdlist $kid]
5225                     }
5226                 }
5227                 if {$x0 <= $col} break
5228             }
5229             # Insert a pad at that column as long as it has a line and
5230             # isn't the last column
5231             if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5232                 set idlist [linsert $idlist $col {}]
5233                 lset rowidlist $row $idlist
5234                 changedrow $row
5235             }
5236         }
5237     }
5240 proc xc {row col} {
5241     global canvx0 linespc
5242     return [expr {$canvx0 + $col * $linespc}]
5245 proc yc {row} {
5246     global canvy0 linespc
5247     return [expr {$canvy0 + $row * $linespc}]
5250 proc linewidth {id} {
5251     global thickerline lthickness
5253     set wid $lthickness
5254     if {[info exists thickerline] && $id eq $thickerline} {
5255         set wid [expr {2 * $lthickness}]
5256     }
5257     return $wid
5260 proc rowranges {id} {
5261     global curview children uparrowlen downarrowlen
5262     global rowidlist
5264     set kids $children($curview,$id)
5265     if {$kids eq {}} {
5266         return {}
5267     }
5268     set ret {}
5269     lappend kids $id
5270     foreach child $kids {
5271         if {![commitinview $child $curview]} break
5272         set row [rowofcommit $child]
5273         if {![info exists prev]} {
5274             lappend ret [expr {$row + 1}]
5275         } else {
5276             if {$row <= $prevrow} {
5277                 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5278             }
5279             # see if the line extends the whole way from prevrow to row
5280             if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5281                 [lsearch -exact [lindex $rowidlist \
5282                             [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5283                 # it doesn't, see where it ends
5284                 set r [expr {$prevrow + $downarrowlen}]
5285                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5286                     while {[incr r -1] > $prevrow &&
5287                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5288                 } else {
5289                     while {[incr r] <= $row &&
5290                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5291                     incr r -1
5292                 }
5293                 lappend ret $r
5294                 # see where it starts up again
5295                 set r [expr {$row - $uparrowlen}]
5296                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5297                     while {[incr r] < $row &&
5298                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5299                 } else {
5300                     while {[incr r -1] >= $prevrow &&
5301                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5302                     incr r
5303                 }
5304                 lappend ret $r
5305             }
5306         }
5307         if {$child eq $id} {
5308             lappend ret $row
5309         }
5310         set prev $child
5311         set prevrow $row
5312     }
5313     return $ret
5316 proc drawlineseg {id row endrow arrowlow} {
5317     global rowidlist displayorder iddrawn linesegs
5318     global canv colormap linespc curview maxlinelen parentlist
5320     set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5321     set le [expr {$row + 1}]
5322     set arrowhigh 1
5323     while {1} {
5324         set c [lsearch -exact [lindex $rowidlist $le] $id]
5325         if {$c < 0} {
5326             incr le -1
5327             break
5328         }
5329         lappend cols $c
5330         set x [lindex $displayorder $le]
5331         if {$x eq $id} {
5332             set arrowhigh 0
5333             break
5334         }
5335         if {[info exists iddrawn($x)] || $le == $endrow} {
5336             set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5337             if {$c >= 0} {
5338                 lappend cols $c
5339                 set arrowhigh 0
5340             }
5341             break
5342         }
5343         incr le
5344     }
5345     if {$le <= $row} {
5346         return $row
5347     }
5349     set lines {}
5350     set i 0
5351     set joinhigh 0
5352     if {[info exists linesegs($id)]} {
5353         set lines $linesegs($id)
5354         foreach li $lines {
5355             set r0 [lindex $li 0]
5356             if {$r0 > $row} {
5357                 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5358                     set joinhigh 1
5359                 }
5360                 break
5361             }
5362             incr i
5363         }
5364     }
5365     set joinlow 0
5366     if {$i > 0} {
5367         set li [lindex $lines [expr {$i-1}]]
5368         set r1 [lindex $li 1]
5369         if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5370             set joinlow 1
5371         }
5372     }
5374     set x [lindex $cols [expr {$le - $row}]]
5375     set xp [lindex $cols [expr {$le - 1 - $row}]]
5376     set dir [expr {$xp - $x}]
5377     if {$joinhigh} {
5378         set ith [lindex $lines $i 2]
5379         set coords [$canv coords $ith]
5380         set ah [$canv itemcget $ith -arrow]
5381         set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5382         set x2 [lindex $cols [expr {$le + 1 - $row}]]
5383         if {$x2 ne {} && $x - $x2 == $dir} {
5384             set coords [lrange $coords 0 end-2]
5385         }
5386     } else {
5387         set coords [list [xc $le $x] [yc $le]]
5388     }
5389     if {$joinlow} {
5390         set itl [lindex $lines [expr {$i-1}] 2]
5391         set al [$canv itemcget $itl -arrow]
5392         set arrowlow [expr {$al eq "last" || $al eq "both"}]
5393     } elseif {$arrowlow} {
5394         if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5395             [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5396             set arrowlow 0
5397         }
5398     }
5399     set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5400     for {set y $le} {[incr y -1] > $row} {} {
5401         set x $xp
5402         set xp [lindex $cols [expr {$y - 1 - $row}]]
5403         set ndir [expr {$xp - $x}]
5404         if {$dir != $ndir || $xp < 0} {
5405             lappend coords [xc $y $x] [yc $y]
5406         }
5407         set dir $ndir
5408     }
5409     if {!$joinlow} {
5410         if {$xp < 0} {
5411             # join parent line to first child
5412             set ch [lindex $displayorder $row]
5413             set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5414             if {$xc < 0} {
5415                 puts "oops: drawlineseg: child $ch not on row $row"
5416             } elseif {$xc != $x} {
5417                 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5418                     set d [expr {int(0.5 * $linespc)}]
5419                     set x1 [xc $row $x]
5420                     if {$xc < $x} {
5421                         set x2 [expr {$x1 - $d}]
5422                     } else {
5423                         set x2 [expr {$x1 + $d}]
5424                     }
5425                     set y2 [yc $row]
5426                     set y1 [expr {$y2 + $d}]
5427                     lappend coords $x1 $y1 $x2 $y2
5428                 } elseif {$xc < $x - 1} {
5429                     lappend coords [xc $row [expr {$x-1}]] [yc $row]
5430                 } elseif {$xc > $x + 1} {
5431                     lappend coords [xc $row [expr {$x+1}]] [yc $row]
5432                 }
5433                 set x $xc
5434             }
5435             lappend coords [xc $row $x] [yc $row]
5436         } else {
5437             set xn [xc $row $xp]
5438             set yn [yc $row]
5439             lappend coords $xn $yn
5440         }
5441         if {!$joinhigh} {
5442             assigncolor $id
5443             set t [$canv create line $coords -width [linewidth $id] \
5444                        -fill $colormap($id) -tags lines.$id -arrow $arrow]
5445             $canv lower $t
5446             bindline $t $id
5447             set lines [linsert $lines $i [list $row $le $t]]
5448         } else {
5449             $canv coords $ith $coords
5450             if {$arrow ne $ah} {
5451                 $canv itemconf $ith -arrow $arrow
5452             }
5453             lset lines $i 0 $row
5454         }
5455     } else {
5456         set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5457         set ndir [expr {$xo - $xp}]
5458         set clow [$canv coords $itl]
5459         if {$dir == $ndir} {
5460             set clow [lrange $clow 2 end]
5461         }
5462         set coords [concat $coords $clow]
5463         if {!$joinhigh} {
5464             lset lines [expr {$i-1}] 1 $le
5465         } else {
5466             # coalesce two pieces
5467             $canv delete $ith
5468             set b [lindex $lines [expr {$i-1}] 0]
5469             set e [lindex $lines $i 1]
5470             set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5471         }
5472         $canv coords $itl $coords
5473         if {$arrow ne $al} {
5474             $canv itemconf $itl -arrow $arrow
5475         }
5476     }
5478     set linesegs($id) $lines
5479     return $le
5482 proc drawparentlinks {id row} {
5483     global rowidlist canv colormap curview parentlist
5484     global idpos linespc
5486     set rowids [lindex $rowidlist $row]
5487     set col [lsearch -exact $rowids $id]
5488     if {$col < 0} return
5489     set olds [lindex $parentlist $row]
5490     set row2 [expr {$row + 1}]
5491     set x [xc $row $col]
5492     set y [yc $row]
5493     set y2 [yc $row2]
5494     set d [expr {int(0.5 * $linespc)}]
5495     set ymid [expr {$y + $d}]
5496     set ids [lindex $rowidlist $row2]
5497     # rmx = right-most X coord used
5498     set rmx 0
5499     foreach p $olds {
5500         set i [lsearch -exact $ids $p]
5501         if {$i < 0} {
5502             puts "oops, parent $p of $id not in list"
5503             continue
5504         }
5505         set x2 [xc $row2 $i]
5506         if {$x2 > $rmx} {
5507             set rmx $x2
5508         }
5509         set j [lsearch -exact $rowids $p]
5510         if {$j < 0} {
5511             # drawlineseg will do this one for us
5512             continue
5513         }
5514         assigncolor $p
5515         # should handle duplicated parents here...
5516         set coords [list $x $y]
5517         if {$i != $col} {
5518             # if attaching to a vertical segment, draw a smaller
5519             # slant for visual distinctness
5520             if {$i == $j} {
5521                 if {$i < $col} {
5522                     lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5523                 } else {
5524                     lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5525                 }
5526             } elseif {$i < $col && $i < $j} {
5527                 # segment slants towards us already
5528                 lappend coords [xc $row $j] $y
5529             } else {
5530                 if {$i < $col - 1} {
5531                     lappend coords [expr {$x2 + $linespc}] $y
5532                 } elseif {$i > $col + 1} {
5533                     lappend coords [expr {$x2 - $linespc}] $y
5534                 }
5535                 lappend coords $x2 $y2
5536             }
5537         } else {
5538             lappend coords $x2 $y2
5539         }
5540         set t [$canv create line $coords -width [linewidth $p] \
5541                    -fill $colormap($p) -tags lines.$p]
5542         $canv lower $t
5543         bindline $t $p
5544     }
5545     if {$rmx > [lindex $idpos($id) 1]} {
5546         lset idpos($id) 1 $rmx
5547         redrawtags $id
5548     }
5551 proc drawlines {id} {
5552     global canv
5554     $canv itemconf lines.$id -width [linewidth $id]
5557 proc drawcmittext {id row col} {
5558     global linespc canv canv2 canv3 fgcolor curview
5559     global cmitlisted commitinfo rowidlist parentlist
5560     global rowtextx idpos idtags idheads idotherrefs
5561     global linehtag linentag linedtag selectedline
5562     global canvxmax boldids boldnameids fgcolor
5563     global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5565     # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5566     set listed $cmitlisted($curview,$id)
5567     if {$id eq $nullid} {
5568         set ofill red
5569     } elseif {$id eq $nullid2} {
5570         set ofill green
5571     } elseif {$id eq $mainheadid} {
5572         set ofill yellow
5573     } else {
5574         set ofill [lindex $circlecolors $listed]
5575     }
5576     set x [xc $row $col]
5577     set y [yc $row]
5578     set orad [expr {$linespc / 3}]
5579     if {$listed <= 2} {
5580         set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5581                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5582                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
5583     } elseif {$listed == 3} {
5584         # triangle pointing left for left-side commits
5585         set t [$canv create polygon \
5586                    [expr {$x - $orad}] $y \
5587                    [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5588                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5589                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
5590     } else {
5591         # triangle pointing right for right-side commits
5592         set t [$canv create polygon \
5593                    [expr {$x + $orad - 1}] $y \
5594                    [expr {$x - $orad}] [expr {$y - $orad}] \
5595                    [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5596                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
5597     }
5598     set circleitem($row) $t
5599     $canv raise $t
5600     $canv bind $t <1> {selcanvline {} %x %y}
5601     set rmx [llength [lindex $rowidlist $row]]
5602     set olds [lindex $parentlist $row]
5603     if {$olds ne {}} {
5604         set nextids [lindex $rowidlist [expr {$row + 1}]]
5605         foreach p $olds {
5606             set i [lsearch -exact $nextids $p]
5607             if {$i > $rmx} {
5608                 set rmx $i
5609             }
5610         }
5611     }
5612     set xt [xc $row $rmx]
5613     set rowtextx($row) $xt
5614     set idpos($id) [list $x $xt $y]
5615     if {[info exists idtags($id)] || [info exists idheads($id)]
5616         || [info exists idotherrefs($id)]} {
5617         set xt [drawtags $id $x $xt $y]
5618     }
5619     set headline [lindex $commitinfo($id) 0]
5620     set name [lindex $commitinfo($id) 1]
5621     set date [lindex $commitinfo($id) 2]
5622     set date [formatdate $date]
5623     set font mainfont
5624     set nfont mainfont
5625     set isbold [ishighlighted $id]
5626     if {$isbold > 0} {
5627         lappend boldids $id
5628         set font mainfontbold
5629         if {$isbold > 1} {
5630             lappend boldnameids $id
5631             set nfont mainfontbold
5632         }
5633     }
5634     set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5635                            -text $headline -font $font -tags text]
5636     $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5637     set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5638                            -text $name -font $nfont -tags text]
5639     set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5640                            -text $date -font mainfont -tags text]
5641     if {$selectedline == $row} {
5642         make_secsel $id
5643     }
5644     set xr [expr {$xt + [font measure $font $headline]}]
5645     if {$xr > $canvxmax} {
5646         set canvxmax $xr
5647         setcanvscroll
5648     }
5651 proc drawcmitrow {row} {
5652     global displayorder rowidlist nrows_drawn
5653     global iddrawn markingmatches
5654     global commitinfo numcommits
5655     global filehighlight fhighlights findpattern nhighlights
5656     global hlview vhighlights
5657     global highlight_related rhighlights
5659     if {$row >= $numcommits} return
5661     set id [lindex $displayorder $row]
5662     if {[info exists hlview] && ![info exists vhighlights($id)]} {
5663         askvhighlight $row $id
5664     }
5665     if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5666         askfilehighlight $row $id
5667     }
5668     if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5669         askfindhighlight $row $id
5670     }
5671     if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5672         askrelhighlight $row $id
5673     }
5674     if {![info exists iddrawn($id)]} {
5675         set col [lsearch -exact [lindex $rowidlist $row] $id]
5676         if {$col < 0} {
5677             puts "oops, row $row id $id not in list"
5678             return
5679         }
5680         if {![info exists commitinfo($id)]} {
5681             getcommit $id
5682         }
5683         assigncolor $id
5684         drawcmittext $id $row $col
5685         set iddrawn($id) 1
5686         incr nrows_drawn
5687     }
5688     if {$markingmatches} {
5689         markrowmatches $row $id
5690     }
5693 proc drawcommits {row {endrow {}}} {
5694     global numcommits iddrawn displayorder curview need_redisplay
5695     global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5697     if {$row < 0} {
5698         set row 0
5699     }
5700     if {$endrow eq {}} {
5701         set endrow $row
5702     }
5703     if {$endrow >= $numcommits} {
5704         set endrow [expr {$numcommits - 1}]
5705     }
5707     set rl1 [expr {$row - $downarrowlen - 3}]
5708     if {$rl1 < 0} {
5709         set rl1 0
5710     }
5711     set ro1 [expr {$row - 3}]
5712     if {$ro1 < 0} {
5713         set ro1 0
5714     }
5715     set r2 [expr {$endrow + $uparrowlen + 3}]
5716     if {$r2 > $numcommits} {
5717         set r2 $numcommits
5718     }
5719     for {set r $rl1} {$r < $r2} {incr r} {
5720         if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5721             if {$rl1 < $r} {
5722                 layoutrows $rl1 $r
5723             }
5724             set rl1 [expr {$r + 1}]
5725         }
5726     }
5727     if {$rl1 < $r} {
5728         layoutrows $rl1 $r
5729     }
5730     optimize_rows $ro1 0 $r2
5731     if {$need_redisplay || $nrows_drawn > 2000} {
5732         clear_display
5733         drawvisible
5734     }
5736     # make the lines join to already-drawn rows either side
5737     set r [expr {$row - 1}]
5738     if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5739         set r $row
5740     }
5741     set er [expr {$endrow + 1}]
5742     if {$er >= $numcommits ||
5743         ![info exists iddrawn([lindex $displayorder $er])]} {
5744         set er $endrow
5745     }
5746     for {} {$r <= $er} {incr r} {
5747         set id [lindex $displayorder $r]
5748         set wasdrawn [info exists iddrawn($id)]
5749         drawcmitrow $r
5750         if {$r == $er} break
5751         set nextid [lindex $displayorder [expr {$r + 1}]]
5752         if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5753         drawparentlinks $id $r
5755         set rowids [lindex $rowidlist $r]
5756         foreach lid $rowids {
5757             if {$lid eq {}} continue
5758             if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5759             if {$lid eq $id} {
5760                 # see if this is the first child of any of its parents
5761                 foreach p [lindex $parentlist $r] {
5762                     if {[lsearch -exact $rowids $p] < 0} {
5763                         # make this line extend up to the child
5764                         set lineend($p) [drawlineseg $p $r $er 0]
5765                     }
5766                 }
5767             } else {
5768                 set lineend($lid) [drawlineseg $lid $r $er 1]
5769             }
5770         }
5771     }
5774 proc undolayout {row} {
5775     global uparrowlen mingaplen downarrowlen
5776     global rowidlist rowisopt rowfinal need_redisplay
5778     set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5779     if {$r < 0} {
5780         set r 0
5781     }
5782     if {[llength $rowidlist] > $r} {
5783         incr r -1
5784         set rowidlist [lrange $rowidlist 0 $r]
5785         set rowfinal [lrange $rowfinal 0 $r]
5786         set rowisopt [lrange $rowisopt 0 $r]
5787         set need_redisplay 1
5788         run drawvisible
5789     }
5792 proc drawvisible {} {
5793     global canv linespc curview vrowmod selectedline targetrow targetid
5794     global need_redisplay cscroll numcommits
5796     set fs [$canv yview]
5797     set ymax [lindex [$canv cget -scrollregion] 3]
5798     if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5799     set f0 [lindex $fs 0]
5800     set f1 [lindex $fs 1]
5801     set y0 [expr {int($f0 * $ymax)}]
5802     set y1 [expr {int($f1 * $ymax)}]
5804     if {[info exists targetid]} {
5805         if {[commitinview $targetid $curview]} {
5806             set r [rowofcommit $targetid]
5807             if {$r != $targetrow} {
5808                 # Fix up the scrollregion and change the scrolling position
5809                 # now that our target row has moved.
5810                 set diff [expr {($r - $targetrow) * $linespc}]
5811                 set targetrow $r
5812                 setcanvscroll
5813                 set ymax [lindex [$canv cget -scrollregion] 3]
5814                 incr y0 $diff
5815                 incr y1 $diff
5816                 set f0 [expr {$y0 / $ymax}]
5817                 set f1 [expr {$y1 / $ymax}]
5818                 allcanvs yview moveto $f0
5819                 $cscroll set $f0 $f1
5820                 set need_redisplay 1
5821             }
5822         } else {
5823             unset targetid
5824         }
5825     }
5827     set row [expr {int(($y0 - 3) / $linespc) - 1}]
5828     set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5829     if {$endrow >= $vrowmod($curview)} {
5830         update_arcrows $curview
5831     }
5832     if {$selectedline ne {} &&
5833         $row <= $selectedline && $selectedline <= $endrow} {
5834         set targetrow $selectedline
5835     } elseif {[info exists targetid]} {
5836         set targetrow [expr {int(($row + $endrow) / 2)}]
5837     }
5838     if {[info exists targetrow]} {
5839         if {$targetrow >= $numcommits} {
5840             set targetrow [expr {$numcommits - 1}]
5841         }
5842         set targetid [commitonrow $targetrow]
5843     }
5844     drawcommits $row $endrow
5847 proc clear_display {} {
5848     global iddrawn linesegs need_redisplay nrows_drawn
5849     global vhighlights fhighlights nhighlights rhighlights
5850     global linehtag linentag linedtag boldids boldnameids
5852     allcanvs delete all
5853     catch {unset iddrawn}
5854     catch {unset linesegs}
5855     catch {unset linehtag}
5856     catch {unset linentag}
5857     catch {unset linedtag}
5858     set boldids {}
5859     set boldnameids {}
5860     catch {unset vhighlights}
5861     catch {unset fhighlights}
5862     catch {unset nhighlights}
5863     catch {unset rhighlights}
5864     set need_redisplay 0
5865     set nrows_drawn 0
5868 proc findcrossings {id} {
5869     global rowidlist parentlist numcommits displayorder
5871     set cross {}
5872     set ccross {}
5873     foreach {s e} [rowranges $id] {
5874         if {$e >= $numcommits} {
5875             set e [expr {$numcommits - 1}]
5876         }
5877         if {$e <= $s} continue
5878         for {set row $e} {[incr row -1] >= $s} {} {
5879             set x [lsearch -exact [lindex $rowidlist $row] $id]
5880             if {$x < 0} break
5881             set olds [lindex $parentlist $row]
5882             set kid [lindex $displayorder $row]
5883             set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
5884             if {$kidx < 0} continue
5885             set nextrow [lindex $rowidlist [expr {$row + 1}]]
5886             foreach p $olds {
5887                 set px [lsearch -exact $nextrow $p]
5888                 if {$px < 0} continue
5889                 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
5890                     if {[lsearch -exact $ccross $p] >= 0} continue
5891                     if {$x == $px + ($kidx < $px? -1: 1)} {
5892                         lappend ccross $p
5893                     } elseif {[lsearch -exact $cross $p] < 0} {
5894                         lappend cross $p
5895                     }
5896                 }
5897             }
5898         }
5899     }
5900     return [concat $ccross {{}} $cross]
5903 proc assigncolor {id} {
5904     global colormap colors nextcolor
5905     global parents children children curview
5907     if {[info exists colormap($id)]} return
5908     set ncolors [llength $colors]
5909     if {[info exists children($curview,$id)]} {
5910         set kids $children($curview,$id)
5911     } else {
5912         set kids {}
5913     }
5914     if {[llength $kids] == 1} {
5915         set child [lindex $kids 0]
5916         if {[info exists colormap($child)]
5917             && [llength $parents($curview,$child)] == 1} {
5918             set colormap($id) $colormap($child)
5919             return
5920         }
5921     }
5922     set badcolors {}
5923     set origbad {}
5924     foreach x [findcrossings $id] {
5925         if {$x eq {}} {
5926             # delimiter between corner crossings and other crossings
5927             if {[llength $badcolors] >= $ncolors - 1} break
5928             set origbad $badcolors
5929         }
5930         if {[info exists colormap($x)]
5931             && [lsearch -exact $badcolors $colormap($x)] < 0} {
5932             lappend badcolors $colormap($x)
5933         }
5934     }
5935     if {[llength $badcolors] >= $ncolors} {
5936         set badcolors $origbad
5937     }
5938     set origbad $badcolors
5939     if {[llength $badcolors] < $ncolors - 1} {
5940         foreach child $kids {
5941             if {[info exists colormap($child)]
5942                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
5943                 lappend badcolors $colormap($child)
5944             }
5945             foreach p $parents($curview,$child) {
5946                 if {[info exists colormap($p)]
5947                     && [lsearch -exact $badcolors $colormap($p)] < 0} {
5948                     lappend badcolors $colormap($p)
5949                 }
5950             }
5951         }
5952         if {[llength $badcolors] >= $ncolors} {
5953             set badcolors $origbad
5954         }
5955     }
5956     for {set i 0} {$i <= $ncolors} {incr i} {
5957         set c [lindex $colors $nextcolor]
5958         if {[incr nextcolor] >= $ncolors} {
5959             set nextcolor 0
5960         }
5961         if {[lsearch -exact $badcolors $c]} break
5962     }
5963     set colormap($id) $c
5966 proc bindline {t id} {
5967     global canv
5969     $canv bind $t <Enter> "lineenter %x %y $id"
5970     $canv bind $t <Motion> "linemotion %x %y $id"
5971     $canv bind $t <Leave> "lineleave $id"
5972     $canv bind $t <Button-1> "lineclick %x %y $id 1"
5975 proc drawtags {id x xt y1} {
5976     global idtags idheads idotherrefs mainhead
5977     global linespc lthickness
5978     global canv rowtextx curview fgcolor bgcolor ctxbut
5980     set marks {}
5981     set ntags 0
5982     set nheads 0
5983     if {[info exists idtags($id)]} {
5984         set marks $idtags($id)
5985         set ntags [llength $marks]
5986     }
5987     if {[info exists idheads($id)]} {
5988         set marks [concat $marks $idheads($id)]
5989         set nheads [llength $idheads($id)]
5990     }
5991     if {[info exists idotherrefs($id)]} {
5992         set marks [concat $marks $idotherrefs($id)]
5993     }
5994     if {$marks eq {}} {
5995         return $xt
5996     }
5998     set delta [expr {int(0.5 * ($linespc - $lthickness))}]
5999     set yt [expr {$y1 - 0.5 * $linespc}]
6000     set yb [expr {$yt + $linespc - 1}]
6001     set xvals {}
6002     set wvals {}
6003     set i -1
6004     foreach tag $marks {
6005         incr i
6006         if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6007             set wid [font measure mainfontbold $tag]
6008         } else {
6009             set wid [font measure mainfont $tag]
6010         }
6011         lappend xvals $xt
6012         lappend wvals $wid
6013         set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6014     }
6015     set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6016                -width $lthickness -fill black -tags tag.$id]
6017     $canv lower $t
6018     foreach tag $marks x $xvals wid $wvals {
6019         set xl [expr {$x + $delta}]
6020         set xr [expr {$x + $delta + $wid + $lthickness}]
6021         set font mainfont
6022         if {[incr ntags -1] >= 0} {
6023             # draw a tag
6024             set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6025                        $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6026                        -width 1 -outline black -fill yellow -tags tag.$id]
6027             $canv bind $t <1> [list showtag $tag 1]
6028             set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6029         } else {
6030             # draw a head or other ref
6031             if {[incr nheads -1] >= 0} {
6032                 set col green
6033                 if {$tag eq $mainhead} {
6034                     set font mainfontbold
6035                 }
6036             } else {
6037                 set col "#ddddff"
6038             }
6039             set xl [expr {$xl - $delta/2}]
6040             $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6041                 -width 1 -outline black -fill $col -tags tag.$id
6042             if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6043                 set rwid [font measure mainfont $remoteprefix]
6044                 set xi [expr {$x + 1}]
6045                 set yti [expr {$yt + 1}]
6046                 set xri [expr {$x + $rwid}]
6047                 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6048                         -width 0 -fill "#ffddaa" -tags tag.$id
6049             }
6050         }
6051         set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6052                    -font $font -tags [list tag.$id text]]
6053         if {$ntags >= 0} {
6054             $canv bind $t <1> [list showtag $tag 1]
6055         } elseif {$nheads >= 0} {
6056             $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6057         }
6058     }
6059     return $xt
6062 proc xcoord {i level ln} {
6063     global canvx0 xspc1 xspc2
6065     set x [expr {$canvx0 + $i * $xspc1($ln)}]
6066     if {$i > 0 && $i == $level} {
6067         set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6068     } elseif {$i > $level} {
6069         set x [expr {$x + $xspc2 - $xspc1($ln)}]
6070     }
6071     return $x
6074 proc show_status {msg} {
6075     global canv fgcolor
6077     clear_display
6078     $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6079         -tags text -fill $fgcolor
6082 # Don't change the text pane cursor if it is currently the hand cursor,
6083 # showing that we are over a sha1 ID link.
6084 proc settextcursor {c} {
6085     global ctext curtextcursor
6087     if {[$ctext cget -cursor] == $curtextcursor} {
6088         $ctext config -cursor $c
6089     }
6090     set curtextcursor $c
6093 proc nowbusy {what {name {}}} {
6094     global isbusy busyname statusw
6096     if {[array names isbusy] eq {}} {
6097         . config -cursor watch
6098         settextcursor watch
6099     }
6100     set isbusy($what) 1
6101     set busyname($what) $name
6102     if {$name ne {}} {
6103         $statusw conf -text $name
6104     }
6107 proc notbusy {what} {
6108     global isbusy maincursor textcursor busyname statusw
6110     catch {
6111         unset isbusy($what)
6112         if {$busyname($what) ne {} &&
6113             [$statusw cget -text] eq $busyname($what)} {
6114             $statusw conf -text {}
6115         }
6116     }
6117     if {[array names isbusy] eq {}} {
6118         . config -cursor $maincursor
6119         settextcursor $textcursor
6120     }
6123 proc findmatches {f} {
6124     global findtype findstring
6125     if {$findtype == [mc "Regexp"]} {
6126         set matches [regexp -indices -all -inline $findstring $f]
6127     } else {
6128         set fs $findstring
6129         if {$findtype == [mc "IgnCase"]} {
6130             set f [string tolower $f]
6131             set fs [string tolower $fs]
6132         }
6133         set matches {}
6134         set i 0
6135         set l [string length $fs]
6136         while {[set j [string first $fs $f $i]] >= 0} {
6137             lappend matches [list $j [expr {$j+$l-1}]]
6138             set i [expr {$j + $l}]
6139         }
6140     }
6141     return $matches
6144 proc dofind {{dirn 1} {wrap 1}} {
6145     global findstring findstartline findcurline selectedline numcommits
6146     global gdttype filehighlight fh_serial find_dirn findallowwrap
6148     if {[info exists find_dirn]} {
6149         if {$find_dirn == $dirn} return
6150         stopfinding
6151     }
6152     focus .
6153     if {$findstring eq {} || $numcommits == 0} return
6154     if {$selectedline eq {}} {
6155         set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6156     } else {
6157         set findstartline $selectedline
6158     }
6159     set findcurline $findstartline
6160     nowbusy finding [mc "Searching"]
6161     if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6162         after cancel do_file_hl $fh_serial
6163         do_file_hl $fh_serial
6164     }
6165     set find_dirn $dirn
6166     set findallowwrap $wrap
6167     run findmore
6170 proc stopfinding {} {
6171     global find_dirn findcurline fprogcoord
6173     if {[info exists find_dirn]} {
6174         unset find_dirn
6175         unset findcurline
6176         notbusy finding
6177         set fprogcoord 0
6178         adjustprogress
6179     }
6180     stopblaming
6183 proc findmore {} {
6184     global commitdata commitinfo numcommits findpattern findloc
6185     global findstartline findcurline findallowwrap
6186     global find_dirn gdttype fhighlights fprogcoord
6187     global curview varcorder vrownum varccommits vrowmod
6189     if {![info exists find_dirn]} {
6190         return 0
6191     }
6192     set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6193     set l $findcurline
6194     set moretodo 0
6195     if {$find_dirn > 0} {
6196         incr l
6197         if {$l >= $numcommits} {
6198             set l 0
6199         }
6200         if {$l <= $findstartline} {
6201             set lim [expr {$findstartline + 1}]
6202         } else {
6203             set lim $numcommits
6204             set moretodo $findallowwrap
6205         }
6206     } else {
6207         if {$l == 0} {
6208             set l $numcommits
6209         }
6210         incr l -1
6211         if {$l >= $findstartline} {
6212             set lim [expr {$findstartline - 1}]
6213         } else {
6214             set lim -1
6215             set moretodo $findallowwrap
6216         }
6217     }
6218     set n [expr {($lim - $l) * $find_dirn}]
6219     if {$n > 500} {
6220         set n 500
6221         set moretodo 1
6222     }
6223     if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6224         update_arcrows $curview
6225     }
6226     set found 0
6227     set domore 1
6228     set ai [bsearch $vrownum($curview) $l]
6229     set a [lindex $varcorder($curview) $ai]
6230     set arow [lindex $vrownum($curview) $ai]
6231     set ids [lindex $varccommits($curview,$a)]
6232     set arowend [expr {$arow + [llength $ids]}]
6233     if {$gdttype eq [mc "containing:"]} {
6234         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6235             if {$l < $arow || $l >= $arowend} {
6236                 incr ai $find_dirn
6237                 set a [lindex $varcorder($curview) $ai]
6238                 set arow [lindex $vrownum($curview) $ai]
6239                 set ids [lindex $varccommits($curview,$a)]
6240                 set arowend [expr {$arow + [llength $ids]}]
6241             }
6242             set id [lindex $ids [expr {$l - $arow}]]
6243             # shouldn't happen unless git log doesn't give all the commits...
6244             if {![info exists commitdata($id)] ||
6245                 ![doesmatch $commitdata($id)]} {
6246                 continue
6247             }
6248             if {![info exists commitinfo($id)]} {
6249                 getcommit $id
6250             }
6251             set info $commitinfo($id)
6252             foreach f $info ty $fldtypes {
6253                 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6254                     [doesmatch $f]} {
6255                     set found 1
6256                     break
6257                 }
6258             }
6259             if {$found} break
6260         }
6261     } else {
6262         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6263             if {$l < $arow || $l >= $arowend} {
6264                 incr ai $find_dirn
6265                 set a [lindex $varcorder($curview) $ai]
6266                 set arow [lindex $vrownum($curview) $ai]
6267                 set ids [lindex $varccommits($curview,$a)]
6268                 set arowend [expr {$arow + [llength $ids]}]
6269             }
6270             set id [lindex $ids [expr {$l - $arow}]]
6271             if {![info exists fhighlights($id)]} {
6272                 # this sets fhighlights($id) to -1
6273                 askfilehighlight $l $id
6274             }
6275             if {$fhighlights($id) > 0} {
6276                 set found $domore
6277                 break
6278             }
6279             if {$fhighlights($id) < 0} {
6280                 if {$domore} {
6281                     set domore 0
6282                     set findcurline [expr {$l - $find_dirn}]
6283                 }
6284             }
6285         }
6286     }
6287     if {$found || ($domore && !$moretodo)} {
6288         unset findcurline
6289         unset find_dirn
6290         notbusy finding
6291         set fprogcoord 0
6292         adjustprogress
6293         if {$found} {
6294             findselectline $l
6295         } else {
6296             bell
6297         }
6298         return 0
6299     }
6300     if {!$domore} {
6301         flushhighlights
6302     } else {
6303         set findcurline [expr {$l - $find_dirn}]
6304     }
6305     set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6306     if {$n < 0} {
6307         incr n $numcommits
6308     }
6309     set fprogcoord [expr {$n * 1.0 / $numcommits}]
6310     adjustprogress
6311     return $domore
6314 proc findselectline {l} {
6315     global findloc commentend ctext findcurline markingmatches gdttype
6317     set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6318     set findcurline $l
6319     selectline $l 1
6320     if {$markingmatches &&
6321         ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6322         # highlight the matches in the comments
6323         set f [$ctext get 1.0 $commentend]
6324         set matches [findmatches $f]
6325         foreach match $matches {
6326             set start [lindex $match 0]
6327             set end [expr {[lindex $match 1] + 1}]
6328             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6329         }
6330     }
6331     drawvisible
6334 # mark the bits of a headline or author that match a find string
6335 proc markmatches {canv l str tag matches font row} {
6336     global selectedline
6338     set bbox [$canv bbox $tag]
6339     set x0 [lindex $bbox 0]
6340     set y0 [lindex $bbox 1]
6341     set y1 [lindex $bbox 3]
6342     foreach match $matches {
6343         set start [lindex $match 0]
6344         set end [lindex $match 1]
6345         if {$start > $end} continue
6346         set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6347         set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6348         set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6349                    [expr {$x0+$xlen+2}] $y1 \
6350                    -outline {} -tags [list match$l matches] -fill yellow]
6351         $canv lower $t
6352         if {$row == $selectedline} {
6353             $canv raise $t secsel
6354         }
6355     }
6358 proc unmarkmatches {} {
6359     global markingmatches
6361     allcanvs delete matches
6362     set markingmatches 0
6363     stopfinding
6366 proc selcanvline {w x y} {
6367     global canv canvy0 ctext linespc
6368     global rowtextx
6369     set ymax [lindex [$canv cget -scrollregion] 3]
6370     if {$ymax == {}} return
6371     set yfrac [lindex [$canv yview] 0]
6372     set y [expr {$y + $yfrac * $ymax}]
6373     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6374     if {$l < 0} {
6375         set l 0
6376     }
6377     if {$w eq $canv} {
6378         set xmax [lindex [$canv cget -scrollregion] 2]
6379         set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6380         if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6381     }
6382     unmarkmatches
6383     selectline $l 1
6386 proc commit_descriptor {p} {
6387     global commitinfo
6388     if {![info exists commitinfo($p)]} {
6389         getcommit $p
6390     }
6391     set l "..."
6392     if {[llength $commitinfo($p)] > 1} {
6393         set l [lindex $commitinfo($p) 0]
6394     }
6395     return "$p ($l)\n"
6398 # append some text to the ctext widget, and make any SHA1 ID
6399 # that we know about be a clickable link.
6400 proc appendwithlinks {text tags} {
6401     global ctext linknum curview
6403     set start [$ctext index "end - 1c"]
6404     $ctext insert end $text $tags
6405     set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6406     foreach l $links {
6407         set s [lindex $l 0]
6408         set e [lindex $l 1]
6409         set linkid [string range $text $s $e]
6410         incr e
6411         $ctext tag delete link$linknum
6412         $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6413         setlink $linkid link$linknum
6414         incr linknum
6415     }
6418 proc setlink {id lk} {
6419     global curview ctext pendinglinks
6421     set known 0
6422     if {[string length $id] < 40} {
6423         set matches [longid $id]
6424         if {[llength $matches] > 0} {
6425             if {[llength $matches] > 1} return
6426             set known 1
6427             set id [lindex $matches 0]
6428         }
6429     } else {
6430         set known [commitinview $id $curview]
6431     }
6432     if {$known} {
6433         $ctext tag conf $lk -foreground blue -underline 1
6434         $ctext tag bind $lk <1> [list selbyid $id]
6435         $ctext tag bind $lk <Enter> {linkcursor %W 1}
6436         $ctext tag bind $lk <Leave> {linkcursor %W -1}
6437     } else {
6438         lappend pendinglinks($id) $lk
6439         interestedin $id {makelink %P}
6440     }
6443 proc makelink {id} {
6444     global pendinglinks
6446     if {![info exists pendinglinks($id)]} return
6447     foreach lk $pendinglinks($id) {
6448         setlink $id $lk
6449     }
6450     unset pendinglinks($id)
6453 proc linkcursor {w inc} {
6454     global linkentercount curtextcursor
6456     if {[incr linkentercount $inc] > 0} {
6457         $w configure -cursor hand2
6458     } else {
6459         $w configure -cursor $curtextcursor
6460         if {$linkentercount < 0} {
6461             set linkentercount 0
6462         }
6463     }
6466 proc viewnextline {dir} {
6467     global canv linespc
6469     $canv delete hover
6470     set ymax [lindex [$canv cget -scrollregion] 3]
6471     set wnow [$canv yview]
6472     set wtop [expr {[lindex $wnow 0] * $ymax}]
6473     set newtop [expr {$wtop + $dir * $linespc}]
6474     if {$newtop < 0} {
6475         set newtop 0
6476     } elseif {$newtop > $ymax} {
6477         set newtop $ymax
6478     }
6479     allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6482 # add a list of tag or branch names at position pos
6483 # returns the number of names inserted
6484 proc appendrefs {pos ids var} {
6485     global ctext linknum curview $var maxrefs
6487     if {[catch {$ctext index $pos}]} {
6488         return 0
6489     }
6490     $ctext conf -state normal
6491     $ctext delete $pos "$pos lineend"
6492     set tags {}
6493     foreach id $ids {
6494         foreach tag [set $var\($id\)] {
6495             lappend tags [list $tag $id]
6496         }
6497     }
6498     if {[llength $tags] > $maxrefs} {
6499         $ctext insert $pos "many ([llength $tags])"
6500     } else {
6501         set tags [lsort -index 0 -decreasing $tags]
6502         set sep {}
6503         foreach ti $tags {
6504             set id [lindex $ti 1]
6505             set lk link$linknum
6506             incr linknum
6507             $ctext tag delete $lk
6508             $ctext insert $pos $sep
6509             $ctext insert $pos [lindex $ti 0] $lk
6510             setlink $id $lk
6511             set sep ", "
6512         }
6513     }
6514     $ctext conf -state disabled
6515     return [llength $tags]
6518 # called when we have finished computing the nearby tags
6519 proc dispneartags {delay} {
6520     global selectedline currentid showneartags tagphase
6522     if {$selectedline eq {} || !$showneartags} return
6523     after cancel dispnexttag
6524     if {$delay} {
6525         after 200 dispnexttag
6526         set tagphase -1
6527     } else {
6528         after idle dispnexttag
6529         set tagphase 0
6530     }
6533 proc dispnexttag {} {
6534     global selectedline currentid showneartags tagphase ctext
6536     if {$selectedline eq {} || !$showneartags} return
6537     switch -- $tagphase {
6538         0 {
6539             set dtags [desctags $currentid]
6540             if {$dtags ne {}} {
6541                 appendrefs precedes $dtags idtags
6542             }
6543         }
6544         1 {
6545             set atags [anctags $currentid]
6546             if {$atags ne {}} {
6547                 appendrefs follows $atags idtags
6548             }
6549         }
6550         2 {
6551             set dheads [descheads $currentid]
6552             if {$dheads ne {}} {
6553                 if {[appendrefs branch $dheads idheads] > 1
6554                     && [$ctext get "branch -3c"] eq "h"} {
6555                     # turn "Branch" into "Branches"
6556                     $ctext conf -state normal
6557                     $ctext insert "branch -2c" "es"
6558                     $ctext conf -state disabled
6559                 }
6560             }
6561         }
6562     }
6563     if {[incr tagphase] <= 2} {
6564         after idle dispnexttag
6565     }
6568 proc make_secsel {id} {
6569     global linehtag linentag linedtag canv canv2 canv3
6571     if {![info exists linehtag($id)]} return
6572     $canv delete secsel
6573     set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6574                -tags secsel -fill [$canv cget -selectbackground]]
6575     $canv lower $t
6576     $canv2 delete secsel
6577     set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6578                -tags secsel -fill [$canv2 cget -selectbackground]]
6579     $canv2 lower $t
6580     $canv3 delete secsel
6581     set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6582                -tags secsel -fill [$canv3 cget -selectbackground]]
6583     $canv3 lower $t
6586 proc selectline {l isnew {desired_loc {}}} {
6587     global canv ctext commitinfo selectedline
6588     global canvy0 linespc parents children curview
6589     global currentid sha1entry
6590     global commentend idtags linknum
6591     global mergemax numcommits pending_select
6592     global cmitmode showneartags allcommits
6593     global targetrow targetid lastscrollrows
6594     global autoselect jump_to_here
6596     catch {unset pending_select}
6597     $canv delete hover
6598     normalline
6599     unsel_reflist
6600     stopfinding
6601     if {$l < 0 || $l >= $numcommits} return
6602     set id [commitonrow $l]
6603     set targetid $id
6604     set targetrow $l
6605     set selectedline $l
6606     set currentid $id
6607     if {$lastscrollrows < $numcommits} {
6608         setcanvscroll
6609     }
6611     set y [expr {$canvy0 + $l * $linespc}]
6612     set ymax [lindex [$canv cget -scrollregion] 3]
6613     set ytop [expr {$y - $linespc - 1}]
6614     set ybot [expr {$y + $linespc + 1}]
6615     set wnow [$canv yview]
6616     set wtop [expr {[lindex $wnow 0] * $ymax}]
6617     set wbot [expr {[lindex $wnow 1] * $ymax}]
6618     set wh [expr {$wbot - $wtop}]
6619     set newtop $wtop
6620     if {$ytop < $wtop} {
6621         if {$ybot < $wtop} {
6622             set newtop [expr {$y - $wh / 2.0}]
6623         } else {
6624             set newtop $ytop
6625             if {$newtop > $wtop - $linespc} {
6626                 set newtop [expr {$wtop - $linespc}]
6627             }
6628         }
6629     } elseif {$ybot > $wbot} {
6630         if {$ytop > $wbot} {
6631             set newtop [expr {$y - $wh / 2.0}]
6632         } else {
6633             set newtop [expr {$ybot - $wh}]
6634             if {$newtop < $wtop + $linespc} {
6635                 set newtop [expr {$wtop + $linespc}]
6636             }
6637         }
6638     }
6639     if {$newtop != $wtop} {
6640         if {$newtop < 0} {
6641             set newtop 0
6642         }
6643         allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6644         drawvisible
6645     }
6647     make_secsel $id
6649     if {$isnew} {
6650         addtohistory [list selbyid $id]
6651     }
6653     $sha1entry delete 0 end
6654     $sha1entry insert 0 $id
6655     if {$autoselect} {
6656         $sha1entry selection from 0
6657         $sha1entry selection to end
6658     }
6659     rhighlight_sel $id
6661     $ctext conf -state normal
6662     clear_ctext
6663     set linknum 0
6664     if {![info exists commitinfo($id)]} {
6665         getcommit $id
6666     }
6667     set info $commitinfo($id)
6668     set date [formatdate [lindex $info 2]]
6669     $ctext insert end "[mc "Author"]: [lindex $info 1]  $date\n"
6670     set date [formatdate [lindex $info 4]]
6671     $ctext insert end "[mc "Committer"]: [lindex $info 3]  $date\n"
6672     if {[info exists idtags($id)]} {
6673         $ctext insert end [mc "Tags:"]
6674         foreach tag $idtags($id) {
6675             $ctext insert end " $tag"
6676         }
6677         $ctext insert end "\n"
6678     }
6680     set headers {}
6681     set olds $parents($curview,$id)
6682     if {[llength $olds] > 1} {
6683         set np 0
6684         foreach p $olds {
6685             if {$np >= $mergemax} {
6686                 set tag mmax
6687             } else {
6688                 set tag m$np
6689             }
6690             $ctext insert end "[mc "Parent"]: " $tag
6691             appendwithlinks [commit_descriptor $p] {}
6692             incr np
6693         }
6694     } else {
6695         foreach p $olds {
6696             append headers "[mc "Parent"]: [commit_descriptor $p]"
6697         }
6698     }
6700     foreach c $children($curview,$id) {
6701         append headers "[mc "Child"]:  [commit_descriptor $c]"
6702     }
6704     # make anything that looks like a SHA1 ID be a clickable link
6705     appendwithlinks $headers {}
6706     if {$showneartags} {
6707         if {![info exists allcommits]} {
6708             getallcommits
6709         }
6710         $ctext insert end "[mc "Branch"]: "
6711         $ctext mark set branch "end -1c"
6712         $ctext mark gravity branch left
6713         $ctext insert end "\n[mc "Follows"]: "
6714         $ctext mark set follows "end -1c"
6715         $ctext mark gravity follows left
6716         $ctext insert end "\n[mc "Precedes"]: "
6717         $ctext mark set precedes "end -1c"
6718         $ctext mark gravity precedes left
6719         $ctext insert end "\n"
6720         dispneartags 1
6721     }
6722     $ctext insert end "\n"
6723     set comment [lindex $info 5]
6724     if {[string first "\r" $comment] >= 0} {
6725         set comment [string map {"\r" "\n    "} $comment]
6726     }
6727     appendwithlinks $comment {comment}
6729     $ctext tag remove found 1.0 end
6730     $ctext conf -state disabled
6731     set commentend [$ctext index "end - 1c"]
6733     set jump_to_here $desired_loc
6734     init_flist [mc "Comments"]
6735     if {$cmitmode eq "tree"} {
6736         gettree $id
6737     } elseif {[llength $olds] <= 1} {
6738         startdiff $id
6739     } else {
6740         mergediff $id
6741     }
6744 proc selfirstline {} {
6745     unmarkmatches
6746     selectline 0 1
6749 proc sellastline {} {
6750     global numcommits
6751     unmarkmatches
6752     set l [expr {$numcommits - 1}]
6753     selectline $l 1
6756 proc selnextline {dir} {
6757     global selectedline
6758     focus .
6759     if {$selectedline eq {}} return
6760     set l [expr {$selectedline + $dir}]
6761     unmarkmatches
6762     selectline $l 1
6765 proc selnextpage {dir} {
6766     global canv linespc selectedline numcommits
6768     set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6769     if {$lpp < 1} {
6770         set lpp 1
6771     }
6772     allcanvs yview scroll [expr {$dir * $lpp}] units
6773     drawvisible
6774     if {$selectedline eq {}} return
6775     set l [expr {$selectedline + $dir * $lpp}]
6776     if {$l < 0} {
6777         set l 0
6778     } elseif {$l >= $numcommits} {
6779         set l [expr $numcommits - 1]
6780     }
6781     unmarkmatches
6782     selectline $l 1
6785 proc unselectline {} {
6786     global selectedline currentid
6788     set selectedline {}
6789     catch {unset currentid}
6790     allcanvs delete secsel
6791     rhighlight_none
6794 proc reselectline {} {
6795     global selectedline
6797     if {$selectedline ne {}} {
6798         selectline $selectedline 0
6799     }
6802 proc addtohistory {cmd} {
6803     global history historyindex curview
6805     set elt [list $curview $cmd]
6806     if {$historyindex > 0
6807         && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6808         return
6809     }
6811     if {$historyindex < [llength $history]} {
6812         set history [lreplace $history $historyindex end $elt]
6813     } else {
6814         lappend history $elt
6815     }
6816     incr historyindex
6817     if {$historyindex > 1} {
6818         .tf.bar.leftbut conf -state normal
6819     } else {
6820         .tf.bar.leftbut conf -state disabled
6821     }
6822     .tf.bar.rightbut conf -state disabled
6825 proc godo {elt} {
6826     global curview
6828     set view [lindex $elt 0]
6829     set cmd [lindex $elt 1]
6830     if {$curview != $view} {
6831         showview $view
6832     }
6833     eval $cmd
6836 proc goback {} {
6837     global history historyindex
6838     focus .
6840     if {$historyindex > 1} {
6841         incr historyindex -1
6842         godo [lindex $history [expr {$historyindex - 1}]]
6843         .tf.bar.rightbut conf -state normal
6844     }
6845     if {$historyindex <= 1} {
6846         .tf.bar.leftbut conf -state disabled
6847     }
6850 proc goforw {} {
6851     global history historyindex
6852     focus .
6854     if {$historyindex < [llength $history]} {
6855         set cmd [lindex $history $historyindex]
6856         incr historyindex
6857         godo $cmd
6858         .tf.bar.leftbut conf -state normal
6859     }
6860     if {$historyindex >= [llength $history]} {
6861         .tf.bar.rightbut conf -state disabled
6862     }
6865 proc gettree {id} {
6866     global treefilelist treeidlist diffids diffmergeid treepending
6867     global nullid nullid2
6869     set diffids $id
6870     catch {unset diffmergeid}
6871     if {![info exists treefilelist($id)]} {
6872         if {![info exists treepending]} {
6873             if {$id eq $nullid} {
6874                 set cmd [list | git ls-files]
6875             } elseif {$id eq $nullid2} {
6876                 set cmd [list | git ls-files --stage -t]
6877             } else {
6878                 set cmd [list | git ls-tree -r $id]
6879             }
6880             if {[catch {set gtf [open $cmd r]}]} {
6881                 return
6882             }
6883             set treepending $id
6884             set treefilelist($id) {}
6885             set treeidlist($id) {}
6886             fconfigure $gtf -blocking 0 -encoding binary
6887             filerun $gtf [list gettreeline $gtf $id]
6888         }
6889     } else {
6890         setfilelist $id
6891     }
6894 proc gettreeline {gtf id} {
6895     global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
6897     set nl 0
6898     while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
6899         if {$diffids eq $nullid} {
6900             set fname $line
6901         } else {
6902             set i [string first "\t" $line]
6903             if {$i < 0} continue
6904             set fname [string range $line [expr {$i+1}] end]
6905             set line [string range $line 0 [expr {$i-1}]]
6906             if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
6907             set sha1 [lindex $line 2]
6908             lappend treeidlist($id) $sha1
6909         }
6910         if {[string index $fname 0] eq "\""} {
6911             set fname [lindex $fname 0]
6912         }
6913         set fname [encoding convertfrom $fname]
6914         lappend treefilelist($id) $fname
6915     }
6916     if {![eof $gtf]} {
6917         return [expr {$nl >= 1000? 2: 1}]
6918     }
6919     close $gtf
6920     unset treepending
6921     if {$cmitmode ne "tree"} {
6922         if {![info exists diffmergeid]} {
6923             gettreediffs $diffids
6924         }
6925     } elseif {$id ne $diffids} {
6926         gettree $diffids
6927     } else {
6928         setfilelist $id
6929     }
6930     return 0
6933 proc showfile {f} {
6934     global treefilelist treeidlist diffids nullid nullid2
6935     global ctext_file_names ctext_file_lines
6936     global ctext commentend
6938     set i [lsearch -exact $treefilelist($diffids) $f]
6939     if {$i < 0} {
6940         puts "oops, $f not in list for id $diffids"
6941         return
6942     }
6943     if {$diffids eq $nullid} {
6944         if {[catch {set bf [open $f r]} err]} {
6945             puts "oops, can't read $f: $err"
6946             return
6947         }
6948     } else {
6949         set blob [lindex $treeidlist($diffids) $i]
6950         if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
6951             puts "oops, error reading blob $blob: $err"
6952             return
6953         }
6954     }
6955     fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
6956     filerun $bf [list getblobline $bf $diffids]
6957     $ctext config -state normal
6958     clear_ctext $commentend
6959     lappend ctext_file_names $f
6960     lappend ctext_file_lines [lindex [split $commentend "."] 0]
6961     $ctext insert end "\n"
6962     $ctext insert end "$f\n" filesep
6963     $ctext config -state disabled
6964     $ctext yview $commentend
6965     settabs 0
6968 proc getblobline {bf id} {
6969     global diffids cmitmode ctext
6971     if {$id ne $diffids || $cmitmode ne "tree"} {
6972         catch {close $bf}
6973         return 0
6974     }
6975     $ctext config -state normal
6976     set nl 0
6977     while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
6978         $ctext insert end "$line\n"
6979     }
6980     if {[eof $bf]} {
6981         global jump_to_here ctext_file_names commentend
6983         # delete last newline
6984         $ctext delete "end - 2c" "end - 1c"
6985         close $bf
6986         if {$jump_to_here ne {} &&
6987             [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
6988             set lnum [expr {[lindex $jump_to_here 1] +
6989                             [lindex [split $commentend .] 0]}]
6990             mark_ctext_line $lnum
6991         }
6992         return 0
6993     }
6994     $ctext config -state disabled
6995     return [expr {$nl >= 1000? 2: 1}]
6998 proc mark_ctext_line {lnum} {
6999     global ctext markbgcolor
7001     $ctext tag delete omark
7002     $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7003     $ctext tag conf omark -background $markbgcolor
7004     $ctext see $lnum.0
7007 proc mergediff {id} {
7008     global diffmergeid
7009     global diffids treediffs
7010     global parents curview
7012     set diffmergeid $id
7013     set diffids $id
7014     set treediffs($id) {}
7015     set np [llength $parents($curview,$id)]
7016     settabs $np
7017     getblobdiffs $id
7020 proc startdiff {ids} {
7021     global treediffs diffids treepending diffmergeid nullid nullid2
7023     settabs 1
7024     set diffids $ids
7025     catch {unset diffmergeid}
7026     if {![info exists treediffs($ids)] ||
7027         [lsearch -exact $ids $nullid] >= 0 ||
7028         [lsearch -exact $ids $nullid2] >= 0} {
7029         if {![info exists treepending]} {
7030             gettreediffs $ids
7031         }
7032     } else {
7033         addtocflist $ids
7034     }
7037 proc path_filter {filter name} {
7038     foreach p $filter {
7039         set l [string length $p]
7040         if {[string index $p end] eq "/"} {
7041             if {[string compare -length $l $p $name] == 0} {
7042                 return 1
7043             }
7044         } else {
7045             if {[string compare -length $l $p $name] == 0 &&
7046                 ([string length $name] == $l ||
7047                  [string index $name $l] eq "/")} {
7048                 return 1
7049             }
7050         }
7051     }
7052     return 0
7055 proc addtocflist {ids} {
7056     global treediffs
7058     add_flist $treediffs($ids)
7059     getblobdiffs $ids
7062 proc diffcmd {ids flags} {
7063     global nullid nullid2
7065     set i [lsearch -exact $ids $nullid]
7066     set j [lsearch -exact $ids $nullid2]
7067     if {$i >= 0} {
7068         if {[llength $ids] > 1 && $j < 0} {
7069             # comparing working directory with some specific revision
7070             set cmd [concat | git diff-index $flags]
7071             if {$i == 0} {
7072                 lappend cmd -R [lindex $ids 1]
7073             } else {
7074                 lappend cmd [lindex $ids 0]
7075             }
7076         } else {
7077             # comparing working directory with index
7078             set cmd [concat | git diff-files $flags]
7079             if {$j == 1} {
7080                 lappend cmd -R
7081             }
7082         }
7083     } elseif {$j >= 0} {
7084         set cmd [concat | git diff-index --cached $flags]
7085         if {[llength $ids] > 1} {
7086             # comparing index with specific revision
7087             if {$i == 0} {
7088                 lappend cmd -R [lindex $ids 1]
7089             } else {
7090                 lappend cmd [lindex $ids 0]
7091             }
7092         } else {
7093             # comparing index with HEAD
7094             lappend cmd HEAD
7095         }
7096     } else {
7097         set cmd [concat | git diff-tree -r $flags $ids]
7098     }
7099     return $cmd
7102 proc gettreediffs {ids} {
7103     global treediff treepending
7105     if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7107     set treepending $ids
7108     set treediff {}
7109     fconfigure $gdtf -blocking 0 -encoding binary
7110     filerun $gdtf [list gettreediffline $gdtf $ids]
7113 proc gettreediffline {gdtf ids} {
7114     global treediff treediffs treepending diffids diffmergeid
7115     global cmitmode vfilelimit curview limitdiffs perfile_attrs
7117     set nr 0
7118     set sublist {}
7119     set max 1000
7120     if {$perfile_attrs} {
7121         # cache_gitattr is slow, and even slower on win32 where we
7122         # have to invoke it for only about 30 paths at a time
7123         set max 500
7124         if {[tk windowingsystem] == "win32"} {
7125             set max 120
7126         }
7127     }
7128     while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7129         set i [string first "\t" $line]
7130         if {$i >= 0} {
7131             set file [string range $line [expr {$i+1}] end]
7132             if {[string index $file 0] eq "\""} {
7133                 set file [lindex $file 0]
7134             }
7135             set file [encoding convertfrom $file]
7136             if {$file ne [lindex $treediff end]} {
7137                 lappend treediff $file
7138                 lappend sublist $file
7139             }
7140         }
7141     }
7142     if {$perfile_attrs} {
7143         cache_gitattr encoding $sublist
7144     }
7145     if {![eof $gdtf]} {
7146         return [expr {$nr >= $max? 2: 1}]
7147     }
7148     close $gdtf
7149     if {$limitdiffs && $vfilelimit($curview) ne {}} {
7150         set flist {}
7151         foreach f $treediff {
7152             if {[path_filter $vfilelimit($curview) $f]} {
7153                 lappend flist $f
7154             }
7155         }
7156         set treediffs($ids) $flist
7157     } else {
7158         set treediffs($ids) $treediff
7159     }
7160     unset treepending
7161     if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7162         gettree $diffids
7163     } elseif {$ids != $diffids} {
7164         if {![info exists diffmergeid]} {
7165             gettreediffs $diffids
7166         }
7167     } else {
7168         addtocflist $ids
7169     }
7170     return 0
7173 # empty string or positive integer
7174 proc diffcontextvalidate {v} {
7175     return [regexp {^(|[1-9][0-9]*)$} $v]
7178 proc diffcontextchange {n1 n2 op} {
7179     global diffcontextstring diffcontext
7181     if {[string is integer -strict $diffcontextstring]} {
7182         if {$diffcontextstring > 0} {
7183             set diffcontext $diffcontextstring
7184             reselectline
7185         }
7186     }
7189 proc changeignorespace {} {
7190     reselectline
7193 proc getblobdiffs {ids} {
7194     global blobdifffd diffids env
7195     global diffinhdr treediffs
7196     global diffcontext
7197     global ignorespace
7198     global limitdiffs vfilelimit curview
7199     global diffencoding targetline diffnparents
7201     set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7202     if {$ignorespace} {
7203         append cmd " -w"
7204     }
7205     if {$limitdiffs && $vfilelimit($curview) ne {}} {
7206         set cmd [concat $cmd -- $vfilelimit($curview)]
7207     }
7208     if {[catch {set bdf [open $cmd r]} err]} {
7209         error_popup [mc "Error getting diffs: %s" $err]
7210         return
7211     }
7212     set targetline {}
7213     set diffnparents 0
7214     set diffinhdr 0
7215     set diffencoding [get_path_encoding {}]
7216     fconfigure $bdf -blocking 0 -encoding binary
7217     set blobdifffd($ids) $bdf
7218     filerun $bdf [list getblobdiffline $bdf $diffids]
7221 proc setinlist {var i val} {
7222     global $var
7224     while {[llength [set $var]] < $i} {
7225         lappend $var {}
7226     }
7227     if {[llength [set $var]] == $i} {
7228         lappend $var $val
7229     } else {
7230         lset $var $i $val
7231     }
7234 proc makediffhdr {fname ids} {
7235     global ctext curdiffstart treediffs diffencoding
7236     global ctext_file_names jump_to_here targetline diffline
7238     set fname [encoding convertfrom $fname]
7239     set diffencoding [get_path_encoding $fname]
7240     set i [lsearch -exact $treediffs($ids) $fname]
7241     if {$i >= 0} {
7242         setinlist difffilestart $i $curdiffstart
7243     }
7244     lset ctext_file_names end $fname
7245     set l [expr {(78 - [string length $fname]) / 2}]
7246     set pad [string range "----------------------------------------" 1 $l]
7247     $ctext insert $curdiffstart "$pad $fname $pad" filesep
7248     set targetline {}
7249     if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7250         set targetline [lindex $jump_to_here 1]
7251     }
7252     set diffline 0
7255 proc getblobdiffline {bdf ids} {
7256     global diffids blobdifffd ctext curdiffstart
7257     global diffnexthead diffnextnote difffilestart
7258     global ctext_file_names ctext_file_lines
7259     global diffinhdr treediffs mergemax diffnparents
7260     global diffencoding jump_to_here targetline diffline
7262     set nr 0
7263     $ctext conf -state normal
7264     while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7265         if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7266             close $bdf
7267             return 0
7268         }
7269         if {![string compare -length 5 "diff " $line]} {
7270             if {![regexp {^diff (--cc|--git) } $line m type]} {
7271                 set line [encoding convertfrom $line]
7272                 $ctext insert end "$line\n" hunksep
7273                 continue
7274             }
7275             # start of a new file
7276             set diffinhdr 1
7277             $ctext insert end "\n"
7278             set curdiffstart [$ctext index "end - 1c"]
7279             lappend ctext_file_names ""
7280             lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7281             $ctext insert end "\n" filesep
7283             if {$type eq "--cc"} {
7284                 # start of a new file in a merge diff
7285                 set fname [string range $line 10 end]
7286                 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7287                     lappend treediffs($ids) $fname
7288                     add_flist [list $fname]
7289                 }
7291             } else {
7292                 set line [string range $line 11 end]
7293                 # If the name hasn't changed the length will be odd,
7294                 # the middle char will be a space, and the two bits either
7295                 # side will be a/name and b/name, or "a/name" and "b/name".
7296                 # If the name has changed we'll get "rename from" and
7297                 # "rename to" or "copy from" and "copy to" lines following
7298                 # this, and we'll use them to get the filenames.
7299                 # This complexity is necessary because spaces in the
7300                 # filename(s) don't get escaped.
7301                 set l [string length $line]
7302                 set i [expr {$l / 2}]
7303                 if {!(($l & 1) && [string index $line $i] eq " " &&
7304                       [string range $line 2 [expr {$i - 1}]] eq \
7305                           [string range $line [expr {$i + 3}] end])} {
7306                     continue
7307                 }
7308                 # unescape if quoted and chop off the a/ from the front
7309                 if {[string index $line 0] eq "\""} {
7310                     set fname [string range [lindex $line 0] 2 end]
7311                 } else {
7312                     set fname [string range $line 2 [expr {$i - 1}]]
7313                 }
7314             }
7315             makediffhdr $fname $ids
7317         } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7318             set fname [encoding convertfrom [string range $line 16 end]]
7319             $ctext insert end "\n"
7320             set curdiffstart [$ctext index "end - 1c"]
7321             lappend ctext_file_names $fname
7322             lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7323             $ctext insert end "$line\n" filesep
7324             set i [lsearch -exact $treediffs($ids) $fname]
7325             if {$i >= 0} {
7326                 setinlist difffilestart $i $curdiffstart
7327             }
7329         } elseif {![string compare -length 2 "@@" $line]} {
7330             regexp {^@@+} $line ats
7331             set line [encoding convertfrom $diffencoding $line]
7332             $ctext insert end "$line\n" hunksep
7333             if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7334                 set diffline $nl
7335             }
7336             set diffnparents [expr {[string length $ats] - 1}]
7337             set diffinhdr 0
7339         } elseif {$diffinhdr} {
7340             if {![string compare -length 12 "rename from " $line]} {
7341                 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7342                 if {[string index $fname 0] eq "\""} {
7343                     set fname [lindex $fname 0]
7344                 }
7345                 set fname [encoding convertfrom $fname]
7346                 set i [lsearch -exact $treediffs($ids) $fname]
7347                 if {$i >= 0} {
7348                     setinlist difffilestart $i $curdiffstart
7349                 }
7350             } elseif {![string compare -length 10 $line "rename to "] ||
7351                       ![string compare -length 8 $line "copy to "]} {
7352                 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7353                 if {[string index $fname 0] eq "\""} {
7354                     set fname [lindex $fname 0]
7355                 }
7356                 makediffhdr $fname $ids
7357             } elseif {[string compare -length 3 $line "---"] == 0} {
7358                 # do nothing
7359                 continue
7360             } elseif {[string compare -length 3 $line "+++"] == 0} {
7361                 set diffinhdr 0
7362                 continue
7363             }
7364             $ctext insert end "$line\n" filesep
7366         } else {
7367             set line [encoding convertfrom $diffencoding $line]
7368             # parse the prefix - one ' ', '-' or '+' for each parent
7369             set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7370             set tag [expr {$diffnparents > 1? "m": "d"}]
7371             if {[string trim $prefix " -+"] eq {}} {
7372                 # prefix only has " ", "-" and "+" in it: normal diff line
7373                 set num [string first "-" $prefix]
7374                 if {$num >= 0} {
7375                     # removed line, first parent with line is $num
7376                     if {$num >= $mergemax} {
7377                         set num "max"
7378                     }
7379                     $ctext insert end "$line\n" $tag$num
7380                 } else {
7381                     set tags {}
7382                     if {[string first "+" $prefix] >= 0} {
7383                         # added line
7384                         lappend tags ${tag}result
7385                         if {$diffnparents > 1} {
7386                             set num [string first " " $prefix]
7387                             if {$num >= 0} {
7388                                 if {$num >= $mergemax} {
7389                                     set num "max"
7390                                 }
7391                                 lappend tags m$num
7392                             }
7393                         }
7394                     }
7395                     if {$targetline ne {}} {
7396                         if {$diffline == $targetline} {
7397                             set seehere [$ctext index "end - 1 chars"]
7398                             set targetline {}
7399                         } else {
7400                             incr diffline
7401                         }
7402                     }
7403                     $ctext insert end "$line\n" $tags
7404                 }
7405             } else {
7406                 # "\ No newline at end of file",
7407                 # or something else we don't recognize
7408                 $ctext insert end "$line\n" hunksep
7409             }
7410         }
7411     }
7412     if {[info exists seehere]} {
7413         mark_ctext_line [lindex [split $seehere .] 0]
7414     }
7415     $ctext conf -state disabled
7416     if {[eof $bdf]} {
7417         close $bdf
7418         return 0
7419     }
7420     return [expr {$nr >= 1000? 2: 1}]
7423 proc changediffdisp {} {
7424     global ctext diffelide
7426     $ctext tag conf d0 -elide [lindex $diffelide 0]
7427     $ctext tag conf dresult -elide [lindex $diffelide 1]
7430 proc highlightfile {loc cline} {
7431     global ctext cflist cflist_top
7433     $ctext yview $loc
7434     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7435     $cflist tag add highlight $cline.0 "$cline.0 lineend"
7436     $cflist see $cline.0
7437     set cflist_top $cline
7440 proc prevfile {} {
7441     global difffilestart ctext cmitmode
7443     if {$cmitmode eq "tree"} return
7444     set prev 0.0
7445     set prevline 1
7446     set here [$ctext index @0,0]
7447     foreach loc $difffilestart {
7448         if {[$ctext compare $loc >= $here]} {
7449             highlightfile $prev $prevline
7450             return
7451         }
7452         set prev $loc
7453         incr prevline
7454     }
7455     highlightfile $prev $prevline
7458 proc nextfile {} {
7459     global difffilestart ctext cmitmode
7461     if {$cmitmode eq "tree"} return
7462     set here [$ctext index @0,0]
7463     set line 1
7464     foreach loc $difffilestart {
7465         incr line
7466         if {[$ctext compare $loc > $here]} {
7467             highlightfile $loc $line
7468             return
7469         }
7470     }
7473 proc clear_ctext {{first 1.0}} {
7474     global ctext smarktop smarkbot
7475     global ctext_file_names ctext_file_lines
7476     global pendinglinks
7478     set l [lindex [split $first .] 0]
7479     if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7480         set smarktop $l
7481     }
7482     if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7483         set smarkbot $l
7484     }
7485     $ctext delete $first end
7486     if {$first eq "1.0"} {
7487         catch {unset pendinglinks}
7488     }
7489     set ctext_file_names {}
7490     set ctext_file_lines {}
7493 proc settabs {{firstab {}}} {
7494     global firsttabstop tabstop ctext have_tk85
7496     if {$firstab ne {} && $have_tk85} {
7497         set firsttabstop $firstab
7498     }
7499     set w [font measure textfont "0"]
7500     if {$firsttabstop != 0} {
7501         $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7502                                [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7503     } elseif {$have_tk85 || $tabstop != 8} {
7504         $ctext conf -tabs [expr {$tabstop * $w}]
7505     } else {
7506         $ctext conf -tabs {}
7507     }
7510 proc incrsearch {name ix op} {
7511     global ctext searchstring searchdirn
7513     $ctext tag remove found 1.0 end
7514     if {[catch {$ctext index anchor}]} {
7515         # no anchor set, use start of selection, or of visible area
7516         set sel [$ctext tag ranges sel]
7517         if {$sel ne {}} {
7518             $ctext mark set anchor [lindex $sel 0]
7519         } elseif {$searchdirn eq "-forwards"} {
7520             $ctext mark set anchor @0,0
7521         } else {
7522             $ctext mark set anchor @0,[winfo height $ctext]
7523         }
7524     }
7525     if {$searchstring ne {}} {
7526         set here [$ctext search $searchdirn -- $searchstring anchor]
7527         if {$here ne {}} {
7528             $ctext see $here
7529         }
7530         searchmarkvisible 1
7531     }
7534 proc dosearch {} {
7535     global sstring ctext searchstring searchdirn
7537     focus $sstring
7538     $sstring icursor end
7539     set searchdirn -forwards
7540     if {$searchstring ne {}} {
7541         set sel [$ctext tag ranges sel]
7542         if {$sel ne {}} {
7543             set start "[lindex $sel 0] + 1c"
7544         } elseif {[catch {set start [$ctext index anchor]}]} {
7545             set start "@0,0"
7546         }
7547         set match [$ctext search -count mlen -- $searchstring $start]
7548         $ctext tag remove sel 1.0 end
7549         if {$match eq {}} {
7550             bell
7551             return
7552         }
7553         $ctext see $match
7554         set mend "$match + $mlen c"
7555         $ctext tag add sel $match $mend
7556         $ctext mark unset anchor
7557     }
7560 proc dosearchback {} {
7561     global sstring ctext searchstring searchdirn
7563     focus $sstring
7564     $sstring icursor end
7565     set searchdirn -backwards
7566     if {$searchstring ne {}} {
7567         set sel [$ctext tag ranges sel]
7568         if {$sel ne {}} {
7569             set start [lindex $sel 0]
7570         } elseif {[catch {set start [$ctext index anchor]}]} {
7571             set start @0,[winfo height $ctext]
7572         }
7573         set match [$ctext search -backwards -count ml -- $searchstring $start]
7574         $ctext tag remove sel 1.0 end
7575         if {$match eq {}} {
7576             bell
7577             return
7578         }
7579         $ctext see $match
7580         set mend "$match + $ml c"
7581         $ctext tag add sel $match $mend
7582         $ctext mark unset anchor
7583     }
7586 proc searchmark {first last} {
7587     global ctext searchstring
7589     set mend $first.0
7590     while {1} {
7591         set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7592         if {$match eq {}} break
7593         set mend "$match + $mlen c"
7594         $ctext tag add found $match $mend
7595     }
7598 proc searchmarkvisible {doall} {
7599     global ctext smarktop smarkbot
7601     set topline [lindex [split [$ctext index @0,0] .] 0]
7602     set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7603     if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7604         # no overlap with previous
7605         searchmark $topline $botline
7606         set smarktop $topline
7607         set smarkbot $botline
7608     } else {
7609         if {$topline < $smarktop} {
7610             searchmark $topline [expr {$smarktop-1}]
7611             set smarktop $topline
7612         }
7613         if {$botline > $smarkbot} {
7614             searchmark [expr {$smarkbot+1}] $botline
7615             set smarkbot $botline
7616         }
7617     }
7620 proc scrolltext {f0 f1} {
7621     global searchstring
7623     .bleft.bottom.sb set $f0 $f1
7624     if {$searchstring ne {}} {
7625         searchmarkvisible 0
7626     }
7629 proc setcoords {} {
7630     global linespc charspc canvx0 canvy0
7631     global xspc1 xspc2 lthickness
7633     set linespc [font metrics mainfont -linespace]
7634     set charspc [font measure mainfont "m"]
7635     set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7636     set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7637     set lthickness [expr {int($linespc / 9) + 1}]
7638     set xspc1(0) $linespc
7639     set xspc2 $linespc
7642 proc redisplay {} {
7643     global canv
7644     global selectedline
7646     set ymax [lindex [$canv cget -scrollregion] 3]
7647     if {$ymax eq {} || $ymax == 0} return
7648     set span [$canv yview]
7649     clear_display
7650     setcanvscroll
7651     allcanvs yview moveto [lindex $span 0]
7652     drawvisible
7653     if {$selectedline ne {}} {
7654         selectline $selectedline 0
7655         allcanvs yview moveto [lindex $span 0]
7656     }
7659 proc parsefont {f n} {
7660     global fontattr
7662     set fontattr($f,family) [lindex $n 0]
7663     set s [lindex $n 1]
7664     if {$s eq {} || $s == 0} {
7665         set s 10
7666     } elseif {$s < 0} {
7667         set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7668     }
7669     set fontattr($f,size) $s
7670     set fontattr($f,weight) normal
7671     set fontattr($f,slant) roman
7672     foreach style [lrange $n 2 end] {
7673         switch -- $style {
7674             "normal" -
7675             "bold"   {set fontattr($f,weight) $style}
7676             "roman" -
7677             "italic" {set fontattr($f,slant) $style}
7678         }
7679     }
7682 proc fontflags {f {isbold 0}} {
7683     global fontattr
7685     return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7686                 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7687                 -slant $fontattr($f,slant)]
7690 proc fontname {f} {
7691     global fontattr
7693     set n [list $fontattr($f,family) $fontattr($f,size)]
7694     if {$fontattr($f,weight) eq "bold"} {
7695         lappend n "bold"
7696     }
7697     if {$fontattr($f,slant) eq "italic"} {
7698         lappend n "italic"
7699     }
7700     return $n
7703 proc incrfont {inc} {
7704     global mainfont textfont ctext canv cflist showrefstop
7705     global stopped entries fontattr
7707     unmarkmatches
7708     set s $fontattr(mainfont,size)
7709     incr s $inc
7710     if {$s < 1} {
7711         set s 1
7712     }
7713     set fontattr(mainfont,size) $s
7714     font config mainfont -size $s
7715     font config mainfontbold -size $s
7716     set mainfont [fontname mainfont]
7717     set s $fontattr(textfont,size)
7718     incr s $inc
7719     if {$s < 1} {
7720         set s 1
7721     }
7722     set fontattr(textfont,size) $s
7723     font config textfont -size $s
7724     font config textfontbold -size $s
7725     set textfont [fontname textfont]
7726     setcoords
7727     settabs
7728     redisplay
7731 proc clearsha1 {} {
7732     global sha1entry sha1string
7733     if {[string length $sha1string] == 40} {
7734         $sha1entry delete 0 end
7735     }
7738 proc sha1change {n1 n2 op} {
7739     global sha1string currentid sha1but
7740     if {$sha1string == {}
7741         || ([info exists currentid] && $sha1string == $currentid)} {
7742         set state disabled
7743     } else {
7744         set state normal
7745     }
7746     if {[$sha1but cget -state] == $state} return
7747     if {$state == "normal"} {
7748         $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7749     } else {
7750         $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7751     }
7754 proc gotocommit {} {
7755     global sha1string tagids headids curview varcid
7757     if {$sha1string == {}
7758         || ([info exists currentid] && $sha1string == $currentid)} return
7759     if {[info exists tagids($sha1string)]} {
7760         set id $tagids($sha1string)
7761     } elseif {[info exists headids($sha1string)]} {
7762         set id $headids($sha1string)
7763     } else {
7764         set id [string tolower $sha1string]
7765         if {[regexp {^[0-9a-f]{4,39}$} $id]} {
7766             set matches [longid $id]
7767             if {$matches ne {}} {
7768                 if {[llength $matches] > 1} {
7769                     error_popup [mc "Short SHA1 id %s is ambiguous" $id]
7770                     return
7771                 }
7772                 set id [lindex $matches 0]
7773             }
7774         }
7775     }
7776     if {[commitinview $id $curview]} {
7777         selectline [rowofcommit $id] 1
7778         return
7779     }
7780     if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
7781         set msg [mc "SHA1 id %s is not known" $sha1string]
7782     } else {
7783         set msg [mc "Tag/Head %s is not known" $sha1string]
7784     }
7785     error_popup $msg
7788 proc lineenter {x y id} {
7789     global hoverx hovery hoverid hovertimer
7790     global commitinfo canv
7792     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7793     set hoverx $x
7794     set hovery $y
7795     set hoverid $id
7796     if {[info exists hovertimer]} {
7797         after cancel $hovertimer
7798     }
7799     set hovertimer [after 500 linehover]
7800     $canv delete hover
7803 proc linemotion {x y id} {
7804     global hoverx hovery hoverid hovertimer
7806     if {[info exists hoverid] && $id == $hoverid} {
7807         set hoverx $x
7808         set hovery $y
7809         if {[info exists hovertimer]} {
7810             after cancel $hovertimer
7811         }
7812         set hovertimer [after 500 linehover]
7813     }
7816 proc lineleave {id} {
7817     global hoverid hovertimer canv
7819     if {[info exists hoverid] && $id == $hoverid} {
7820         $canv delete hover
7821         if {[info exists hovertimer]} {
7822             after cancel $hovertimer
7823             unset hovertimer
7824         }
7825         unset hoverid
7826     }
7829 proc linehover {} {
7830     global hoverx hovery hoverid hovertimer
7831     global canv linespc lthickness
7832     global commitinfo
7834     set text [lindex $commitinfo($hoverid) 0]
7835     set ymax [lindex [$canv cget -scrollregion] 3]
7836     if {$ymax == {}} return
7837     set yfrac [lindex [$canv yview] 0]
7838     set x [expr {$hoverx + 2 * $linespc}]
7839     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
7840     set x0 [expr {$x - 2 * $lthickness}]
7841     set y0 [expr {$y - 2 * $lthickness}]
7842     set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
7843     set y1 [expr {$y + $linespc + 2 * $lthickness}]
7844     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
7845                -fill \#ffff80 -outline black -width 1 -tags hover]
7846     $canv raise $t
7847     set t [$canv create text $x $y -anchor nw -text $text -tags hover \
7848                -font mainfont]
7849     $canv raise $t
7852 proc clickisonarrow {id y} {
7853     global lthickness
7855     set ranges [rowranges $id]
7856     set thresh [expr {2 * $lthickness + 6}]
7857     set n [expr {[llength $ranges] - 1}]
7858     for {set i 1} {$i < $n} {incr i} {
7859         set row [lindex $ranges $i]
7860         if {abs([yc $row] - $y) < $thresh} {
7861             return $i
7862         }
7863     }
7864     return {}
7867 proc arrowjump {id n y} {
7868     global canv
7870     # 1 <-> 2, 3 <-> 4, etc...
7871     set n [expr {(($n - 1) ^ 1) + 1}]
7872     set row [lindex [rowranges $id] $n]
7873     set yt [yc $row]
7874     set ymax [lindex [$canv cget -scrollregion] 3]
7875     if {$ymax eq {} || $ymax <= 0} return
7876     set view [$canv yview]
7877     set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
7878     set yfrac [expr {$yt / $ymax - $yspan / 2}]
7879     if {$yfrac < 0} {
7880         set yfrac 0
7881     }
7882     allcanvs yview moveto $yfrac
7885 proc lineclick {x y id isnew} {
7886     global ctext commitinfo children canv thickerline curview
7888     if {![info exists commitinfo($id)] && ![getcommit $id]} return
7889     unmarkmatches
7890     unselectline
7891     normalline
7892     $canv delete hover
7893     # draw this line thicker than normal
7894     set thickerline $id
7895     drawlines $id
7896     if {$isnew} {
7897         set ymax [lindex [$canv cget -scrollregion] 3]
7898         if {$ymax eq {}} return
7899         set yfrac [lindex [$canv yview] 0]
7900         set y [expr {$y + $yfrac * $ymax}]
7901     }
7902     set dirn [clickisonarrow $id $y]
7903     if {$dirn ne {}} {
7904         arrowjump $id $dirn $y
7905         return
7906     }
7908     if {$isnew} {
7909         addtohistory [list lineclick $x $y $id 0]
7910     }
7911     # fill the details pane with info about this line
7912     $ctext conf -state normal
7913     clear_ctext
7914     settabs 0
7915     $ctext insert end "[mc "Parent"]:\t"
7916     $ctext insert end $id link0
7917     setlink $id link0
7918     set info $commitinfo($id)
7919     $ctext insert end "\n\t[lindex $info 0]\n"
7920     $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
7921     set date [formatdate [lindex $info 2]]
7922     $ctext insert end "\t[mc "Date"]:\t$date\n"
7923     set kids $children($curview,$id)
7924     if {$kids ne {}} {
7925         $ctext insert end "\n[mc "Children"]:"
7926         set i 0
7927         foreach child $kids {
7928             incr i
7929             if {![info exists commitinfo($child)] && ![getcommit $child]} continue
7930             set info $commitinfo($child)
7931             $ctext insert end "\n\t"
7932             $ctext insert end $child link$i
7933             setlink $child link$i
7934             $ctext insert end "\n\t[lindex $info 0]"
7935             $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
7936             set date [formatdate [lindex $info 2]]
7937             $ctext insert end "\n\t[mc "Date"]:\t$date\n"
7938         }
7939     }
7940     $ctext conf -state disabled
7941     init_flist {}
7944 proc normalline {} {
7945     global thickerline
7946     if {[info exists thickerline]} {
7947         set id $thickerline
7948         unset thickerline
7949         drawlines $id
7950     }
7953 proc selbyid {id} {
7954     global curview
7955     if {[commitinview $id $curview]} {
7956         selectline [rowofcommit $id] 1
7957     }
7960 proc mstime {} {
7961     global startmstime
7962     if {![info exists startmstime]} {
7963         set startmstime [clock clicks -milliseconds]
7964     }
7965     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
7968 proc rowmenu {x y id} {
7969     global rowctxmenu selectedline rowmenuid curview
7970     global nullid nullid2 fakerowmenu mainhead
7972     stopfinding
7973     set rowmenuid $id
7974     if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
7975         set state disabled
7976     } else {
7977         set state normal
7978     }
7979     if {$id ne $nullid && $id ne $nullid2} {
7980         set menu $rowctxmenu
7981         if {$mainhead ne {}} {
7982             $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
7983         } else {
7984             $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
7985         }
7986     } else {
7987         set menu $fakerowmenu
7988     }
7989     $menu entryconfigure [mca "Diff this -> selected"] -state $state
7990     $menu entryconfigure [mca "Diff selected -> this"] -state $state
7991     $menu entryconfigure [mca "Make patch"] -state $state
7992     tk_popup $menu $x $y
7995 proc diffvssel {dirn} {
7996     global rowmenuid selectedline
7998     if {$selectedline eq {}} return
7999     if {$dirn} {
8000         set oldid [commitonrow $selectedline]
8001         set newid $rowmenuid
8002     } else {
8003         set oldid $rowmenuid
8004         set newid [commitonrow $selectedline]
8005     }
8006     addtohistory [list doseldiff $oldid $newid]
8007     doseldiff $oldid $newid
8010 proc doseldiff {oldid newid} {
8011     global ctext
8012     global commitinfo
8014     $ctext conf -state normal
8015     clear_ctext
8016     init_flist [mc "Top"]
8017     $ctext insert end "[mc "From"] "
8018     $ctext insert end $oldid link0
8019     setlink $oldid link0
8020     $ctext insert end "\n     "
8021     $ctext insert end [lindex $commitinfo($oldid) 0]
8022     $ctext insert end "\n\n[mc "To"]   "
8023     $ctext insert end $newid link1
8024     setlink $newid link1
8025     $ctext insert end "\n     "
8026     $ctext insert end [lindex $commitinfo($newid) 0]
8027     $ctext insert end "\n"
8028     $ctext conf -state disabled
8029     $ctext tag remove found 1.0 end
8030     startdiff [list $oldid $newid]
8033 proc mkpatch {} {
8034     global rowmenuid currentid commitinfo patchtop patchnum
8036     if {![info exists currentid]} return
8037     set oldid $currentid
8038     set oldhead [lindex $commitinfo($oldid) 0]
8039     set newid $rowmenuid
8040     set newhead [lindex $commitinfo($newid) 0]
8041     set top .patch
8042     set patchtop $top
8043     catch {destroy $top}
8044     toplevel $top
8045     make_transient $top .
8046     label $top.title -text [mc "Generate patch"]
8047     grid $top.title - -pady 10
8048     label $top.from -text [mc "From:"]
8049     entry $top.fromsha1 -width 40 -relief flat
8050     $top.fromsha1 insert 0 $oldid
8051     $top.fromsha1 conf -state readonly
8052     grid $top.from $top.fromsha1 -sticky w
8053     entry $top.fromhead -width 60 -relief flat
8054     $top.fromhead insert 0 $oldhead
8055     $top.fromhead conf -state readonly
8056     grid x $top.fromhead -sticky w
8057     label $top.to -text [mc "To:"]
8058     entry $top.tosha1 -width 40 -relief flat
8059     $top.tosha1 insert 0 $newid
8060     $top.tosha1 conf -state readonly
8061     grid $top.to $top.tosha1 -sticky w
8062     entry $top.tohead -width 60 -relief flat
8063     $top.tohead insert 0 $newhead
8064     $top.tohead conf -state readonly
8065     grid x $top.tohead -sticky w
8066     button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
8067     grid $top.rev x -pady 10
8068     label $top.flab -text [mc "Output file:"]
8069     entry $top.fname -width 60
8070     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8071     incr patchnum
8072     grid $top.flab $top.fname -sticky w
8073     frame $top.buts
8074     button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8075     button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8076     bind $top <Key-Return> mkpatchgo
8077     bind $top <Key-Escape> mkpatchcan
8078     grid $top.buts.gen $top.buts.can
8079     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8080     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8081     grid $top.buts - -pady 10 -sticky ew
8082     focus $top.fname
8085 proc mkpatchrev {} {
8086     global patchtop
8088     set oldid [$patchtop.fromsha1 get]
8089     set oldhead [$patchtop.fromhead get]
8090     set newid [$patchtop.tosha1 get]
8091     set newhead [$patchtop.tohead get]
8092     foreach e [list fromsha1 fromhead tosha1 tohead] \
8093             v [list $newid $newhead $oldid $oldhead] {
8094         $patchtop.$e conf -state normal
8095         $patchtop.$e delete 0 end
8096         $patchtop.$e insert 0 $v
8097         $patchtop.$e conf -state readonly
8098     }
8101 proc mkpatchgo {} {
8102     global patchtop nullid nullid2
8104     set oldid [$patchtop.fromsha1 get]
8105     set newid [$patchtop.tosha1 get]
8106     set fname [$patchtop.fname get]
8107     set cmd [diffcmd [list $oldid $newid] -p]
8108     # trim off the initial "|"
8109     set cmd [lrange $cmd 1 end]
8110     lappend cmd >$fname &
8111     if {[catch {eval exec $cmd} err]} {
8112         error_popup "[mc "Error creating patch:"] $err" $patchtop
8113     }
8114     catch {destroy $patchtop}
8115     unset patchtop
8118 proc mkpatchcan {} {
8119     global patchtop
8121     catch {destroy $patchtop}
8122     unset patchtop
8125 proc mktag {} {
8126     global rowmenuid mktagtop commitinfo
8128     set top .maketag
8129     set mktagtop $top
8130     catch {destroy $top}
8131     toplevel $top
8132     make_transient $top .
8133     label $top.title -text [mc "Create tag"]
8134     grid $top.title - -pady 10
8135     label $top.id -text [mc "ID:"]
8136     entry $top.sha1 -width 40 -relief flat
8137     $top.sha1 insert 0 $rowmenuid
8138     $top.sha1 conf -state readonly
8139     grid $top.id $top.sha1 -sticky w
8140     entry $top.head -width 60 -relief flat
8141     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8142     $top.head conf -state readonly
8143     grid x $top.head -sticky w
8144     label $top.tlab -text [mc "Tag name:"]
8145     entry $top.tag -width 60
8146     grid $top.tlab $top.tag -sticky w
8147     frame $top.buts
8148     button $top.buts.gen -text [mc "Create"] -command mktaggo
8149     button $top.buts.can -text [mc "Cancel"] -command mktagcan
8150     bind $top <Key-Return> mktaggo
8151     bind $top <Key-Escape> mktagcan
8152     grid $top.buts.gen $top.buts.can
8153     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8154     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8155     grid $top.buts - -pady 10 -sticky ew
8156     focus $top.tag
8159 proc domktag {} {
8160     global mktagtop env tagids idtags
8162     set id [$mktagtop.sha1 get]
8163     set tag [$mktagtop.tag get]
8164     if {$tag == {}} {
8165         error_popup [mc "No tag name specified"] $mktagtop
8166         return 0
8167     }
8168     if {[info exists tagids($tag)]} {
8169         error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8170         return 0
8171     }
8172     if {[catch {
8173         exec git tag $tag $id
8174     } err]} {
8175         error_popup "[mc "Error creating tag:"] $err" $mktagtop
8176         return 0
8177     }
8179     set tagids($tag) $id
8180     lappend idtags($id) $tag
8181     redrawtags $id
8182     addedtag $id
8183     dispneartags 0
8184     run refill_reflist
8185     return 1
8188 proc redrawtags {id} {
8189     global canv linehtag idpos currentid curview cmitlisted
8190     global canvxmax iddrawn circleitem mainheadid circlecolors
8192     if {![commitinview $id $curview]} return
8193     if {![info exists iddrawn($id)]} return
8194     set row [rowofcommit $id]
8195     if {$id eq $mainheadid} {
8196         set ofill yellow
8197     } else {
8198         set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8199     }
8200     $canv itemconf $circleitem($row) -fill $ofill
8201     $canv delete tag.$id
8202     set xt [eval drawtags $id $idpos($id)]
8203     $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8204     set text [$canv itemcget $linehtag($id) -text]
8205     set font [$canv itemcget $linehtag($id) -font]
8206     set xr [expr {$xt + [font measure $font $text]}]
8207     if {$xr > $canvxmax} {
8208         set canvxmax $xr
8209         setcanvscroll
8210     }
8211     if {[info exists currentid] && $currentid == $id} {
8212         make_secsel $id
8213     }
8216 proc mktagcan {} {
8217     global mktagtop
8219     catch {destroy $mktagtop}
8220     unset mktagtop
8223 proc mktaggo {} {
8224     if {![domktag]} return
8225     mktagcan
8228 proc writecommit {} {
8229     global rowmenuid wrcomtop commitinfo wrcomcmd
8231     set top .writecommit
8232     set wrcomtop $top
8233     catch {destroy $top}
8234     toplevel $top
8235     make_transient $top .
8236     label $top.title -text [mc "Write commit to file"]
8237     grid $top.title - -pady 10
8238     label $top.id -text [mc "ID:"]
8239     entry $top.sha1 -width 40 -relief flat
8240     $top.sha1 insert 0 $rowmenuid
8241     $top.sha1 conf -state readonly
8242     grid $top.id $top.sha1 -sticky w
8243     entry $top.head -width 60 -relief flat
8244     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8245     $top.head conf -state readonly
8246     grid x $top.head -sticky w
8247     label $top.clab -text [mc "Command:"]
8248     entry $top.cmd -width 60 -textvariable wrcomcmd
8249     grid $top.clab $top.cmd -sticky w -pady 10
8250     label $top.flab -text [mc "Output file:"]
8251     entry $top.fname -width 60
8252     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8253     grid $top.flab $top.fname -sticky w
8254     frame $top.buts
8255     button $top.buts.gen -text [mc "Write"] -command wrcomgo
8256     button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8257     bind $top <Key-Return> wrcomgo
8258     bind $top <Key-Escape> wrcomcan
8259     grid $top.buts.gen $top.buts.can
8260     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8261     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8262     grid $top.buts - -pady 10 -sticky ew
8263     focus $top.fname
8266 proc wrcomgo {} {
8267     global wrcomtop
8269     set id [$wrcomtop.sha1 get]
8270     set cmd "echo $id | [$wrcomtop.cmd get]"
8271     set fname [$wrcomtop.fname get]
8272     if {[catch {exec sh -c $cmd >$fname &} err]} {
8273         error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8274     }
8275     catch {destroy $wrcomtop}
8276     unset wrcomtop
8279 proc wrcomcan {} {
8280     global wrcomtop
8282     catch {destroy $wrcomtop}
8283     unset wrcomtop
8286 proc mkbranch {} {
8287     global rowmenuid mkbrtop
8289     set top .makebranch
8290     catch {destroy $top}
8291     toplevel $top
8292     make_transient $top .
8293     label $top.title -text [mc "Create new branch"]
8294     grid $top.title - -pady 10
8295     label $top.id -text [mc "ID:"]
8296     entry $top.sha1 -width 40 -relief flat
8297     $top.sha1 insert 0 $rowmenuid
8298     $top.sha1 conf -state readonly
8299     grid $top.id $top.sha1 -sticky w
8300     label $top.nlab -text [mc "Name:"]
8301     entry $top.name -width 40
8302     grid $top.nlab $top.name -sticky w
8303     frame $top.buts
8304     button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8305     button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8306     bind $top <Key-Return> [list mkbrgo $top]
8307     bind $top <Key-Escape> "catch {destroy $top}"
8308     grid $top.buts.go $top.buts.can
8309     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8310     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8311     grid $top.buts - -pady 10 -sticky ew
8312     focus $top.name
8315 proc mkbrgo {top} {
8316     global headids idheads
8318     set name [$top.name get]
8319     set id [$top.sha1 get]
8320     set cmdargs {}
8321     set old_id {}
8322     if {$name eq {}} {
8323         error_popup [mc "Please specify a name for the new branch"] $top
8324         return
8325     }
8326     if {[info exists headids($name)]} {
8327         if {![confirm_popup [mc \
8328                 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8329             return
8330         }
8331         set old_id $headids($name)
8332         lappend cmdargs -f
8333     }
8334     catch {destroy $top}
8335     lappend cmdargs $name $id
8336     nowbusy newbranch
8337     update
8338     if {[catch {
8339         eval exec git branch $cmdargs
8340     } err]} {
8341         notbusy newbranch
8342         error_popup $err
8343     } else {
8344         notbusy newbranch
8345         if {$old_id ne {}} {
8346             movehead $id $name
8347             movedhead $id $name
8348             redrawtags $old_id
8349             redrawtags $id
8350         } else {
8351             set headids($name) $id
8352             lappend idheads($id) $name
8353             addedhead $id $name
8354             redrawtags $id
8355         }
8356         dispneartags 0
8357         run refill_reflist
8358     }
8361 proc exec_citool {tool_args {baseid {}}} {
8362     global commitinfo env
8364     set save_env [array get env GIT_AUTHOR_*]
8366     if {$baseid ne {}} {
8367         if {![info exists commitinfo($baseid)]} {
8368             getcommit $baseid
8369         }
8370         set author [lindex $commitinfo($baseid) 1]
8371         set date [lindex $commitinfo($baseid) 2]
8372         if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8373                     $author author name email]
8374             && $date ne {}} {
8375             set env(GIT_AUTHOR_NAME) $name
8376             set env(GIT_AUTHOR_EMAIL) $email
8377             set env(GIT_AUTHOR_DATE) $date
8378         }
8379     }
8381     eval exec git citool $tool_args &
8383     array unset env GIT_AUTHOR_*
8384     array set env $save_env
8387 proc cherrypick {} {
8388     global rowmenuid curview
8389     global mainhead mainheadid
8391     set oldhead [exec git rev-parse HEAD]
8392     set dheads [descheads $rowmenuid]
8393     if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8394         set ok [confirm_popup [mc "Commit %s is already\
8395                 included in branch %s -- really re-apply it?" \
8396                                    [string range $rowmenuid 0 7] $mainhead]]
8397         if {!$ok} return
8398     }
8399     nowbusy cherrypick [mc "Cherry-picking"]
8400     update
8401     # Unfortunately git-cherry-pick writes stuff to stderr even when
8402     # no error occurs, and exec takes that as an indication of error...
8403     if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8404         notbusy cherrypick
8405         if {[regexp -line \
8406                  {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8407                  $err msg fname]} {
8408             error_popup [mc "Cherry-pick failed because of local changes\
8409                         to file '%s'.\nPlease commit, reset or stash\
8410                         your changes and try again." $fname]
8411         } elseif {[regexp -line \
8412                        {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8413                        $err]} {
8414             if {[confirm_popup [mc "Cherry-pick failed because of merge\
8415                         conflict.\nDo you wish to run git citool to\
8416                         resolve it?"]]} {
8417                 # Force citool to read MERGE_MSG
8418                 file delete [file join [gitdir] "GITGUI_MSG"]
8419                 exec_citool {} $rowmenuid
8420             }
8421         } else {
8422             error_popup $err
8423         }
8424         run updatecommits
8425         return
8426     }
8427     set newhead [exec git rev-parse HEAD]
8428     if {$newhead eq $oldhead} {
8429         notbusy cherrypick
8430         error_popup [mc "No changes committed"]
8431         return
8432     }
8433     addnewchild $newhead $oldhead
8434     if {[commitinview $oldhead $curview]} {
8435         # XXX this isn't right if we have a path limit...
8436         insertrow $newhead $oldhead $curview
8437         if {$mainhead ne {}} {
8438             movehead $newhead $mainhead
8439             movedhead $newhead $mainhead
8440         }
8441         set mainheadid $newhead
8442         redrawtags $oldhead
8443         redrawtags $newhead
8444         selbyid $newhead
8445     }
8446     notbusy cherrypick
8449 proc resethead {} {
8450     global mainhead rowmenuid confirm_ok resettype
8452     set confirm_ok 0
8453     set w ".confirmreset"
8454     toplevel $w
8455     make_transient $w .
8456     wm title $w [mc "Confirm reset"]
8457     message $w.m -text \
8458         [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
8459         -justify center -aspect 1000
8460     pack $w.m -side top -fill x -padx 20 -pady 20
8461     frame $w.f -relief sunken -border 2
8462     message $w.f.rt -text [mc "Reset type:"] -aspect 1000
8463     grid $w.f.rt -sticky w
8464     set resettype mixed
8465     radiobutton $w.f.soft -value soft -variable resettype -justify left \
8466         -text [mc "Soft: Leave working tree and index untouched"]
8467     grid $w.f.soft -sticky w
8468     radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
8469         -text [mc "Mixed: Leave working tree untouched, reset index"]
8470     grid $w.f.mixed -sticky w
8471     radiobutton $w.f.hard -value hard -variable resettype -justify left \
8472         -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8473     grid $w.f.hard -sticky w
8474     pack $w.f -side top -fill x
8475     button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8476     pack $w.ok -side left -fill x -padx 20 -pady 20
8477     button $w.cancel -text [mc Cancel] -command "destroy $w"
8478     bind $w <Key-Escape> [list destroy $w]
8479     pack $w.cancel -side right -fill x -padx 20 -pady 20
8480     bind $w <Visibility> "grab $w; focus $w"
8481     tkwait window $w
8482     if {!$confirm_ok} return
8483     if {[catch {set fd [open \
8484             [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8485         error_popup $err
8486     } else {
8487         dohidelocalchanges
8488         filerun $fd [list readresetstat $fd]
8489         nowbusy reset [mc "Resetting"]
8490         selbyid $rowmenuid
8491     }
8494 proc readresetstat {fd} {
8495     global mainhead mainheadid showlocalchanges rprogcoord
8497     if {[gets $fd line] >= 0} {
8498         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8499             set rprogcoord [expr {1.0 * $m / $n}]
8500             adjustprogress
8501         }
8502         return 1
8503     }
8504     set rprogcoord 0
8505     adjustprogress
8506     notbusy reset
8507     if {[catch {close $fd} err]} {
8508         error_popup $err
8509     }
8510     set oldhead $mainheadid
8511     set newhead [exec git rev-parse HEAD]
8512     if {$newhead ne $oldhead} {
8513         movehead $newhead $mainhead
8514         movedhead $newhead $mainhead
8515         set mainheadid $newhead
8516         redrawtags $oldhead
8517         redrawtags $newhead
8518     }
8519     if {$showlocalchanges} {
8520         doshowlocalchanges
8521     }
8522     return 0
8525 # context menu for a head
8526 proc headmenu {x y id head} {
8527     global headmenuid headmenuhead headctxmenu mainhead
8529     stopfinding
8530     set headmenuid $id
8531     set headmenuhead $head
8532     set state normal
8533     if {$head eq $mainhead} {
8534         set state disabled
8535     }
8536     $headctxmenu entryconfigure 0 -state $state
8537     $headctxmenu entryconfigure 1 -state $state
8538     tk_popup $headctxmenu $x $y
8541 proc cobranch {} {
8542     global headmenuid headmenuhead headids
8543     global showlocalchanges
8545     # check the tree is clean first??
8546     nowbusy checkout [mc "Checking out"]
8547     update
8548     dohidelocalchanges
8549     if {[catch {
8550         set fd [open [list | git checkout $headmenuhead 2>@1] r]
8551     } err]} {
8552         notbusy checkout
8553         error_popup $err
8554         if {$showlocalchanges} {
8555             dodiffindex
8556         }
8557     } else {
8558         filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8559     }
8562 proc readcheckoutstat {fd newhead newheadid} {
8563     global mainhead mainheadid headids showlocalchanges progresscoords
8564     global viewmainheadid curview
8566     if {[gets $fd line] >= 0} {
8567         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8568             set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8569             adjustprogress
8570         }
8571         return 1
8572     }
8573     set progresscoords {0 0}
8574     adjustprogress
8575     notbusy checkout
8576     if {[catch {close $fd} err]} {
8577         error_popup $err
8578     }
8579     set oldmainid $mainheadid
8580     set mainhead $newhead
8581     set mainheadid $newheadid
8582     set viewmainheadid($curview) $newheadid
8583     redrawtags $oldmainid
8584     redrawtags $newheadid
8585     selbyid $newheadid
8586     if {$showlocalchanges} {
8587         dodiffindex
8588     }
8591 proc rmbranch {} {
8592     global headmenuid headmenuhead mainhead
8593     global idheads
8595     set head $headmenuhead
8596     set id $headmenuid
8597     # this check shouldn't be needed any more...
8598     if {$head eq $mainhead} {
8599         error_popup [mc "Cannot delete the currently checked-out branch"]
8600         return
8601     }
8602     set dheads [descheads $id]
8603     if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
8604         # the stuff on this branch isn't on any other branch
8605         if {![confirm_popup [mc "The commits on branch %s aren't on any other\
8606                         branch.\nReally delete branch %s?" $head $head]]} return
8607     }
8608     nowbusy rmbranch
8609     update
8610     if {[catch {exec git branch -D $head} err]} {
8611         notbusy rmbranch
8612         error_popup $err
8613         return
8614     }
8615     removehead $id $head
8616     removedhead $id $head
8617     redrawtags $id
8618     notbusy rmbranch
8619     dispneartags 0
8620     run refill_reflist
8623 # Display a list of tags and heads
8624 proc showrefs {} {
8625     global showrefstop bgcolor fgcolor selectbgcolor
8626     global bglist fglist reflistfilter reflist maincursor
8628     set top .showrefs
8629     set showrefstop $top
8630     if {[winfo exists $top]} {
8631         raise $top
8632         refill_reflist
8633         return
8634     }
8635     toplevel $top
8636     wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
8637     make_transient $top .
8638     text $top.list -background $bgcolor -foreground $fgcolor \
8639         -selectbackground $selectbgcolor -font mainfont \
8640         -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
8641         -width 30 -height 20 -cursor $maincursor \
8642         -spacing1 1 -spacing3 1 -state disabled
8643     $top.list tag configure highlight -background $selectbgcolor
8644     lappend bglist $top.list
8645     lappend fglist $top.list
8646     scrollbar $top.ysb -command "$top.list yview" -orient vertical
8647     scrollbar $top.xsb -command "$top.list xview" -orient horizontal
8648     grid $top.list $top.ysb -sticky nsew
8649     grid $top.xsb x -sticky ew
8650     frame $top.f
8651     label $top.f.l -text "[mc "Filter"]: "
8652     entry $top.f.e -width 20 -textvariable reflistfilter
8653     set reflistfilter "*"
8654     trace add variable reflistfilter write reflistfilter_change
8655     pack $top.f.e -side right -fill x -expand 1
8656     pack $top.f.l -side left
8657     grid $top.f - -sticky ew -pady 2
8658     button $top.close -command [list destroy $top] -text [mc "Close"]
8659     bind $top <Key-Escape> [list destroy $top]
8660     grid $top.close -
8661     grid columnconfigure $top 0 -weight 1
8662     grid rowconfigure $top 0 -weight 1
8663     bind $top.list <1> {break}
8664     bind $top.list <B1-Motion> {break}
8665     bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
8666     set reflist {}
8667     refill_reflist
8670 proc sel_reflist {w x y} {
8671     global showrefstop reflist headids tagids otherrefids
8673     if {![winfo exists $showrefstop]} return
8674     set l [lindex [split [$w index "@$x,$y"] "."] 0]
8675     set ref [lindex $reflist [expr {$l-1}]]
8676     set n [lindex $ref 0]
8677     switch -- [lindex $ref 1] {
8678         "H" {selbyid $headids($n)}
8679         "T" {selbyid $tagids($n)}
8680         "o" {selbyid $otherrefids($n)}
8681     }
8682     $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
8685 proc unsel_reflist {} {
8686     global showrefstop
8688     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8689     $showrefstop.list tag remove highlight 0.0 end
8692 proc reflistfilter_change {n1 n2 op} {
8693     global reflistfilter
8695     after cancel refill_reflist
8696     after 200 refill_reflist
8699 proc refill_reflist {} {
8700     global reflist reflistfilter showrefstop headids tagids otherrefids
8701     global curview
8703     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
8704     set refs {}
8705     foreach n [array names headids] {
8706         if {[string match $reflistfilter $n]} {
8707             if {[commitinview $headids($n) $curview]} {
8708                 lappend refs [list $n H]
8709             } else {
8710                 interestedin $headids($n) {run refill_reflist}
8711             }
8712         }
8713     }
8714     foreach n [array names tagids] {
8715         if {[string match $reflistfilter $n]} {
8716             if {[commitinview $tagids($n) $curview]} {
8717                 lappend refs [list $n T]
8718             } else {
8719                 interestedin $tagids($n) {run refill_reflist}
8720             }
8721         }
8722     }
8723     foreach n [array names otherrefids] {
8724         if {[string match $reflistfilter $n]} {
8725             if {[commitinview $otherrefids($n) $curview]} {
8726                 lappend refs [list $n o]
8727             } else {
8728                 interestedin $otherrefids($n) {run refill_reflist}
8729             }
8730         }
8731     }
8732     set refs [lsort -index 0 $refs]
8733     if {$refs eq $reflist} return
8735     # Update the contents of $showrefstop.list according to the
8736     # differences between $reflist (old) and $refs (new)
8737     $showrefstop.list conf -state normal
8738     $showrefstop.list insert end "\n"
8739     set i 0
8740     set j 0
8741     while {$i < [llength $reflist] || $j < [llength $refs]} {
8742         if {$i < [llength $reflist]} {
8743             if {$j < [llength $refs]} {
8744                 set cmp [string compare [lindex $reflist $i 0] \
8745                              [lindex $refs $j 0]]
8746                 if {$cmp == 0} {
8747                     set cmp [string compare [lindex $reflist $i 1] \
8748                                  [lindex $refs $j 1]]
8749                 }
8750             } else {
8751                 set cmp -1
8752             }
8753         } else {
8754             set cmp 1
8755         }
8756         switch -- $cmp {
8757             -1 {
8758                 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
8759                 incr i
8760             }
8761             0 {
8762                 incr i
8763                 incr j
8764             }
8765             1 {
8766                 set l [expr {$j + 1}]
8767                 $showrefstop.list image create $l.0 -align baseline \
8768                     -image reficon-[lindex $refs $j 1] -padx 2
8769                 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
8770                 incr j
8771             }
8772         }
8773     }
8774     set reflist $refs
8775     # delete last newline
8776     $showrefstop.list delete end-2c end-1c
8777     $showrefstop.list conf -state disabled
8780 # Stuff for finding nearby tags
8781 proc getallcommits {} {
8782     global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
8783     global idheads idtags idotherrefs allparents tagobjid
8785     if {![info exists allcommits]} {
8786         set nextarc 0
8787         set allcommits 0
8788         set seeds {}
8789         set allcwait 0
8790         set cachedarcs 0
8791         set allccache [file join [gitdir] "gitk.cache"]
8792         if {![catch {
8793             set f [open $allccache r]
8794             set allcwait 1
8795             getcache $f
8796         }]} return
8797     }
8799     if {$allcwait} {
8800         return
8801     }
8802     set cmd [list | git rev-list --parents]
8803     set allcupdate [expr {$seeds ne {}}]
8804     if {!$allcupdate} {
8805         set ids "--all"
8806     } else {
8807         set refs [concat [array names idheads] [array names idtags] \
8808                       [array names idotherrefs]]
8809         set ids {}
8810         set tagobjs {}
8811         foreach name [array names tagobjid] {
8812             lappend tagobjs $tagobjid($name)
8813         }
8814         foreach id [lsort -unique $refs] {
8815             if {![info exists allparents($id)] &&
8816                 [lsearch -exact $tagobjs $id] < 0} {
8817                 lappend ids $id
8818             }
8819         }
8820         if {$ids ne {}} {
8821             foreach id $seeds {
8822                 lappend ids "^$id"
8823             }
8824         }
8825     }
8826     if {$ids ne {}} {
8827         set fd [open [concat $cmd $ids] r]
8828         fconfigure $fd -blocking 0
8829         incr allcommits
8830         nowbusy allcommits
8831         filerun $fd [list getallclines $fd]
8832     } else {
8833         dispneartags 0
8834     }
8837 # Since most commits have 1 parent and 1 child, we group strings of
8838 # such commits into "arcs" joining branch/merge points (BMPs), which
8839 # are commits that either don't have 1 parent or don't have 1 child.
8841 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
8842 # arcout(id) - outgoing arcs for BMP
8843 # arcids(a) - list of IDs on arc including end but not start
8844 # arcstart(a) - BMP ID at start of arc
8845 # arcend(a) - BMP ID at end of arc
8846 # growing(a) - arc a is still growing
8847 # arctags(a) - IDs out of arcids (excluding end) that have tags
8848 # archeads(a) - IDs out of arcids (excluding end) that have heads
8849 # The start of an arc is at the descendent end, so "incoming" means
8850 # coming from descendents, and "outgoing" means going towards ancestors.
8852 proc getallclines {fd} {
8853     global allparents allchildren idtags idheads nextarc
8854     global arcnos arcids arctags arcout arcend arcstart archeads growing
8855     global seeds allcommits cachedarcs allcupdate
8856     
8857     set nid 0
8858     while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
8859         set id [lindex $line 0]
8860         if {[info exists allparents($id)]} {
8861             # seen it already
8862             continue
8863         }
8864         set cachedarcs 0
8865         set olds [lrange $line 1 end]
8866         set allparents($id) $olds
8867         if {![info exists allchildren($id)]} {
8868             set allchildren($id) {}
8869             set arcnos($id) {}
8870             lappend seeds $id
8871         } else {
8872             set a $arcnos($id)
8873             if {[llength $olds] == 1 && [llength $a] == 1} {
8874                 lappend arcids($a) $id
8875                 if {[info exists idtags($id)]} {
8876                     lappend arctags($a) $id
8877                 }
8878                 if {[info exists idheads($id)]} {
8879                     lappend archeads($a) $id
8880                 }
8881                 if {[info exists allparents($olds)]} {
8882                     # seen parent already
8883                     if {![info exists arcout($olds)]} {
8884                         splitarc $olds
8885                     }
8886                     lappend arcids($a) $olds
8887                     set arcend($a) $olds
8888                     unset growing($a)
8889                 }
8890                 lappend allchildren($olds) $id
8891                 lappend arcnos($olds) $a
8892                 continue
8893             }
8894         }
8895         foreach a $arcnos($id) {
8896             lappend arcids($a) $id
8897             set arcend($a) $id
8898             unset growing($a)
8899         }
8901         set ao {}
8902         foreach p $olds {
8903             lappend allchildren($p) $id
8904             set a [incr nextarc]
8905             set arcstart($a) $id
8906             set archeads($a) {}
8907             set arctags($a) {}
8908             set archeads($a) {}
8909             set arcids($a) {}
8910             lappend ao $a
8911             set growing($a) 1
8912             if {[info exists allparents($p)]} {
8913                 # seen it already, may need to make a new branch
8914                 if {![info exists arcout($p)]} {
8915                     splitarc $p
8916                 }
8917                 lappend arcids($a) $p
8918                 set arcend($a) $p
8919                 unset growing($a)
8920             }
8921             lappend arcnos($p) $a
8922         }
8923         set arcout($id) $ao
8924     }
8925     if {$nid > 0} {
8926         global cached_dheads cached_dtags cached_atags
8927         catch {unset cached_dheads}
8928         catch {unset cached_dtags}
8929         catch {unset cached_atags}
8930     }
8931     if {![eof $fd]} {
8932         return [expr {$nid >= 1000? 2: 1}]
8933     }
8934     set cacheok 1
8935     if {[catch {
8936         fconfigure $fd -blocking 1
8937         close $fd
8938     } err]} {
8939         # got an error reading the list of commits
8940         # if we were updating, try rereading the whole thing again
8941         if {$allcupdate} {
8942             incr allcommits -1
8943             dropcache $err
8944             return
8945         }
8946         error_popup "[mc "Error reading commit topology information;\
8947                 branch and preceding/following tag information\
8948                 will be incomplete."]\n($err)"
8949         set cacheok 0
8950     }
8951     if {[incr allcommits -1] == 0} {
8952         notbusy allcommits
8953         if {$cacheok} {
8954             run savecache
8955         }
8956     }
8957     dispneartags 0
8958     return 0
8961 proc recalcarc {a} {
8962     global arctags archeads arcids idtags idheads
8964     set at {}
8965     set ah {}
8966     foreach id [lrange $arcids($a) 0 end-1] {
8967         if {[info exists idtags($id)]} {
8968             lappend at $id
8969         }
8970         if {[info exists idheads($id)]} {
8971             lappend ah $id
8972         }
8973     }
8974     set arctags($a) $at
8975     set archeads($a) $ah
8978 proc splitarc {p} {
8979     global arcnos arcids nextarc arctags archeads idtags idheads
8980     global arcstart arcend arcout allparents growing
8982     set a $arcnos($p)
8983     if {[llength $a] != 1} {
8984         puts "oops splitarc called but [llength $a] arcs already"
8985         return
8986     }
8987     set a [lindex $a 0]
8988     set i [lsearch -exact $arcids($a) $p]
8989     if {$i < 0} {
8990         puts "oops splitarc $p not in arc $a"
8991         return
8992     }
8993     set na [incr nextarc]
8994     if {[info exists arcend($a)]} {
8995         set arcend($na) $arcend($a)
8996     } else {
8997         set l [lindex $allparents([lindex $arcids($a) end]) 0]
8998         set j [lsearch -exact $arcnos($l) $a]
8999         set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9000     }
9001     set tail [lrange $arcids($a) [expr {$i+1}] end]
9002     set arcids($a) [lrange $arcids($a) 0 $i]
9003     set arcend($a) $p
9004     set arcstart($na) $p
9005     set arcout($p) $na
9006     set arcids($na) $tail
9007     if {[info exists growing($a)]} {
9008         set growing($na) 1
9009         unset growing($a)
9010     }
9012     foreach id $tail {
9013         if {[llength $arcnos($id)] == 1} {
9014             set arcnos($id) $na
9015         } else {
9016             set j [lsearch -exact $arcnos($id) $a]
9017             set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9018         }
9019     }
9021     # reconstruct tags and heads lists
9022     if {$arctags($a) ne {} || $archeads($a) ne {}} {
9023         recalcarc $a
9024         recalcarc $na
9025     } else {
9026         set arctags($na) {}
9027         set archeads($na) {}
9028     }
9031 # Update things for a new commit added that is a child of one
9032 # existing commit.  Used when cherry-picking.
9033 proc addnewchild {id p} {
9034     global allparents allchildren idtags nextarc
9035     global arcnos arcids arctags arcout arcend arcstart archeads growing
9036     global seeds allcommits
9038     if {![info exists allcommits] || ![info exists arcnos($p)]} return
9039     set allparents($id) [list $p]
9040     set allchildren($id) {}
9041     set arcnos($id) {}
9042     lappend seeds $id
9043     lappend allchildren($p) $id
9044     set a [incr nextarc]
9045     set arcstart($a) $id
9046     set archeads($a) {}
9047     set arctags($a) {}
9048     set arcids($a) [list $p]
9049     set arcend($a) $p
9050     if {![info exists arcout($p)]} {
9051         splitarc $p
9052     }
9053     lappend arcnos($p) $a
9054     set arcout($id) [list $a]
9057 # This implements a cache for the topology information.
9058 # The cache saves, for each arc, the start and end of the arc,
9059 # the ids on the arc, and the outgoing arcs from the end.
9060 proc readcache {f} {
9061     global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9062     global idtags idheads allparents cachedarcs possible_seeds seeds growing
9063     global allcwait
9065     set a $nextarc
9066     set lim $cachedarcs
9067     if {$lim - $a > 500} {
9068         set lim [expr {$a + 500}]
9069     }
9070     if {[catch {
9071         if {$a == $lim} {
9072             # finish reading the cache and setting up arctags, etc.
9073             set line [gets $f]
9074             if {$line ne "1"} {error "bad final version"}
9075             close $f
9076             foreach id [array names idtags] {
9077                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9078                     [llength $allparents($id)] == 1} {
9079                     set a [lindex $arcnos($id) 0]
9080                     if {$arctags($a) eq {}} {
9081                         recalcarc $a
9082                     }
9083                 }
9084             }
9085             foreach id [array names idheads] {
9086                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9087                     [llength $allparents($id)] == 1} {
9088                     set a [lindex $arcnos($id) 0]
9089                     if {$archeads($a) eq {}} {
9090                         recalcarc $a
9091                     }
9092                 }
9093             }
9094             foreach id [lsort -unique $possible_seeds] {
9095                 if {$arcnos($id) eq {}} {
9096                     lappend seeds $id
9097                 }
9098             }
9099             set allcwait 0
9100         } else {
9101             while {[incr a] <= $lim} {
9102                 set line [gets $f]
9103                 if {[llength $line] != 3} {error "bad line"}
9104                 set s [lindex $line 0]
9105                 set arcstart($a) $s
9106                 lappend arcout($s) $a
9107                 if {![info exists arcnos($s)]} {
9108                     lappend possible_seeds $s
9109                     set arcnos($s) {}
9110                 }
9111                 set e [lindex $line 1]
9112                 if {$e eq {}} {
9113                     set growing($a) 1
9114                 } else {
9115                     set arcend($a) $e
9116                     if {![info exists arcout($e)]} {
9117                         set arcout($e) {}
9118                     }
9119                 }
9120                 set arcids($a) [lindex $line 2]
9121                 foreach id $arcids($a) {
9122                     lappend allparents($s) $id
9123                     set s $id
9124                     lappend arcnos($id) $a
9125                 }
9126                 if {![info exists allparents($s)]} {
9127                     set allparents($s) {}
9128                 }
9129                 set arctags($a) {}
9130                 set archeads($a) {}
9131             }
9132             set nextarc [expr {$a - 1}]
9133         }
9134     } err]} {
9135         dropcache $err
9136         return 0
9137     }
9138     if {!$allcwait} {
9139         getallcommits
9140     }
9141     return $allcwait
9144 proc getcache {f} {
9145     global nextarc cachedarcs possible_seeds
9147     if {[catch {
9148         set line [gets $f]
9149         if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9150         # make sure it's an integer
9151         set cachedarcs [expr {int([lindex $line 1])}]
9152         if {$cachedarcs < 0} {error "bad number of arcs"}
9153         set nextarc 0
9154         set possible_seeds {}
9155         run readcache $f
9156     } err]} {
9157         dropcache $err
9158     }
9159     return 0
9162 proc dropcache {err} {
9163     global allcwait nextarc cachedarcs seeds
9165     #puts "dropping cache ($err)"
9166     foreach v {arcnos arcout arcids arcstart arcend growing \
9167                    arctags archeads allparents allchildren} {
9168         global $v
9169         catch {unset $v}
9170     }
9171     set allcwait 0
9172     set nextarc 0
9173     set cachedarcs 0
9174     set seeds {}
9175     getallcommits
9178 proc writecache {f} {
9179     global cachearc cachedarcs allccache
9180     global arcstart arcend arcnos arcids arcout
9182     set a $cachearc
9183     set lim $cachedarcs
9184     if {$lim - $a > 1000} {
9185         set lim [expr {$a + 1000}]
9186     }
9187     if {[catch {
9188         while {[incr a] <= $lim} {
9189             if {[info exists arcend($a)]} {
9190                 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9191             } else {
9192                 puts $f [list $arcstart($a) {} $arcids($a)]
9193             }
9194         }
9195     } err]} {
9196         catch {close $f}
9197         catch {file delete $allccache}
9198         #puts "writing cache failed ($err)"
9199         return 0
9200     }
9201     set cachearc [expr {$a - 1}]
9202     if {$a > $cachedarcs} {
9203         puts $f "1"
9204         close $f
9205         return 0
9206     }
9207     return 1
9210 proc savecache {} {
9211     global nextarc cachedarcs cachearc allccache
9213     if {$nextarc == $cachedarcs} return
9214     set cachearc 0
9215     set cachedarcs $nextarc
9216     catch {
9217         set f [open $allccache w]
9218         puts $f [list 1 $cachedarcs]
9219         run writecache $f
9220     }
9223 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9224 # or 0 if neither is true.
9225 proc anc_or_desc {a b} {
9226     global arcout arcstart arcend arcnos cached_isanc
9228     if {$arcnos($a) eq $arcnos($b)} {
9229         # Both are on the same arc(s); either both are the same BMP,
9230         # or if one is not a BMP, the other is also not a BMP or is
9231         # the BMP at end of the arc (and it only has 1 incoming arc).
9232         # Or both can be BMPs with no incoming arcs.
9233         if {$a eq $b || $arcnos($a) eq {}} {
9234             return 0
9235         }
9236         # assert {[llength $arcnos($a)] == 1}
9237         set arc [lindex $arcnos($a) 0]
9238         set i [lsearch -exact $arcids($arc) $a]
9239         set j [lsearch -exact $arcids($arc) $b]
9240         if {$i < 0 || $i > $j} {
9241             return 1
9242         } else {
9243             return -1
9244         }
9245     }
9247     if {![info exists arcout($a)]} {
9248         set arc [lindex $arcnos($a) 0]
9249         if {[info exists arcend($arc)]} {
9250             set aend $arcend($arc)
9251         } else {
9252             set aend {}
9253         }
9254         set a $arcstart($arc)
9255     } else {
9256         set aend $a
9257     }
9258     if {![info exists arcout($b)]} {
9259         set arc [lindex $arcnos($b) 0]
9260         if {[info exists arcend($arc)]} {
9261             set bend $arcend($arc)
9262         } else {
9263             set bend {}
9264         }
9265         set b $arcstart($arc)
9266     } else {
9267         set bend $b
9268     }
9269     if {$a eq $bend} {
9270         return 1
9271     }
9272     if {$b eq $aend} {
9273         return -1
9274     }
9275     if {[info exists cached_isanc($a,$bend)]} {
9276         if {$cached_isanc($a,$bend)} {
9277             return 1
9278         }
9279     }
9280     if {[info exists cached_isanc($b,$aend)]} {
9281         if {$cached_isanc($b,$aend)} {
9282             return -1
9283         }
9284         if {[info exists cached_isanc($a,$bend)]} {
9285             return 0
9286         }
9287     }
9289     set todo [list $a $b]
9290     set anc($a) a
9291     set anc($b) b
9292     for {set i 0} {$i < [llength $todo]} {incr i} {
9293         set x [lindex $todo $i]
9294         if {$anc($x) eq {}} {
9295             continue
9296         }
9297         foreach arc $arcnos($x) {
9298             set xd $arcstart($arc)
9299             if {$xd eq $bend} {
9300                 set cached_isanc($a,$bend) 1
9301                 set cached_isanc($b,$aend) 0
9302                 return 1
9303             } elseif {$xd eq $aend} {
9304                 set cached_isanc($b,$aend) 1
9305                 set cached_isanc($a,$bend) 0
9306                 return -1
9307             }
9308             if {![info exists anc($xd)]} {
9309                 set anc($xd) $anc($x)
9310                 lappend todo $xd
9311             } elseif {$anc($xd) ne $anc($x)} {
9312                 set anc($xd) {}
9313             }
9314         }
9315     }
9316     set cached_isanc($a,$bend) 0
9317     set cached_isanc($b,$aend) 0
9318     return 0
9321 # This identifies whether $desc has an ancestor that is
9322 # a growing tip of the graph and which is not an ancestor of $anc
9323 # and returns 0 if so and 1 if not.
9324 # If we subsequently discover a tag on such a growing tip, and that
9325 # turns out to be a descendent of $anc (which it could, since we
9326 # don't necessarily see children before parents), then $desc
9327 # isn't a good choice to display as a descendent tag of
9328 # $anc (since it is the descendent of another tag which is
9329 # a descendent of $anc).  Similarly, $anc isn't a good choice to
9330 # display as a ancestor tag of $desc.
9332 proc is_certain {desc anc} {
9333     global arcnos arcout arcstart arcend growing problems
9335     set certain {}
9336     if {[llength $arcnos($anc)] == 1} {
9337         # tags on the same arc are certain
9338         if {$arcnos($desc) eq $arcnos($anc)} {
9339             return 1
9340         }
9341         if {![info exists arcout($anc)]} {
9342             # if $anc is partway along an arc, use the start of the arc instead
9343             set a [lindex $arcnos($anc) 0]
9344             set anc $arcstart($a)
9345         }
9346     }
9347     if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9348         set x $desc
9349     } else {
9350         set a [lindex $arcnos($desc) 0]
9351         set x $arcend($a)
9352     }
9353     if {$x == $anc} {
9354         return 1
9355     }
9356     set anclist [list $x]
9357     set dl($x) 1
9358     set nnh 1
9359     set ngrowanc 0
9360     for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9361         set x [lindex $anclist $i]
9362         if {$dl($x)} {
9363             incr nnh -1
9364         }
9365         set done($x) 1
9366         foreach a $arcout($x) {
9367             if {[info exists growing($a)]} {
9368                 if {![info exists growanc($x)] && $dl($x)} {
9369                     set growanc($x) 1
9370                     incr ngrowanc
9371                 }
9372             } else {
9373                 set y $arcend($a)
9374                 if {[info exists dl($y)]} {
9375                     if {$dl($y)} {
9376                         if {!$dl($x)} {
9377                             set dl($y) 0
9378                             if {![info exists done($y)]} {
9379                                 incr nnh -1
9380                             }
9381                             if {[info exists growanc($x)]} {
9382                                 incr ngrowanc -1
9383                             }
9384                             set xl [list $y]
9385                             for {set k 0} {$k < [llength $xl]} {incr k} {
9386                                 set z [lindex $xl $k]
9387                                 foreach c $arcout($z) {
9388                                     if {[info exists arcend($c)]} {
9389                                         set v $arcend($c)
9390                                         if {[info exists dl($v)] && $dl($v)} {
9391                                             set dl($v) 0
9392                                             if {![info exists done($v)]} {
9393                                                 incr nnh -1
9394                                             }
9395                                             if {[info exists growanc($v)]} {
9396                                                 incr ngrowanc -1
9397                                             }
9398                                             lappend xl $v
9399                                         }
9400                                     }
9401                                 }
9402                             }
9403                         }
9404                     }
9405                 } elseif {$y eq $anc || !$dl($x)} {
9406                     set dl($y) 0
9407                     lappend anclist $y
9408                 } else {
9409                     set dl($y) 1
9410                     lappend anclist $y
9411                     incr nnh
9412                 }
9413             }
9414         }
9415     }
9416     foreach x [array names growanc] {
9417         if {$dl($x)} {
9418             return 0
9419         }
9420         return 0
9421     }
9422     return 1
9425 proc validate_arctags {a} {
9426     global arctags idtags
9428     set i -1
9429     set na $arctags($a)
9430     foreach id $arctags($a) {
9431         incr i
9432         if {![info exists idtags($id)]} {
9433             set na [lreplace $na $i $i]
9434             incr i -1
9435         }
9436     }
9437     set arctags($a) $na
9440 proc validate_archeads {a} {
9441     global archeads idheads
9443     set i -1
9444     set na $archeads($a)
9445     foreach id $archeads($a) {
9446         incr i
9447         if {![info exists idheads($id)]} {
9448             set na [lreplace $na $i $i]
9449             incr i -1
9450         }
9451     }
9452     set archeads($a) $na
9455 # Return the list of IDs that have tags that are descendents of id,
9456 # ignoring IDs that are descendents of IDs already reported.
9457 proc desctags {id} {
9458     global arcnos arcstart arcids arctags idtags allparents
9459     global growing cached_dtags
9461     if {![info exists allparents($id)]} {
9462         return {}
9463     }
9464     set t1 [clock clicks -milliseconds]
9465     set argid $id
9466     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9467         # part-way along an arc; check that arc first
9468         set a [lindex $arcnos($id) 0]
9469         if {$arctags($a) ne {}} {
9470             validate_arctags $a
9471             set i [lsearch -exact $arcids($a) $id]
9472             set tid {}
9473             foreach t $arctags($a) {
9474                 set j [lsearch -exact $arcids($a) $t]
9475                 if {$j >= $i} break
9476                 set tid $t
9477             }
9478             if {$tid ne {}} {
9479                 return $tid
9480             }
9481         }
9482         set id $arcstart($a)
9483         if {[info exists idtags($id)]} {
9484             return $id
9485         }
9486     }
9487     if {[info exists cached_dtags($id)]} {
9488         return $cached_dtags($id)
9489     }
9491     set origid $id
9492     set todo [list $id]
9493     set queued($id) 1
9494     set nc 1
9495     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9496         set id [lindex $todo $i]
9497         set done($id) 1
9498         set ta [info exists hastaggedancestor($id)]
9499         if {!$ta} {
9500             incr nc -1
9501         }
9502         # ignore tags on starting node
9503         if {!$ta && $i > 0} {
9504             if {[info exists idtags($id)]} {
9505                 set tagloc($id) $id
9506                 set ta 1
9507             } elseif {[info exists cached_dtags($id)]} {
9508                 set tagloc($id) $cached_dtags($id)
9509                 set ta 1
9510             }
9511         }
9512         foreach a $arcnos($id) {
9513             set d $arcstart($a)
9514             if {!$ta && $arctags($a) ne {}} {
9515                 validate_arctags $a
9516                 if {$arctags($a) ne {}} {
9517                     lappend tagloc($id) [lindex $arctags($a) end]
9518                 }
9519             }
9520             if {$ta || $arctags($a) ne {}} {
9521                 set tomark [list $d]
9522                 for {set j 0} {$j < [llength $tomark]} {incr j} {
9523                     set dd [lindex $tomark $j]
9524                     if {![info exists hastaggedancestor($dd)]} {
9525                         if {[info exists done($dd)]} {
9526                             foreach b $arcnos($dd) {
9527                                 lappend tomark $arcstart($b)
9528                             }
9529                             if {[info exists tagloc($dd)]} {
9530                                 unset tagloc($dd)
9531                             }
9532                         } elseif {[info exists queued($dd)]} {
9533                             incr nc -1
9534                         }
9535                         set hastaggedancestor($dd) 1
9536                     }
9537                 }
9538             }
9539             if {![info exists queued($d)]} {
9540                 lappend todo $d
9541                 set queued($d) 1
9542                 if {![info exists hastaggedancestor($d)]} {
9543                     incr nc
9544                 }
9545             }
9546         }
9547     }
9548     set tags {}
9549     foreach id [array names tagloc] {
9550         if {![info exists hastaggedancestor($id)]} {
9551             foreach t $tagloc($id) {
9552                 if {[lsearch -exact $tags $t] < 0} {
9553                     lappend tags $t
9554                 }
9555             }
9556         }
9557     }
9558     set t2 [clock clicks -milliseconds]
9559     set loopix $i
9561     # remove tags that are descendents of other tags
9562     for {set i 0} {$i < [llength $tags]} {incr i} {
9563         set a [lindex $tags $i]
9564         for {set j 0} {$j < $i} {incr j} {
9565             set b [lindex $tags $j]
9566             set r [anc_or_desc $a $b]
9567             if {$r == 1} {
9568                 set tags [lreplace $tags $j $j]
9569                 incr j -1
9570                 incr i -1
9571             } elseif {$r == -1} {
9572                 set tags [lreplace $tags $i $i]
9573                 incr i -1
9574                 break
9575             }
9576         }
9577     }
9579     if {[array names growing] ne {}} {
9580         # graph isn't finished, need to check if any tag could get
9581         # eclipsed by another tag coming later.  Simply ignore any
9582         # tags that could later get eclipsed.
9583         set ctags {}
9584         foreach t $tags {
9585             if {[is_certain $t $origid]} {
9586                 lappend ctags $t
9587             }
9588         }
9589         if {$tags eq $ctags} {
9590             set cached_dtags($origid) $tags
9591         } else {
9592             set tags $ctags
9593         }
9594     } else {
9595         set cached_dtags($origid) $tags
9596     }
9597     set t3 [clock clicks -milliseconds]
9598     if {0 && $t3 - $t1 >= 100} {
9599         puts "iterating descendents ($loopix/[llength $todo] nodes) took\
9600             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9601     }
9602     return $tags
9605 proc anctags {id} {
9606     global arcnos arcids arcout arcend arctags idtags allparents
9607     global growing cached_atags
9609     if {![info exists allparents($id)]} {
9610         return {}
9611     }
9612     set t1 [clock clicks -milliseconds]
9613     set argid $id
9614     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9615         # part-way along an arc; check that arc first
9616         set a [lindex $arcnos($id) 0]
9617         if {$arctags($a) ne {}} {
9618             validate_arctags $a
9619             set i [lsearch -exact $arcids($a) $id]
9620             foreach t $arctags($a) {
9621                 set j [lsearch -exact $arcids($a) $t]
9622                 if {$j > $i} {
9623                     return $t
9624                 }
9625             }
9626         }
9627         if {![info exists arcend($a)]} {
9628             return {}
9629         }
9630         set id $arcend($a)
9631         if {[info exists idtags($id)]} {
9632             return $id
9633         }
9634     }
9635     if {[info exists cached_atags($id)]} {
9636         return $cached_atags($id)
9637     }
9639     set origid $id
9640     set todo [list $id]
9641     set queued($id) 1
9642     set taglist {}
9643     set nc 1
9644     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9645         set id [lindex $todo $i]
9646         set done($id) 1
9647         set td [info exists hastaggeddescendent($id)]
9648         if {!$td} {
9649             incr nc -1
9650         }
9651         # ignore tags on starting node
9652         if {!$td && $i > 0} {
9653             if {[info exists idtags($id)]} {
9654                 set tagloc($id) $id
9655                 set td 1
9656             } elseif {[info exists cached_atags($id)]} {
9657                 set tagloc($id) $cached_atags($id)
9658                 set td 1
9659             }
9660         }
9661         foreach a $arcout($id) {
9662             if {!$td && $arctags($a) ne {}} {
9663                 validate_arctags $a
9664                 if {$arctags($a) ne {}} {
9665                     lappend tagloc($id) [lindex $arctags($a) 0]
9666                 }
9667             }
9668             if {![info exists arcend($a)]} continue
9669             set d $arcend($a)
9670             if {$td || $arctags($a) ne {}} {
9671                 set tomark [list $d]
9672                 for {set j 0} {$j < [llength $tomark]} {incr j} {
9673                     set dd [lindex $tomark $j]
9674                     if {![info exists hastaggeddescendent($dd)]} {
9675                         if {[info exists done($dd)]} {
9676                             foreach b $arcout($dd) {
9677                                 if {[info exists arcend($b)]} {
9678                                     lappend tomark $arcend($b)
9679                                 }
9680                             }
9681                             if {[info exists tagloc($dd)]} {
9682                                 unset tagloc($dd)
9683                             }
9684                         } elseif {[info exists queued($dd)]} {
9685                             incr nc -1
9686                         }
9687                         set hastaggeddescendent($dd) 1
9688                     }
9689                 }
9690             }
9691             if {![info exists queued($d)]} {
9692                 lappend todo $d
9693                 set queued($d) 1
9694                 if {![info exists hastaggeddescendent($d)]} {
9695                     incr nc
9696                 }
9697             }
9698         }
9699     }
9700     set t2 [clock clicks -milliseconds]
9701     set loopix $i
9702     set tags {}
9703     foreach id [array names tagloc] {
9704         if {![info exists hastaggeddescendent($id)]} {
9705             foreach t $tagloc($id) {
9706                 if {[lsearch -exact $tags $t] < 0} {
9707                     lappend tags $t
9708                 }
9709             }
9710         }
9711     }
9713     # remove tags that are ancestors of other tags
9714     for {set i 0} {$i < [llength $tags]} {incr i} {
9715         set a [lindex $tags $i]
9716         for {set j 0} {$j < $i} {incr j} {
9717             set b [lindex $tags $j]
9718             set r [anc_or_desc $a $b]
9719             if {$r == -1} {
9720                 set tags [lreplace $tags $j $j]
9721                 incr j -1
9722                 incr i -1
9723             } elseif {$r == 1} {
9724                 set tags [lreplace $tags $i $i]
9725                 incr i -1
9726                 break
9727             }
9728         }
9729     }
9731     if {[array names growing] ne {}} {
9732         # graph isn't finished, need to check if any tag could get
9733         # eclipsed by another tag coming later.  Simply ignore any
9734         # tags that could later get eclipsed.
9735         set ctags {}
9736         foreach t $tags {
9737             if {[is_certain $origid $t]} {
9738                 lappend ctags $t
9739             }
9740         }
9741         if {$tags eq $ctags} {
9742             set cached_atags($origid) $tags
9743         } else {
9744             set tags $ctags
9745         }
9746     } else {
9747         set cached_atags($origid) $tags
9748     }
9749     set t3 [clock clicks -milliseconds]
9750     if {0 && $t3 - $t1 >= 100} {
9751         puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
9752             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
9753     }
9754     return $tags
9757 # Return the list of IDs that have heads that are descendents of id,
9758 # including id itself if it has a head.
9759 proc descheads {id} {
9760     global arcnos arcstart arcids archeads idheads cached_dheads
9761     global allparents
9763     if {![info exists allparents($id)]} {
9764         return {}
9765     }
9766     set aret {}
9767     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9768         # part-way along an arc; check it first
9769         set a [lindex $arcnos($id) 0]
9770         if {$archeads($a) ne {}} {
9771             validate_archeads $a
9772             set i [lsearch -exact $arcids($a) $id]
9773             foreach t $archeads($a) {
9774                 set j [lsearch -exact $arcids($a) $t]
9775                 if {$j > $i} break
9776                 lappend aret $t
9777             }
9778         }
9779         set id $arcstart($a)
9780     }
9781     set origid $id
9782     set todo [list $id]
9783     set seen($id) 1
9784     set ret {}
9785     for {set i 0} {$i < [llength $todo]} {incr i} {
9786         set id [lindex $todo $i]
9787         if {[info exists cached_dheads($id)]} {
9788             set ret [concat $ret $cached_dheads($id)]
9789         } else {
9790             if {[info exists idheads($id)]} {
9791                 lappend ret $id
9792             }
9793             foreach a $arcnos($id) {
9794                 if {$archeads($a) ne {}} {
9795                     validate_archeads $a
9796                     if {$archeads($a) ne {}} {
9797                         set ret [concat $ret $archeads($a)]
9798                     }
9799                 }
9800                 set d $arcstart($a)
9801                 if {![info exists seen($d)]} {
9802                     lappend todo $d
9803                     set seen($d) 1
9804                 }
9805             }
9806         }
9807     }
9808     set ret [lsort -unique $ret]
9809     set cached_dheads($origid) $ret
9810     return [concat $ret $aret]
9813 proc addedtag {id} {
9814     global arcnos arcout cached_dtags cached_atags
9816     if {![info exists arcnos($id)]} return
9817     if {![info exists arcout($id)]} {
9818         recalcarc [lindex $arcnos($id) 0]
9819     }
9820     catch {unset cached_dtags}
9821     catch {unset cached_atags}
9824 proc addedhead {hid head} {
9825     global arcnos arcout cached_dheads
9827     if {![info exists arcnos($hid)]} return
9828     if {![info exists arcout($hid)]} {
9829         recalcarc [lindex $arcnos($hid) 0]
9830     }
9831     catch {unset cached_dheads}
9834 proc removedhead {hid head} {
9835     global cached_dheads
9837     catch {unset cached_dheads}
9840 proc movedhead {hid head} {
9841     global arcnos arcout cached_dheads
9843     if {![info exists arcnos($hid)]} return
9844     if {![info exists arcout($hid)]} {
9845         recalcarc [lindex $arcnos($hid) 0]
9846     }
9847     catch {unset cached_dheads}
9850 proc changedrefs {} {
9851     global cached_dheads cached_dtags cached_atags
9852     global arctags archeads arcnos arcout idheads idtags
9854     foreach id [concat [array names idheads] [array names idtags]] {
9855         if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
9856             set a [lindex $arcnos($id) 0]
9857             if {![info exists donearc($a)]} {
9858                 recalcarc $a
9859                 set donearc($a) 1
9860             }
9861         }
9862     }
9863     catch {unset cached_dtags}
9864     catch {unset cached_atags}
9865     catch {unset cached_dheads}
9868 proc rereadrefs {} {
9869     global idtags idheads idotherrefs mainheadid
9871     set refids [concat [array names idtags] \
9872                     [array names idheads] [array names idotherrefs]]
9873     foreach id $refids {
9874         if {![info exists ref($id)]} {
9875             set ref($id) [listrefs $id]
9876         }
9877     }
9878     set oldmainhead $mainheadid
9879     readrefs
9880     changedrefs
9881     set refids [lsort -unique [concat $refids [array names idtags] \
9882                         [array names idheads] [array names idotherrefs]]]
9883     foreach id $refids {
9884         set v [listrefs $id]
9885         if {![info exists ref($id)] || $ref($id) != $v} {
9886             redrawtags $id
9887         }
9888     }
9889     if {$oldmainhead ne $mainheadid} {
9890         redrawtags $oldmainhead
9891         redrawtags $mainheadid
9892     }
9893     run refill_reflist
9896 proc listrefs {id} {
9897     global idtags idheads idotherrefs
9899     set x {}
9900     if {[info exists idtags($id)]} {
9901         set x $idtags($id)
9902     }
9903     set y {}
9904     if {[info exists idheads($id)]} {
9905         set y $idheads($id)
9906     }
9907     set z {}
9908     if {[info exists idotherrefs($id)]} {
9909         set z $idotherrefs($id)
9910     }
9911     return [list $x $y $z]
9914 proc showtag {tag isnew} {
9915     global ctext tagcontents tagids linknum tagobjid
9917     if {$isnew} {
9918         addtohistory [list showtag $tag 0]
9919     }
9920     $ctext conf -state normal
9921     clear_ctext
9922     settabs 0
9923     set linknum 0
9924     if {![info exists tagcontents($tag)]} {
9925         catch {
9926             set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
9927         }
9928     }
9929     if {[info exists tagcontents($tag)]} {
9930         set text $tagcontents($tag)
9931     } else {
9932         set text "[mc "Tag"]: $tag\n[mc "Id"]:  $tagids($tag)"
9933     }
9934     appendwithlinks $text {}
9935     $ctext conf -state disabled
9936     init_flist {}
9939 proc doquit {} {
9940     global stopped
9941     global gitktmpdir
9943     set stopped 100
9944     savestuff .
9945     destroy .
9947     if {[info exists gitktmpdir]} {
9948         catch {file delete -force $gitktmpdir}
9949     }
9952 proc mkfontdisp {font top which} {
9953     global fontattr fontpref $font
9955     set fontpref($font) [set $font]
9956     button $top.${font}but -text $which -font optionfont \
9957         -command [list choosefont $font $which]
9958     label $top.$font -relief flat -font $font \
9959         -text $fontattr($font,family) -justify left
9960     grid x $top.${font}but $top.$font -sticky w
9963 proc choosefont {font which} {
9964     global fontparam fontlist fonttop fontattr
9965     global prefstop
9967     set fontparam(which) $which
9968     set fontparam(font) $font
9969     set fontparam(family) [font actual $font -family]
9970     set fontparam(size) $fontattr($font,size)
9971     set fontparam(weight) $fontattr($font,weight)
9972     set fontparam(slant) $fontattr($font,slant)
9973     set top .gitkfont
9974     set fonttop $top
9975     if {![winfo exists $top]} {
9976         font create sample
9977         eval font config sample [font actual $font]
9978         toplevel $top
9979         make_transient $top $prefstop
9980         wm title $top [mc "Gitk font chooser"]
9981         label $top.l -textvariable fontparam(which)
9982         pack $top.l -side top
9983         set fontlist [lsort [font families]]
9984         frame $top.f
9985         listbox $top.f.fam -listvariable fontlist \
9986             -yscrollcommand [list $top.f.sb set]
9987         bind $top.f.fam <<ListboxSelect>> selfontfam
9988         scrollbar $top.f.sb -command [list $top.f.fam yview]
9989         pack $top.f.sb -side right -fill y
9990         pack $top.f.fam -side left -fill both -expand 1
9991         pack $top.f -side top -fill both -expand 1
9992         frame $top.g
9993         spinbox $top.g.size -from 4 -to 40 -width 4 \
9994             -textvariable fontparam(size) \
9995             -validatecommand {string is integer -strict %s}
9996         checkbutton $top.g.bold -padx 5 \
9997             -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
9998             -variable fontparam(weight) -onvalue bold -offvalue normal
9999         checkbutton $top.g.ital -padx 5 \
10000             -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0  \
10001             -variable fontparam(slant) -onvalue italic -offvalue roman
10002         pack $top.g.size $top.g.bold $top.g.ital -side left
10003         pack $top.g -side top
10004         canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10005             -background white
10006         $top.c create text 100 25 -anchor center -text $which -font sample \
10007             -fill black -tags text
10008         bind $top.c <Configure> [list centertext $top.c]
10009         pack $top.c -side top -fill x
10010         frame $top.buts
10011         button $top.buts.ok -text [mc "OK"] -command fontok -default active
10012         button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10013         bind $top <Key-Return> fontok
10014         bind $top <Key-Escape> fontcan
10015         grid $top.buts.ok $top.buts.can
10016         grid columnconfigure $top.buts 0 -weight 1 -uniform a
10017         grid columnconfigure $top.buts 1 -weight 1 -uniform a
10018         pack $top.buts -side bottom -fill x
10019         trace add variable fontparam write chg_fontparam
10020     } else {
10021         raise $top
10022         $top.c itemconf text -text $which
10023     }
10024     set i [lsearch -exact $fontlist $fontparam(family)]
10025     if {$i >= 0} {
10026         $top.f.fam selection set $i
10027         $top.f.fam see $i
10028     }
10031 proc centertext {w} {
10032     $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10035 proc fontok {} {
10036     global fontparam fontpref prefstop
10038     set f $fontparam(font)
10039     set fontpref($f) [list $fontparam(family) $fontparam(size)]
10040     if {$fontparam(weight) eq "bold"} {
10041         lappend fontpref($f) "bold"
10042     }
10043     if {$fontparam(slant) eq "italic"} {
10044         lappend fontpref($f) "italic"
10045     }
10046     set w $prefstop.$f
10047     $w conf -text $fontparam(family) -font $fontpref($f)
10048         
10049     fontcan
10052 proc fontcan {} {
10053     global fonttop fontparam
10055     if {[info exists fonttop]} {
10056         catch {destroy $fonttop}
10057         catch {font delete sample}
10058         unset fonttop
10059         unset fontparam
10060     }
10063 proc selfontfam {} {
10064     global fonttop fontparam
10066     set i [$fonttop.f.fam curselection]
10067     if {$i ne {}} {
10068         set fontparam(family) [$fonttop.f.fam get $i]
10069     }
10072 proc chg_fontparam {v sub op} {
10073     global fontparam
10075     font config sample -$sub $fontparam($sub)
10078 proc doprefs {} {
10079     global maxwidth maxgraphpct
10080     global oldprefs prefstop showneartags showlocalchanges
10081     global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10082     global tabstop limitdiffs autoselect extdifftool perfile_attrs
10084     set top .gitkprefs
10085     set prefstop $top
10086     if {[winfo exists $top]} {
10087         raise $top
10088         return
10089     }
10090     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10091                    limitdiffs tabstop perfile_attrs} {
10092         set oldprefs($v) [set $v]
10093     }
10094     toplevel $top
10095     wm title $top [mc "Gitk preferences"]
10096     make_transient $top .
10097     label $top.ldisp -text [mc "Commit list display options"]
10098     grid $top.ldisp - -sticky w -pady 10
10099     label $top.spacer -text " "
10100     label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
10101         -font optionfont
10102     spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10103     grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10104     label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
10105         -font optionfont
10106     spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10107     grid x $top.maxpctl $top.maxpct -sticky w
10108     checkbutton $top.showlocal -text [mc "Show local changes"] \
10109         -font optionfont -variable showlocalchanges
10110     grid x $top.showlocal -sticky w
10111     checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10112         -font optionfont -variable autoselect
10113     grid x $top.autoselect -sticky w
10115     label $top.ddisp -text [mc "Diff display options"]
10116     grid $top.ddisp - -sticky w -pady 10
10117     label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
10118     spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10119     grid x $top.tabstopl $top.tabstop -sticky w
10120     checkbutton $top.ntag -text [mc "Display nearby tags"] \
10121         -font optionfont -variable showneartags
10122     grid x $top.ntag -sticky w
10123     checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10124         -font optionfont -variable limitdiffs
10125     grid x $top.ldiff -sticky w
10126     checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10127         -font optionfont -variable perfile_attrs
10128     grid x $top.lattr -sticky w
10130     entry $top.extdifft -textvariable extdifftool
10131     frame $top.extdifff
10132     label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
10133         -padx 10
10134     button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
10135         -command choose_extdiff
10136     pack $top.extdifff.l $top.extdifff.b -side left
10137     grid x $top.extdifff $top.extdifft -sticky w
10139     label $top.cdisp -text [mc "Colors: press to choose"]
10140     grid $top.cdisp - -sticky w -pady 10
10141     label $top.bg -padx 40 -relief sunk -background $bgcolor
10142     button $top.bgbut -text [mc "Background"] -font optionfont \
10143         -command [list choosecolor bgcolor {} $top.bg background setbg]
10144     grid x $top.bgbut $top.bg -sticky w
10145     label $top.fg -padx 40 -relief sunk -background $fgcolor
10146     button $top.fgbut -text [mc "Foreground"] -font optionfont \
10147         -command [list choosecolor fgcolor {} $top.fg foreground setfg]
10148     grid x $top.fgbut $top.fg -sticky w
10149     label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10150     button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
10151         -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
10152                       [list $ctext tag conf d0 -foreground]]
10153     grid x $top.diffoldbut $top.diffold -sticky w
10154     label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10155     button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
10156         -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
10157                       [list $ctext tag conf dresult -foreground]]
10158     grid x $top.diffnewbut $top.diffnew -sticky w
10159     label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10160     button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
10161         -command [list choosecolor diffcolors 2 $top.hunksep \
10162                       "diff hunk header" \
10163                       [list $ctext tag conf hunksep -foreground]]
10164     grid x $top.hunksepbut $top.hunksep -sticky w
10165     label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10166     button $top.markbgbut -text [mc "Marked line bg"] -font optionfont \
10167         -command [list choosecolor markbgcolor {} $top.markbgsep \
10168                       [mc "marked line background"] \
10169                       [list $ctext tag conf omark -background]]
10170     grid x $top.markbgbut $top.markbgsep -sticky w
10171     label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10172     button $top.selbgbut -text [mc "Select bg"] -font optionfont \
10173         -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
10174     grid x $top.selbgbut $top.selbgsep -sticky w
10176     label $top.cfont -text [mc "Fonts: press to choose"]
10177     grid $top.cfont - -sticky w -pady 10
10178     mkfontdisp mainfont $top [mc "Main font"]
10179     mkfontdisp textfont $top [mc "Diff display font"]
10180     mkfontdisp uifont $top [mc "User interface font"]
10182     frame $top.buts
10183     button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10184     button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10185     bind $top <Key-Return> prefsok
10186     bind $top <Key-Escape> prefscan
10187     grid $top.buts.ok $top.buts.can
10188     grid columnconfigure $top.buts 0 -weight 1 -uniform a
10189     grid columnconfigure $top.buts 1 -weight 1 -uniform a
10190     grid $top.buts - - -pady 10 -sticky ew
10191     bind $top <Visibility> "focus $top.buts.ok"
10194 proc choose_extdiff {} {
10195     global extdifftool
10197     set prog [tk_getOpenFile -title "External diff tool" -multiple false]
10198     if {$prog ne {}} {
10199         set extdifftool $prog
10200     }
10203 proc choosecolor {v vi w x cmd} {
10204     global $v
10206     set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10207                -title [mc "Gitk: choose color for %s" $x]]
10208     if {$c eq {}} return
10209     $w conf -background $c
10210     lset $v $vi $c
10211     eval $cmd $c
10214 proc setselbg {c} {
10215     global bglist cflist
10216     foreach w $bglist {
10217         $w configure -selectbackground $c
10218     }
10219     $cflist tag configure highlight \
10220         -background [$cflist cget -selectbackground]
10221     allcanvs itemconf secsel -fill $c
10224 proc setbg {c} {
10225     global bglist
10227     foreach w $bglist {
10228         $w conf -background $c
10229     }
10232 proc setfg {c} {
10233     global fglist canv
10235     foreach w $fglist {
10236         $w conf -foreground $c
10237     }
10238     allcanvs itemconf text -fill $c
10239     $canv itemconf circle -outline $c
10242 proc prefscan {} {
10243     global oldprefs prefstop
10245     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10246                    limitdiffs tabstop perfile_attrs} {
10247         global $v
10248         set $v $oldprefs($v)
10249     }
10250     catch {destroy $prefstop}
10251     unset prefstop
10252     fontcan
10255 proc prefsok {} {
10256     global maxwidth maxgraphpct
10257     global oldprefs prefstop showneartags showlocalchanges
10258     global fontpref mainfont textfont uifont
10259     global limitdiffs treediffs perfile_attrs
10261     catch {destroy $prefstop}
10262     unset prefstop
10263     fontcan
10264     set fontchanged 0
10265     if {$mainfont ne $fontpref(mainfont)} {
10266         set mainfont $fontpref(mainfont)
10267         parsefont mainfont $mainfont
10268         eval font configure mainfont [fontflags mainfont]
10269         eval font configure mainfontbold [fontflags mainfont 1]
10270         setcoords
10271         set fontchanged 1
10272     }
10273     if {$textfont ne $fontpref(textfont)} {
10274         set textfont $fontpref(textfont)
10275         parsefont textfont $textfont
10276         eval font configure textfont [fontflags textfont]
10277         eval font configure textfontbold [fontflags textfont 1]
10278     }
10279     if {$uifont ne $fontpref(uifont)} {
10280         set uifont $fontpref(uifont)
10281         parsefont uifont $uifont
10282         eval font configure uifont [fontflags uifont]
10283     }
10284     settabs
10285     if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10286         if {$showlocalchanges} {
10287             doshowlocalchanges
10288         } else {
10289             dohidelocalchanges
10290         }
10291     }
10292     if {$limitdiffs != $oldprefs(limitdiffs) ||
10293         ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10294         # treediffs elements are limited by path;
10295         # won't have encodings cached if perfile_attrs was just turned on
10296         catch {unset treediffs}
10297     }
10298     if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10299         || $maxgraphpct != $oldprefs(maxgraphpct)} {
10300         redisplay
10301     } elseif {$showneartags != $oldprefs(showneartags) ||
10302           $limitdiffs != $oldprefs(limitdiffs)} {
10303         reselectline
10304     }
10307 proc formatdate {d} {
10308     global datetimeformat
10309     if {$d ne {}} {
10310         set d [clock format $d -format $datetimeformat]
10311     }
10312     return $d
10315 # This list of encoding names and aliases is distilled from
10316 # http://www.iana.org/assignments/character-sets.
10317 # Not all of them are supported by Tcl.
10318 set encoding_aliases {
10319     { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10320       ISO646-US US-ASCII us IBM367 cp367 csASCII }
10321     { ISO-10646-UTF-1 csISO10646UTF1 }
10322     { ISO_646.basic:1983 ref csISO646basic1983 }
10323     { INVARIANT csINVARIANT }
10324     { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10325     { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10326     { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10327     { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10328     { NATS-DANO iso-ir-9-1 csNATSDANO }
10329     { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10330     { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10331     { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10332     { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10333     { ISO-2022-KR csISO2022KR }
10334     { EUC-KR csEUCKR }
10335     { ISO-2022-JP csISO2022JP }
10336     { ISO-2022-JP-2 csISO2022JP2 }
10337     { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10338       csISO13JISC6220jp }
10339     { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10340     { IT iso-ir-15 ISO646-IT csISO15Italian }
10341     { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10342     { ES iso-ir-17 ISO646-ES csISO17Spanish }
10343     { greek7-old iso-ir-18 csISO18Greek7Old }
10344     { latin-greek iso-ir-19 csISO19LatinGreek }
10345     { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10346     { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10347     { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10348     { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10349     { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10350     { BS_viewdata iso-ir-47 csISO47BSViewdata }
10351     { INIS iso-ir-49 csISO49INIS }
10352     { INIS-8 iso-ir-50 csISO50INIS8 }
10353     { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10354     { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10355     { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10356     { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10357     { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10358     { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10359       csISO60Norwegian1 }
10360     { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10361     { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10362     { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10363     { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10364     { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10365     { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10366     { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10367     { greek7 iso-ir-88 csISO88Greek7 }
10368     { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10369     { iso-ir-90 csISO90 }
10370     { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10371     { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10372       csISO92JISC62991984b }
10373     { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10374     { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10375     { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10376       csISO95JIS62291984handadd }
10377     { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10378     { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10379     { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10380     { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10381       CP819 csISOLatin1 }
10382     { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10383     { T.61-7bit iso-ir-102 csISO102T617bit }
10384     { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10385     { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10386     { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10387     { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10388     { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10389     { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10390     { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10391     { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10392       arabic csISOLatinArabic }
10393     { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10394     { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10395     { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10396       greek greek8 csISOLatinGreek }
10397     { T.101-G2 iso-ir-128 csISO128T101G2 }
10398     { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10399       csISOLatinHebrew }
10400     { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10401     { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10402     { CSN_369103 iso-ir-139 csISO139CSN369103 }
10403     { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10404     { ISO_6937-2-add iso-ir-142 csISOTextComm }
10405     { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10406     { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10407       csISOLatinCyrillic }
10408     { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10409     { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10410     { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10411     { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10412     { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10413     { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10414     { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10415     { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10416     { ISO_10367-box iso-ir-155 csISO10367Box }
10417     { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10418     { latin-lap lap iso-ir-158 csISO158Lap }
10419     { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10420     { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10421     { us-dk csUSDK }
10422     { dk-us csDKUS }
10423     { JIS_X0201 X0201 csHalfWidthKatakana }
10424     { KSC5636 ISO646-KR csKSC5636 }
10425     { ISO-10646-UCS-2 csUnicode }
10426     { ISO-10646-UCS-4 csUCS4 }
10427     { DEC-MCS dec csDECMCS }
10428     { hp-roman8 roman8 r8 csHPRoman8 }
10429     { macintosh mac csMacintosh }
10430     { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10431       csIBM037 }
10432     { IBM038 EBCDIC-INT cp038 csIBM038 }
10433     { IBM273 CP273 csIBM273 }
10434     { IBM274 EBCDIC-BE CP274 csIBM274 }
10435     { IBM275 EBCDIC-BR cp275 csIBM275 }
10436     { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10437     { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10438     { IBM280 CP280 ebcdic-cp-it csIBM280 }
10439     { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10440     { IBM284 CP284 ebcdic-cp-es csIBM284 }
10441     { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10442     { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10443     { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10444     { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10445     { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10446     { IBM424 cp424 ebcdic-cp-he csIBM424 }
10447     { IBM437 cp437 437 csPC8CodePage437 }
10448     { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10449     { IBM775 cp775 csPC775Baltic }
10450     { IBM850 cp850 850 csPC850Multilingual }
10451     { IBM851 cp851 851 csIBM851 }
10452     { IBM852 cp852 852 csPCp852 }
10453     { IBM855 cp855 855 csIBM855 }
10454     { IBM857 cp857 857 csIBM857 }
10455     { IBM860 cp860 860 csIBM860 }
10456     { IBM861 cp861 861 cp-is csIBM861 }
10457     { IBM862 cp862 862 csPC862LatinHebrew }
10458     { IBM863 cp863 863 csIBM863 }
10459     { IBM864 cp864 csIBM864 }
10460     { IBM865 cp865 865 csIBM865 }
10461     { IBM866 cp866 866 csIBM866 }
10462     { IBM868 CP868 cp-ar csIBM868 }
10463     { IBM869 cp869 869 cp-gr csIBM869 }
10464     { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10465     { IBM871 CP871 ebcdic-cp-is csIBM871 }
10466     { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10467     { IBM891 cp891 csIBM891 }
10468     { IBM903 cp903 csIBM903 }
10469     { IBM904 cp904 904 csIBBM904 }
10470     { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10471     { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10472     { IBM1026 CP1026 csIBM1026 }
10473     { EBCDIC-AT-DE csIBMEBCDICATDE }
10474     { EBCDIC-AT-DE-A csEBCDICATDEA }
10475     { EBCDIC-CA-FR csEBCDICCAFR }
10476     { EBCDIC-DK-NO csEBCDICDKNO }
10477     { EBCDIC-DK-NO-A csEBCDICDKNOA }
10478     { EBCDIC-FI-SE csEBCDICFISE }
10479     { EBCDIC-FI-SE-A csEBCDICFISEA }
10480     { EBCDIC-FR csEBCDICFR }
10481     { EBCDIC-IT csEBCDICIT }
10482     { EBCDIC-PT csEBCDICPT }
10483     { EBCDIC-ES csEBCDICES }
10484     { EBCDIC-ES-A csEBCDICESA }
10485     { EBCDIC-ES-S csEBCDICESS }
10486     { EBCDIC-UK csEBCDICUK }
10487     { EBCDIC-US csEBCDICUS }
10488     { UNKNOWN-8BIT csUnknown8BiT }
10489     { MNEMONIC csMnemonic }
10490     { MNEM csMnem }
10491     { VISCII csVISCII }
10492     { VIQR csVIQR }
10493     { KOI8-R csKOI8R }
10494     { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10495     { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10496     { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10497     { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10498     { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10499     { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10500     { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10501     { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10502     { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10503     { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10504     { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10505     { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10506     { IBM1047 IBM-1047 }
10507     { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10508     { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10509     { UNICODE-1-1 csUnicode11 }
10510     { CESU-8 csCESU-8 }
10511     { BOCU-1 csBOCU-1 }
10512     { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10513     { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10514       l8 }
10515     { ISO-8859-15 ISO_8859-15 Latin-9 }
10516     { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10517     { GBK CP936 MS936 windows-936 }
10518     { JIS_Encoding csJISEncoding }
10519     { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10520     { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10521       EUC-JP }
10522     { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10523     { ISO-10646-UCS-Basic csUnicodeASCII }
10524     { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10525     { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10526     { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10527     { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10528     { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10529     { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10530     { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10531     { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10532     { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10533     { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10534     { Adobe-Standard-Encoding csAdobeStandardEncoding }
10535     { Ventura-US csVenturaUS }
10536     { Ventura-International csVenturaInternational }
10537     { PC8-Danish-Norwegian csPC8DanishNorwegian }
10538     { PC8-Turkish csPC8Turkish }
10539     { IBM-Symbols csIBMSymbols }
10540     { IBM-Thai csIBMThai }
10541     { HP-Legal csHPLegal }
10542     { HP-Pi-font csHPPiFont }
10543     { HP-Math8 csHPMath8 }
10544     { Adobe-Symbol-Encoding csHPPSMath }
10545     { HP-DeskTop csHPDesktop }
10546     { Ventura-Math csVenturaMath }
10547     { Microsoft-Publishing csMicrosoftPublishing }
10548     { Windows-31J csWindows31J }
10549     { GB2312 csGB2312 }
10550     { Big5 csBig5 }
10553 proc tcl_encoding {enc} {
10554     global encoding_aliases tcl_encoding_cache
10555     if {[info exists tcl_encoding_cache($enc)]} {
10556         return $tcl_encoding_cache($enc)
10557     }
10558     set names [encoding names]
10559     set lcnames [string tolower $names]
10560     set enc [string tolower $enc]
10561     set i [lsearch -exact $lcnames $enc]
10562     if {$i < 0} {
10563         # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
10564         if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
10565             set i [lsearch -exact $lcnames $encx]
10566         }
10567     }
10568     if {$i < 0} {
10569         foreach l $encoding_aliases {
10570             set ll [string tolower $l]
10571             if {[lsearch -exact $ll $enc] < 0} continue
10572             # look through the aliases for one that tcl knows about
10573             foreach e $ll {
10574                 set i [lsearch -exact $lcnames $e]
10575                 if {$i < 0} {
10576                     if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
10577                         set i [lsearch -exact $lcnames $ex]
10578                     }
10579                 }
10580                 if {$i >= 0} break
10581             }
10582             break
10583         }
10584     }
10585     set tclenc {}
10586     if {$i >= 0} {
10587         set tclenc [lindex $names $i]
10588     }
10589     set tcl_encoding_cache($enc) $tclenc
10590     return $tclenc
10593 proc gitattr {path attr default} {
10594     global path_attr_cache
10595     if {[info exists path_attr_cache($attr,$path)]} {
10596         set r $path_attr_cache($attr,$path)
10597     } else {
10598         set r "unspecified"
10599         if {![catch {set line [exec git check-attr $attr -- $path]}]} {
10600             regexp "(.*): encoding: (.*)" $line m f r
10601         }
10602         set path_attr_cache($attr,$path) $r
10603     }
10604     if {$r eq "unspecified"} {
10605         return $default
10606     }
10607     return $r
10610 proc cache_gitattr {attr pathlist} {
10611     global path_attr_cache
10612     set newlist {}
10613     foreach path $pathlist {
10614         if {![info exists path_attr_cache($attr,$path)]} {
10615             lappend newlist $path
10616         }
10617     }
10618     set lim 1000
10619     if {[tk windowingsystem] == "win32"} {
10620         # windows has a 32k limit on the arguments to a command...
10621         set lim 30
10622     }
10623     while {$newlist ne {}} {
10624         set head [lrange $newlist 0 [expr {$lim - 1}]]
10625         set newlist [lrange $newlist $lim end]
10626         if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
10627             foreach row [split $rlist "\n"] {
10628                 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
10629                     if {[string index $path 0] eq "\""} {
10630                         set path [encoding convertfrom [lindex $path 0]]
10631                     }
10632                     set path_attr_cache($attr,$path) $value
10633                 }
10634             }
10635         }
10636     }
10639 proc get_path_encoding {path} {
10640     global gui_encoding perfile_attrs
10641     set tcl_enc $gui_encoding
10642     if {$path ne {} && $perfile_attrs} {
10643         set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
10644         if {$enc2 ne {}} {
10645             set tcl_enc $enc2
10646         }
10647     }
10648     return $tcl_enc
10651 # First check that Tcl/Tk is recent enough
10652 if {[catch {package require Tk 8.4} err]} {
10653     show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
10654                      Gitk requires at least Tcl/Tk 8.4."]
10655     exit 1
10658 # defaults...
10659 set wrcomcmd "git diff-tree --stdin -p --pretty"
10661 set gitencoding {}
10662 catch {
10663     set gitencoding [exec git config --get i18n.commitencoding]
10665 catch {
10666     set gitencoding [exec git config --get i18n.logoutputencoding]
10668 if {$gitencoding == ""} {
10669     set gitencoding "utf-8"
10671 set tclencoding [tcl_encoding $gitencoding]
10672 if {$tclencoding == {}} {
10673     puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
10676 set gui_encoding [encoding system]
10677 catch {
10678     set enc [exec git config --get gui.encoding]
10679     if {$enc ne {}} {
10680         set tclenc [tcl_encoding $enc]
10681         if {$tclenc ne {}} {
10682             set gui_encoding $tclenc
10683         } else {
10684             puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
10685         }
10686     }
10689 set mainfont {Helvetica 9}
10690 set textfont {Courier 9}
10691 set uifont {Helvetica 9 bold}
10692 set tabstop 8
10693 set findmergefiles 0
10694 set maxgraphpct 50
10695 set maxwidth 16
10696 set revlistorder 0
10697 set fastdate 0
10698 set uparrowlen 5
10699 set downarrowlen 5
10700 set mingaplen 100
10701 set cmitmode "patch"
10702 set wrapcomment "none"
10703 set showneartags 1
10704 set maxrefs 20
10705 set maxlinelen 200
10706 set showlocalchanges 1
10707 set limitdiffs 1
10708 set datetimeformat "%Y-%m-%d %H:%M:%S"
10709 set autoselect 1
10710 set perfile_attrs 0
10712 set extdifftool "meld"
10714 set colors {green red blue magenta darkgrey brown orange}
10715 set bgcolor white
10716 set fgcolor black
10717 set diffcolors {red "#00a000" blue}
10718 set diffcontext 3
10719 set ignorespace 0
10720 set selectbgcolor gray85
10721 set markbgcolor "#e0e0ff"
10723 set circlecolors {white blue gray blue blue}
10725 # button for popping up context menus
10726 if {[tk windowingsystem] eq "aqua"} {
10727     set ctxbut <Button-2>
10728 } else {
10729     set ctxbut <Button-3>
10732 ## For msgcat loading, first locate the installation location.
10733 if { [info exists ::env(GITK_MSGSDIR)] } {
10734     ## Msgsdir was manually set in the environment.
10735     set gitk_msgsdir $::env(GITK_MSGSDIR)
10736 } else {
10737     ## Let's guess the prefix from argv0.
10738     set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
10739     set gitk_libdir [file join $gitk_prefix share gitk lib]
10740     set gitk_msgsdir [file join $gitk_libdir msgs]
10741     unset gitk_prefix
10744 ## Internationalization (i18n) through msgcat and gettext. See
10745 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
10746 package require msgcat
10747 namespace import ::msgcat::mc
10748 ## And eventually load the actual message catalog
10749 ::msgcat::mcload $gitk_msgsdir
10751 catch {source ~/.gitk}
10753 font create optionfont -family sans-serif -size -12
10755 parsefont mainfont $mainfont
10756 eval font create mainfont [fontflags mainfont]
10757 eval font create mainfontbold [fontflags mainfont 1]
10759 parsefont textfont $textfont
10760 eval font create textfont [fontflags textfont]
10761 eval font create textfontbold [fontflags textfont 1]
10763 parsefont uifont $uifont
10764 eval font create uifont [fontflags uifont]
10766 setoptions
10768 # check that we can find a .git directory somewhere...
10769 if {[catch {set gitdir [gitdir]}]} {
10770     show_error {} . [mc "Cannot find a git repository here."]
10771     exit 1
10773 if {![file isdirectory $gitdir]} {
10774     show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
10775     exit 1
10778 set selecthead {}
10779 set selectheadid {}
10781 set revtreeargs {}
10782 set cmdline_files {}
10783 set i 0
10784 set revtreeargscmd {}
10785 foreach arg $argv {
10786     switch -glob -- $arg {
10787         "" { }
10788         "--" {
10789             set cmdline_files [lrange $argv [expr {$i + 1}] end]
10790             break
10791         }
10792         "--select-commit=*" {
10793             set selecthead [string range $arg 16 end]
10794         }
10795         "--argscmd=*" {
10796             set revtreeargscmd [string range $arg 10 end]
10797         }
10798         default {
10799             lappend revtreeargs $arg
10800         }
10801     }
10802     incr i
10805 if {$selecthead eq "HEAD"} {
10806     set selecthead {}
10809 if {$i >= [llength $argv] && $revtreeargs ne {}} {
10810     # no -- on command line, but some arguments (other than --argscmd)
10811     if {[catch {
10812         set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
10813         set cmdline_files [split $f "\n"]
10814         set n [llength $cmdline_files]
10815         set revtreeargs [lrange $revtreeargs 0 end-$n]
10816         # Unfortunately git rev-parse doesn't produce an error when
10817         # something is both a revision and a filename.  To be consistent
10818         # with git log and git rev-list, check revtreeargs for filenames.
10819         foreach arg $revtreeargs {
10820             if {[file exists $arg]} {
10821                 show_error {} . [mc "Ambiguous argument '%s': both revision\
10822                                  and filename" $arg]
10823                 exit 1
10824             }
10825         }
10826     } err]} {
10827         # unfortunately we get both stdout and stderr in $err,
10828         # so look for "fatal:".
10829         set i [string first "fatal:" $err]
10830         if {$i > 0} {
10831             set err [string range $err [expr {$i + 6}] end]
10832         }
10833         show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
10834         exit 1
10835     }
10838 set nullid "0000000000000000000000000000000000000000"
10839 set nullid2 "0000000000000000000000000000000000000001"
10840 set nullfile "/dev/null"
10842 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
10844 set runq {}
10845 set history {}
10846 set historyindex 0
10847 set fh_serial 0
10848 set nhl_names {}
10849 set highlight_paths {}
10850 set findpattern {}
10851 set searchdirn -forwards
10852 set boldids {}
10853 set boldnameids {}
10854 set diffelide {0 0}
10855 set markingmatches 0
10856 set linkentercount 0
10857 set need_redisplay 0
10858 set nrows_drawn 0
10859 set firsttabstop 0
10861 set nextviewnum 1
10862 set curview 0
10863 set selectedview 0
10864 set selectedhlview [mc "None"]
10865 set highlight_related [mc "None"]
10866 set highlight_files {}
10867 set viewfiles(0) {}
10868 set viewperm(0) 0
10869 set viewargs(0) {}
10870 set viewargscmd(0) {}
10872 set selectedline {}
10873 set numcommits 0
10874 set loginstance 0
10875 set cmdlineok 0
10876 set stopped 0
10877 set stuffsaved 0
10878 set patchnum 0
10879 set lserial 0
10880 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
10881 setcoords
10882 makewindow
10883 # wait for the window to become visible
10884 tkwait visibility .
10885 wm title . "[file tail $argv0]: [file tail [pwd]]"
10886 readrefs
10888 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
10889     # create a view for the files/dirs specified on the command line
10890     set curview 1
10891     set selectedview 1
10892     set nextviewnum 2
10893     set viewname(1) [mc "Command line"]
10894     set viewfiles(1) $cmdline_files
10895     set viewargs(1) $revtreeargs
10896     set viewargscmd(1) $revtreeargscmd
10897     set viewperm(1) 0
10898     set vdatemode(1) 0
10899     addviewmenu 1
10900     .bar.view entryconf [mca "Edit view..."] -state normal
10901     .bar.view entryconf [mca "Delete view"] -state normal
10904 if {[info exists permviews]} {
10905     foreach v $permviews {
10906         set n $nextviewnum
10907         incr nextviewnum
10908         set viewname($n) [lindex $v 0]
10909         set viewfiles($n) [lindex $v 1]
10910         set viewargs($n) [lindex $v 2]
10911         set viewargscmd($n) [lindex $v 3]
10912         set viewperm($n) 1
10913         addviewmenu $n
10914     }
10916 getcommits {}