2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright © 2005-2009 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.
14 if {[info exists env
(GIT_DIR
)]} {
17 return [exec git rev-parse
--git-dir]
21 # A simple scheduler for compute-intensive stuff.
22 # The aim is to make sure that event handlers for GUI actions can
23 # run at least every 50-100 ms. Unfortunately fileevent handlers are
24 # run before X event handlers, so reading from a fast source can
25 # make the GUI completely unresponsive.
27 global isonrunq runq currunq
30 if {[info exists isonrunq
($script)]} return
31 if {$runq eq
{} && ![info exists currunq
]} {
34 lappend runq
[list
{} $script]
35 set isonrunq
($script) 1
38 proc filerun
{fd
script} {
39 fileevent
$fd readable
[list filereadable
$fd $script]
42 proc filereadable
{fd
script} {
45 fileevent
$fd readable
{}
46 if {$runq eq
{} && ![info exists currunq
]} {
49 lappend runq
[list
$fd $script]
55 for {set i
0} {$i < [llength
$runq]} {} {
56 if {[lindex
$runq $i 0] eq
$fd} {
57 set runq
[lreplace
$runq $i $i]
65 global isonrunq runq currunq
67 set tstart
[clock clicks
-milliseconds]
69 while {[llength
$runq] > 0} {
70 set fd
[lindex
$runq 0 0]
71 set script [lindex
$runq 0 1]
72 set currunq
[lindex
$runq 0]
73 set runq
[lrange
$runq 1 end
]
74 set repeat
[eval $script]
76 set t1
[clock clicks
-milliseconds]
77 set t
[expr {$t1 - $t0}]
78 if {$repeat ne
{} && $repeat} {
79 if {$fd eq
{} ||
$repeat == 2} {
80 # script returns 1 if it wants to be readded
81 # file readers return 2 if they could do more straight away
82 lappend runq
[list
$fd $script]
84 fileevent
$fd readable
[list filereadable
$fd $script]
86 } elseif
{$fd eq
{}} {
87 unset isonrunq
($script)
90 if {$t1 - $tstart >= 80} break
97 proc reg_instance
{fd
} {
98 global commfd leftover loginstance
100 set i
[incr loginstance
]
106 proc unmerged_files
{files
} {
109 # find the list of unmerged files
113 set fd
[open
"| git ls-files -u" r
]
115 show_error
{} .
"[mc "Couldn
't get list of unmerged files:"] $err"
118 while {[gets $fd line] >= 0} {
119 set i [string first "\t" $line]
121 set fname [string range $line [expr {$i+1}] end]
122 if {[lsearch -exact $mlist $fname] >= 0} continue
124 if {$files eq {} || [path_filter $files $fname]} {
132 proc parseviewargs {n arglist} {
133 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
141 set origargs $arglist
145 foreach arg $arglist {
152 switch -glob -- $arg {
156 # remove from origargs in case we hit an unknown option
157 set origargs [lreplace $origargs $i $i]
161 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165 "--ignore-space-change" - "-U*" - "--unified=*" {
166 # These request or affect diff output, which we don't want.
167 # Some could be used to set our defaults for diff display.
168 lappend diffargs
$arg
170 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171 "--name-only" - "--name-status" - "--color" - "--color-words" -
172 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176 "--objects" - "--objects-edge" - "--reverse" {
177 # These cause our parsing of git log's output to fail, or else
178 # they're options we want to set ourselves, so ignore them.
180 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
181 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
182 "--full-history" - "--dense" - "--sparse" -
183 "--follow" - "--left-right" - "--encoding=*" {
184 # These are harmless, and some are even useful
187 "--diff-filter=*" - "--no-merges" - "--unpacked" -
188 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
189 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
190 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
191 "--remove-empty" - "--first-parent" - "--cherry-pick" -
192 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
193 "--simplify-by-decoration" {
194 # These mean that we get a subset of the commits
199 # This appears to be the only one that has a value as a
200 # separate word following it
210 # git rev-parse doesn't understand --merge
211 lappend revargs
--gitk-symmetric-diff-marker MERGE_HEAD...HEAD
214 # Other flag arguments including -<n>
215 if {[string is digit
-strict [string range
$arg 1 end
]]} {
218 # a flag argument that we don't recognize;
219 # that means we can't optimize
225 # Non-flag arguments specify commits or ranges of commits
226 if {[string match
"*...*" $arg]} {
227 lappend revargs
--gitk-symmetric-diff-marker
233 set vdflags
($n) $diffargs
234 set vflags
($n) $glflags
235 set vrevs
($n) $revargs
236 set vfiltered
($n) $filtered
237 set vorigargs
($n) $origargs
241 proc parseviewrevs
{view revs
} {
242 global vposids vnegids
247 if {[catch
{set ids
[eval exec git rev-parse
$revs]} err
]} {
248 # we get stdout followed by stderr in $err
249 # for an unknown rev, git rev-parse echoes it and then errors out
250 set errlines
[split $err "\n"]
252 for {set l
0} {$l < [llength
$errlines]} {incr l
} {
253 set line
[lindex
$errlines $l]
254 if {!([string length
$line] == 40 && [string is xdigit
$line])} {
255 if {[string match
"fatal:*" $line]} {
256 if {[string match
"fatal: ambiguous argument*" $line]
258 if {[llength
$badrev] == 1} {
259 set err
"unknown revision $badrev"
261 set err
"unknown revisions: [join $badrev ", "]"
264 set err
[join [lrange
$errlines $l end
] "\n"]
271 error_popup
"[mc "Error parsing revisions
:"] $err"
278 foreach id
[split $ids "\n"] {
279 if {$id eq
"--gitk-symmetric-diff-marker"} {
281 } elseif
{[string match
"^*" $id]} {
288 lappend neg
[string range
$id 1 end
]
293 lset ret end
$id...
[lindex
$ret end
]
299 set vposids
($view) $pos
300 set vnegids
($view) $neg
304 # Start off a git log process and arrange to read its output
305 proc start_rev_list
{view
} {
306 global startmsecs commitidx viewcomplete curview
308 global viewargs viewargscmd viewfiles vfilelimit
309 global showlocalchanges
310 global viewactive viewinstances vmergeonly
311 global mainheadid viewmainheadid viewmainheadid_orig
312 global vcanopt vflags vrevs vorigargs
314 set startmsecs
[clock clicks
-milliseconds]
315 set commitidx
($view) 0
316 # these are set this way for the error exits
317 set viewcomplete
($view) 1
318 set viewactive
($view) 0
321 set args
$viewargs($view)
322 if {$viewargscmd($view) ne
{}} {
324 set str
[exec sh
-c $viewargscmd($view)]
326 error_popup
"[mc "Error executing
--argscmd command:"] $err"
329 set args
[concat
$args [split $str "\n"]]
331 set vcanopt
($view) [parseviewargs
$view $args]
333 set files
$viewfiles($view)
334 if {$vmergeonly($view)} {
335 set files
[unmerged_files
$files]
338 if {$nr_unmerged == 0} {
339 error_popup
[mc
"No files selected: --merge specified but\
340 no files are unmerged."]
342 error_popup
[mc
"No files selected: --merge specified but\
343 no unmerged files are within file limit."]
348 set vfilelimit
($view) $files
350 if {$vcanopt($view)} {
351 set revs
[parseviewrevs
$view $vrevs($view)]
355 set args
[concat
$vflags($view) $revs]
357 set args
$vorigargs($view)
361 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
362 --boundary $args "--" $files] r
]
364 error_popup
"[mc "Error executing git log
:"] $err"
367 set i
[reg_instance
$fd]
368 set viewinstances
($view) [list
$i]
369 set viewmainheadid
($view) $mainheadid
370 set viewmainheadid_orig
($view) $mainheadid
371 if {$files ne
{} && $mainheadid ne
{}} {
372 get_viewmainhead
$view
374 if {$showlocalchanges && $viewmainheadid($view) ne
{}} {
375 interestedin
$viewmainheadid($view) dodiffindex
377 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
378 if {$tclencoding != {}} {
379 fconfigure
$fd -encoding $tclencoding
381 filerun
$fd [list getcommitlines
$fd $i $view 0]
382 nowbusy
$view [mc
"Reading"]
383 set viewcomplete
($view) 0
384 set viewactive
($view) 1
388 proc stop_instance
{inst
} {
389 global commfd leftover
391 set fd
$commfd($inst)
395 if {$
::tcl_platform
(platform
) eq
{windows
}} {
404 unset leftover
($inst)
407 proc stop_backends
{} {
410 foreach inst
[array names commfd
] {
415 proc stop_rev_list
{view
} {
418 foreach inst
$viewinstances($view) {
421 set viewinstances
($view) {}
424 proc reset_pending_select
{selid
} {
425 global pending_select mainheadid selectheadid
428 set pending_select
$selid
429 } elseif
{$selectheadid ne
{}} {
430 set pending_select
$selectheadid
432 set pending_select
$mainheadid
436 proc getcommits
{selid
} {
437 global canv curview need_redisplay viewactive
440 if {[start_rev_list
$curview]} {
441 reset_pending_select
$selid
442 show_status
[mc
"Reading commits..."]
445 show_status
[mc
"No commits selected"]
449 proc updatecommits
{} {
450 global curview vcanopt vorigargs vfilelimit viewinstances
451 global viewactive viewcomplete tclencoding
452 global startmsecs showneartags showlocalchanges
453 global mainheadid viewmainheadid viewmainheadid_orig pending_select
455 global varcid vposids vnegids vflags vrevs
457 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
460 if {$mainheadid ne
$viewmainheadid_orig($view)} {
461 if {$showlocalchanges} {
464 set viewmainheadid
($view) $mainheadid
465 set viewmainheadid_orig
($view) $mainheadid
466 if {$vfilelimit($view) ne
{}} {
467 get_viewmainhead
$view
470 if {$showlocalchanges} {
473 if {$vcanopt($view)} {
474 set oldpos
$vposids($view)
475 set oldneg
$vnegids($view)
476 set revs
[parseviewrevs
$view $vrevs($view)]
480 # note: getting the delta when negative refs change is hard,
481 # and could require multiple git log invocations, so in that
482 # case we ask git log for all the commits (not just the delta)
483 if {$oldneg eq
$vnegids($view)} {
486 # take out positive refs that we asked for before or
487 # that we have already seen
489 if {[string length
$rev] == 40} {
490 if {[lsearch
-exact $oldpos $rev] < 0
491 && ![info exists varcid
($view,$rev)]} {
496 lappend
$newrevs $rev
499 if {$npos == 0} return
501 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
503 set args
[concat
$vflags($view) $revs --not $oldpos]
505 set args
$vorigargs($view)
508 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
509 --boundary $args "--" $vfilelimit($view)] r
]
511 error_popup
"[mc "Error executing git log
:"] $err"
514 if {$viewactive($view) == 0} {
515 set startmsecs
[clock clicks
-milliseconds]
517 set i
[reg_instance
$fd]
518 lappend viewinstances
($view) $i
519 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
520 if {$tclencoding != {}} {
521 fconfigure
$fd -encoding $tclencoding
523 filerun
$fd [list getcommitlines
$fd $i $view 1]
524 incr viewactive
($view)
525 set viewcomplete
($view) 0
526 reset_pending_select
{}
527 nowbusy
$view [mc
"Reading"]
533 proc reloadcommits
{} {
534 global curview viewcomplete selectedline currentid thickerline
535 global showneartags treediffs commitinterest cached_commitrow
539 if {$selectedline ne
{}} {
543 if {!$viewcomplete($curview)} {
544 stop_rev_list
$curview
548 catch
{unset currentid
}
549 catch
{unset thickerline
}
550 catch
{unset treediffs
}
557 catch
{unset commitinterest
}
558 catch
{unset cached_commitrow
}
559 catch
{unset targetid
}
565 # This makes a string representation of a positive integer which
566 # sorts as a string in numerical order
569 return [format
"%x" $n]
570 } elseif
{$n < 256} {
571 return [format
"x%.2x" $n]
572 } elseif
{$n < 65536} {
573 return [format
"y%.4x" $n]
575 return [format
"z%.8x" $n]
578 # Procedures used in reordering commits from git log (without
579 # --topo-order) into the order for display.
581 proc varcinit
{view
} {
582 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
583 global vtokmod varcmod vrowmod varcix vlastins
585 set varcstart
($view) {{}}
586 set vupptr
($view) {0}
587 set vdownptr
($view) {0}
588 set vleftptr
($view) {0}
589 set vbackptr
($view) {0}
590 set varctok
($view) {{}}
591 set varcrow
($view) {{}}
592 set vtokmod
($view) {}
595 set varcix
($view) {{}}
596 set vlastins
($view) {0}
599 proc resetvarcs
{view
} {
600 global varcid varccommits parents children vseedcount ordertok
602 foreach vid
[array names varcid
$view,*] {
607 # some commits might have children but haven't been seen yet
608 foreach vid
[array names children
$view,*] {
611 foreach va
[array names varccommits
$view,*] {
612 unset varccommits
($va)
614 foreach vd
[array names vseedcount
$view,*] {
615 unset vseedcount
($vd)
617 catch
{unset ordertok
}
620 # returns a list of the commits with no children
622 global vdownptr vleftptr varcstart
625 set a
[lindex
$vdownptr($v) 0]
627 lappend ret
[lindex
$varcstart($v) $a]
628 set a
[lindex
$vleftptr($v) $a]
633 proc newvarc
{view id
} {
634 global varcid varctok parents children vdatemode
635 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
636 global commitdata commitinfo vseedcount varccommits vlastins
638 set a
[llength
$varctok($view)]
640 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
641 if {![info exists commitinfo
($id)]} {
642 parsecommit
$id $commitdata($id) 1
644 set cdate
[lindex
$commitinfo($id) 4]
645 if {![string is integer
-strict $cdate]} {
648 if {![info exists vseedcount
($view,$cdate)]} {
649 set vseedcount
($view,$cdate) -1
651 set c
[incr vseedcount
($view,$cdate)]
652 set cdate
[expr {$cdate ^
0xffffffff}]
653 set tok
"s[strrep $cdate][strrep $c]"
658 if {[llength
$children($vid)] > 0} {
659 set kid
[lindex
$children($vid) end
]
660 set k
$varcid($view,$kid)
661 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
664 set tok
[lindex
$varctok($view) $k]
668 set i
[lsearch
-exact $parents($view,$ki) $id]
669 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
670 append tok
[strrep
$j]
672 set c
[lindex
$vlastins($view) $ka]
673 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
675 set b
[lindex
$vdownptr($view) $ka]
677 set b
[lindex
$vleftptr($view) $c]
679 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
681 set b
[lindex
$vleftptr($view) $c]
684 lset vdownptr
($view) $ka $a
685 lappend vbackptr
($view) 0
687 lset vleftptr
($view) $c $a
688 lappend vbackptr
($view) $c
690 lset vlastins
($view) $ka $a
691 lappend vupptr
($view) $ka
692 lappend vleftptr
($view) $b
694 lset vbackptr
($view) $b $a
696 lappend varctok
($view) $tok
697 lappend varcstart
($view) $id
698 lappend vdownptr
($view) 0
699 lappend varcrow
($view) {}
700 lappend varcix
($view) {}
701 set varccommits
($view,$a) {}
702 lappend vlastins
($view) 0
706 proc splitvarc
{p v
} {
707 global varcid varcstart varccommits varctok vtokmod
708 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
710 set oa
$varcid($v,$p)
711 set otok
[lindex
$varctok($v) $oa]
712 set ac
$varccommits($v,$oa)
713 set i
[lsearch
-exact $varccommits($v,$oa) $p]
715 set na
[llength
$varctok($v)]
716 # "%" sorts before "0"...
717 set tok
"$otok%[strrep $i]"
718 lappend varctok
($v) $tok
719 lappend varcrow
($v) {}
720 lappend varcix
($v) {}
721 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
722 set varccommits
($v,$na) [lrange
$ac $i end
]
723 lappend varcstart
($v) $p
724 foreach id
$varccommits($v,$na) {
725 set varcid
($v,$id) $na
727 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
728 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
729 lset vdownptr
($v) $oa $na
730 lset vlastins
($v) $oa 0
731 lappend vupptr
($v) $oa
732 lappend vleftptr
($v) 0
733 lappend vbackptr
($v) 0
734 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
735 lset vupptr
($v) $b $na
737 if {[string compare
$otok $vtokmod($v)] <= 0} {
742 proc renumbervarc
{a v
} {
743 global parents children varctok varcstart varccommits
744 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
746 set t1
[clock clicks
-milliseconds]
752 if {[info exists isrelated
($a)]} {
754 set id
[lindex
$varccommits($v,$a) end
]
755 foreach p
$parents($v,$id) {
756 if {[info exists varcid
($v,$p)]} {
757 set isrelated
($varcid($v,$p)) 1
762 set b
[lindex
$vdownptr($v) $a]
765 set b
[lindex
$vleftptr($v) $a]
767 set a
[lindex
$vupptr($v) $a]
773 if {![info exists kidchanged
($a)]} continue
774 set id
[lindex
$varcstart($v) $a]
775 if {[llength
$children($v,$id)] > 1} {
776 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
779 set oldtok
[lindex
$varctok($v) $a]
780 if {!$vdatemode($v)} {
786 set kid
[last_real_child
$v,$id]
788 set k
$varcid($v,$kid)
789 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
792 set tok
[lindex
$varctok($v) $k]
796 set i
[lsearch
-exact $parents($v,$ki) $id]
797 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
798 append tok
[strrep
$j]
800 if {$tok eq
$oldtok} {
803 set id
[lindex
$varccommits($v,$a) end
]
804 foreach p
$parents($v,$id) {
805 if {[info exists varcid
($v,$p)]} {
806 set kidchanged
($varcid($v,$p)) 1
811 lset varctok
($v) $a $tok
812 set b
[lindex
$vupptr($v) $a]
814 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
817 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
820 set c
[lindex
$vbackptr($v) $a]
821 set d
[lindex
$vleftptr($v) $a]
823 lset vdownptr
($v) $b $d
825 lset vleftptr
($v) $c $d
828 lset vbackptr
($v) $d $c
830 if {[lindex
$vlastins($v) $b] == $a} {
831 lset vlastins
($v) $b $c
833 lset vupptr
($v) $a $ka
834 set c
[lindex
$vlastins($v) $ka]
836 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
838 set b
[lindex
$vdownptr($v) $ka]
840 set b
[lindex
$vleftptr($v) $c]
843 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
845 set b
[lindex
$vleftptr($v) $c]
848 lset vdownptr
($v) $ka $a
849 lset vbackptr
($v) $a 0
851 lset vleftptr
($v) $c $a
852 lset vbackptr
($v) $a $c
854 lset vleftptr
($v) $a $b
856 lset vbackptr
($v) $b $a
858 lset vlastins
($v) $ka $a
861 foreach id
[array names sortkids
] {
862 if {[llength
$children($v,$id)] > 1} {
863 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
867 set t2
[clock clicks
-milliseconds]
868 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
871 # Fix up the graph after we have found out that in view $v,
872 # $p (a commit that we have already seen) is actually the parent
873 # of the last commit in arc $a.
874 proc fix_reversal
{p a v
} {
875 global varcid varcstart varctok vupptr
877 set pa
$varcid($v,$p)
878 if {$p ne
[lindex
$varcstart($v) $pa]} {
880 set pa
$varcid($v,$p)
882 # seeds always need to be renumbered
883 if {[lindex
$vupptr($v) $pa] == 0 ||
884 [string compare
[lindex
$varctok($v) $a] \
885 [lindex
$varctok($v) $pa]] > 0} {
890 proc insertrow
{id p v
} {
891 global cmitlisted children parents varcid varctok vtokmod
892 global varccommits ordertok commitidx numcommits curview
893 global targetid targetrow
897 set cmitlisted
($vid) 1
898 set children
($vid) {}
899 set parents
($vid) [list
$p]
900 set a
[newvarc
$v $id]
902 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
905 lappend varccommits
($v,$a) $id
907 if {[llength
[lappend children
($vp) $id]] > 1} {
908 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
909 catch
{unset ordertok
}
911 fix_reversal
$p $a $v
913 if {$v == $curview} {
914 set numcommits
$commitidx($v)
916 if {[info exists targetid
]} {
917 if {![comes_before
$targetid $p]} {
924 proc insertfakerow
{id p
} {
925 global varcid varccommits parents children cmitlisted
926 global commitidx varctok vtokmod targetid targetrow curview numcommits
930 set i
[lsearch
-exact $varccommits($v,$a) $p]
932 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
935 set children
($v,$id) {}
936 set parents
($v,$id) [list
$p]
937 set varcid
($v,$id) $a
938 lappend children
($v,$p) $id
939 set cmitlisted
($v,$id) 1
940 set numcommits
[incr commitidx
($v)]
941 # note we deliberately don't update varcstart($v) even if $i == 0
942 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
944 if {[info exists targetid
]} {
945 if {![comes_before
$targetid $p]} {
953 proc removefakerow
{id
} {
954 global varcid varccommits parents children commitidx
955 global varctok vtokmod cmitlisted currentid selectedline
956 global targetid curview numcommits
959 if {[llength
$parents($v,$id)] != 1} {
960 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
963 set p
[lindex
$parents($v,$id) 0]
964 set a
$varcid($v,$id)
965 set i
[lsearch
-exact $varccommits($v,$a) $id]
967 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
971 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
972 unset parents
($v,$id)
973 unset children
($v,$id)
974 unset cmitlisted
($v,$id)
975 set numcommits
[incr commitidx
($v) -1]
976 set j
[lsearch
-exact $children($v,$p) $id]
978 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
981 if {[info exist currentid
] && $id eq
$currentid} {
985 if {[info exists targetid
] && $targetid eq
$id} {
992 proc real_children
{vp
} {
993 global children nullid nullid2
996 foreach id
$children($vp) {
997 if {$id ne
$nullid && $id ne
$nullid2} {
1004 proc first_real_child
{vp
} {
1005 global children nullid nullid2
1007 foreach id
$children($vp) {
1008 if {$id ne
$nullid && $id ne
$nullid2} {
1015 proc last_real_child
{vp
} {
1016 global children nullid nullid2
1018 set kids
$children($vp)
1019 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
1020 set id
[lindex
$kids $i]
1021 if {$id ne
$nullid && $id ne
$nullid2} {
1028 proc vtokcmp
{v a b
} {
1029 global varctok varcid
1031 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1032 [lindex
$varctok($v) $varcid($v,$b)]]
1035 # This assumes that if lim is not given, the caller has checked that
1036 # arc a's token is less than $vtokmod($v)
1037 proc modify_arc
{v a
{lim
{}}} {
1038 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1041 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
1044 set r
[lindex
$varcrow($v) $a]
1045 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
1048 set vtokmod
($v) [lindex
$varctok($v) $a]
1050 if {$v == $curview} {
1051 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
1052 set a
[lindex
$vupptr($v) $a]
1058 set lim
[llength
$varccommits($v,$a)]
1060 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1067 proc update_arcrows
{v
} {
1068 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1069 global varcid vrownum varcorder varcix varccommits
1070 global vupptr vdownptr vleftptr varctok
1071 global displayorder parentlist curview cached_commitrow
1073 if {$vrowmod($v) == $commitidx($v)} return
1074 if {$v == $curview} {
1075 if {[llength
$displayorder] > $vrowmod($v)} {
1076 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1077 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1079 catch
{unset cached_commitrow
}
1081 set narctot
[expr {[llength
$varctok($v)] - 1}]
1083 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1084 # go up the tree until we find something that has a row number,
1085 # or we get to a seed
1086 set a
[lindex
$vupptr($v) $a]
1089 set a
[lindex
$vdownptr($v) 0]
1092 set varcorder
($v) [list
$a]
1093 lset varcix
($v) $a 0
1094 lset varcrow
($v) $a 0
1098 set arcn
[lindex
$varcix($v) $a]
1099 if {[llength
$vrownum($v)] > $arcn + 1} {
1100 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1101 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1103 set row
[lindex
$varcrow($v) $a]
1107 incr row
[llength
$varccommits($v,$a)]
1108 # go down if possible
1109 set b
[lindex
$vdownptr($v) $a]
1111 # if not, go left, or go up until we can go left
1113 set b
[lindex
$vleftptr($v) $a]
1115 set a
[lindex
$vupptr($v) $a]
1121 lappend vrownum
($v) $row
1122 lappend varcorder
($v) $a
1123 lset varcix
($v) $a $arcn
1124 lset varcrow
($v) $a $row
1126 set vtokmod
($v) [lindex
$varctok($v) $p]
1128 set vrowmod
($v) $row
1129 if {[info exists currentid
]} {
1130 set selectedline
[rowofcommit
$currentid]
1134 # Test whether view $v contains commit $id
1135 proc commitinview
{id v
} {
1138 return [info exists varcid
($v,$id)]
1141 # Return the row number for commit $id in the current view
1142 proc rowofcommit
{id
} {
1143 global varcid varccommits varcrow curview cached_commitrow
1144 global varctok vtokmod
1147 if {![info exists varcid
($v,$id)]} {
1148 puts
"oops rowofcommit no arc for [shortids $id]"
1151 set a
$varcid($v,$id)
1152 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1155 if {[info exists cached_commitrow
($id)]} {
1156 return $cached_commitrow($id)
1158 set i
[lsearch
-exact $varccommits($v,$a) $id]
1160 puts
"oops didn't find commit [shortids $id] in arc $a"
1163 incr i
[lindex
$varcrow($v) $a]
1164 set cached_commitrow
($id) $i
1168 # Returns 1 if a is on an earlier row than b, otherwise 0
1169 proc comes_before
{a b
} {
1170 global varcid varctok curview
1173 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1174 ![info exists varcid
($v,$b)]} {
1177 if {$varcid($v,$a) != $varcid($v,$b)} {
1178 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1179 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1181 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1184 proc bsearch
{l elt
} {
1185 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1190 while {$hi - $lo > 1} {
1191 set mid
[expr {int
(($lo + $hi) / 2)}]
1192 set t
[lindex
$l $mid]
1195 } elseif
{$elt > $t} {
1204 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1205 proc make_disporder
{start end
} {
1206 global vrownum curview commitidx displayorder parentlist
1207 global varccommits varcorder parents vrowmod varcrow
1208 global d_valid_start d_valid_end
1210 if {$end > $vrowmod($curview)} {
1211 update_arcrows
$curview
1213 set ai
[bsearch
$vrownum($curview) $start]
1214 set start
[lindex
$vrownum($curview) $ai]
1215 set narc
[llength
$vrownum($curview)]
1216 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1217 set a
[lindex
$varcorder($curview) $ai]
1218 set l
[llength
$displayorder]
1219 set al
[llength
$varccommits($curview,$a)]
1220 if {$l < $r + $al} {
1222 set pad
[ntimes
[expr {$r - $l}] {}]
1223 set displayorder
[concat
$displayorder $pad]
1224 set parentlist
[concat
$parentlist $pad]
1225 } elseif
{$l > $r} {
1226 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1227 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1229 foreach id
$varccommits($curview,$a) {
1230 lappend displayorder
$id
1231 lappend parentlist
$parents($curview,$id)
1233 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1235 foreach id
$varccommits($curview,$a) {
1236 lset displayorder
$i $id
1237 lset parentlist
$i $parents($curview,$id)
1245 proc commitonrow
{row
} {
1248 set id
[lindex
$displayorder $row]
1250 make_disporder
$row [expr {$row + 1}]
1251 set id
[lindex
$displayorder $row]
1256 proc closevarcs
{v
} {
1257 global varctok varccommits varcid parents children
1258 global cmitlisted commitidx vtokmod
1260 set missing_parents
0
1262 set narcs
[llength
$varctok($v)]
1263 for {set a
1} {$a < $narcs} {incr a
} {
1264 set id
[lindex
$varccommits($v,$a) end
]
1265 foreach p
$parents($v,$id) {
1266 if {[info exists varcid
($v,$p)]} continue
1267 # add p as a new commit
1268 incr missing_parents
1269 set cmitlisted
($v,$p) 0
1270 set parents
($v,$p) {}
1271 if {[llength
$children($v,$p)] == 1 &&
1272 [llength
$parents($v,$id)] == 1} {
1275 set b
[newvarc
$v $p]
1277 set varcid
($v,$p) $b
1278 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1281 lappend varccommits
($v,$b) $p
1283 set scripts
[check_interest
$p $scripts]
1286 if {$missing_parents > 0} {
1287 foreach s
$scripts {
1293 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1294 # Assumes we already have an arc for $rwid.
1295 proc rewrite_commit
{v id rwid
} {
1296 global children parents varcid varctok vtokmod varccommits
1298 foreach ch
$children($v,$id) {
1299 # make $rwid be $ch's parent in place of $id
1300 set i
[lsearch
-exact $parents($v,$ch) $id]
1302 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1304 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1305 # add $ch to $rwid's children and sort the list if necessary
1306 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1307 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1308 $children($v,$rwid)]
1310 # fix the graph after joining $id to $rwid
1311 set a
$varcid($v,$ch)
1312 fix_reversal
$rwid $a $v
1313 # parentlist is wrong for the last element of arc $a
1314 # even if displayorder is right, hence the 3rd arg here
1315 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1319 # Mechanism for registering a command to be executed when we come
1320 # across a particular commit. To handle the case when only the
1321 # prefix of the commit is known, the commitinterest array is now
1322 # indexed by the first 4 characters of the ID. Each element is a
1323 # list of id, cmd pairs.
1324 proc interestedin
{id cmd
} {
1325 global commitinterest
1327 lappend commitinterest
([string range
$id 0 3]) $id $cmd
1330 proc check_interest
{id scripts
} {
1331 global commitinterest
1333 set prefix
[string range
$id 0 3]
1334 if {[info exists commitinterest
($prefix)]} {
1336 foreach
{i
script} $commitinterest($prefix) {
1337 if {[string match
"$i*" $id]} {
1338 lappend scripts
[string map
[list
"%I" $id "%P" $i] $script]
1340 lappend newlist
$i $script
1343 if {$newlist ne
{}} {
1344 set commitinterest
($prefix) $newlist
1346 unset commitinterest
($prefix)
1352 proc getcommitlines
{fd inst view updating
} {
1353 global cmitlisted leftover
1354 global commitidx commitdata vdatemode
1355 global parents children curview hlview
1356 global idpending ordertok
1357 global varccommits varcid varctok vtokmod vfilelimit
1359 set stuff
[read $fd 500000]
1360 # git log doesn't terminate the last commit with a null...
1361 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1368 global commfd viewcomplete viewactive viewname
1369 global viewinstances
1371 set i
[lsearch
-exact $viewinstances($view) $inst]
1373 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1375 # set it blocking so we wait for the process to terminate
1376 fconfigure
$fd -blocking 1
1377 if {[catch
{close
$fd} err
]} {
1379 if {$view != $curview} {
1380 set fv
" for the \"$viewname($view)\" view"
1382 if {[string range
$err 0 4] == "usage"} {
1383 set err
"Gitk: error reading commits$fv:\
1384 bad arguments to git log."
1385 if {$viewname($view) eq
"Command line"} {
1387 " (Note: arguments to gitk are passed to git log\
1388 to allow selection of commits to be displayed.)"
1391 set err
"Error reading commits$fv: $err"
1395 if {[incr viewactive
($view) -1] <= 0} {
1396 set viewcomplete
($view) 1
1397 # Check if we have seen any ids listed as parents that haven't
1398 # appeared in the list
1402 if {$view == $curview} {
1411 set i
[string first
"\0" $stuff $start]
1413 append leftover
($inst) [string range
$stuff $start end
]
1417 set cmit
$leftover($inst)
1418 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1419 set leftover
($inst) {}
1421 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1423 set start
[expr {$i + 1}]
1424 set j
[string first
"\n" $cmit]
1427 if {$j >= 0 && [string match
"commit *" $cmit]} {
1428 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1429 if {[string match
{[-^
<>]*} $ids]} {
1430 switch
-- [string index
$ids 0] {
1436 set ids
[string range
$ids 1 end
]
1440 if {[string length
$id] != 40} {
1448 if {[string length
$shortcmit] > 80} {
1449 set shortcmit
"[string range $shortcmit 0 80]..."
1451 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1454 set id [lindex $ids 0]
1457 if {!$listed && $updating && ![info exists varcid($vid)] &&
1458 $vfilelimit($view) ne {}} {
1459 # git log doesn't rewrite parents
for unlisted commits
1460 # when doing path limiting, so work around that here
1461 # by working out the rewritten parent with git rev-list
1462 # and if we already know about it, using the rewritten
1463 # parent as a substitute parent for $id's children.
1465 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1466 $id -- $vfilelimit($view)]
1468 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1469 # use $rwid in place of $id
1470 rewrite_commit
$view $id $rwid
1477 if {[info exists varcid
($vid)]} {
1478 if {$cmitlisted($vid) ||
!$listed} continue
1482 set olds
[lrange
$ids 1 end
]
1486 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1487 set cmitlisted
($vid) $listed
1488 set parents
($vid) $olds
1489 if {![info exists children
($vid)]} {
1490 set children
($vid) {}
1491 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1492 set k
[lindex
$children($vid) 0]
1493 if {[llength
$parents($view,$k)] == 1 &&
1494 (!$vdatemode($view) ||
1495 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1496 set a
$varcid($view,$k)
1501 set a
[newvarc
$view $id]
1503 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1506 if {![info exists varcid
($vid)]} {
1508 lappend varccommits
($view,$a) $id
1509 incr commitidx
($view)
1514 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1516 if {[llength
[lappend children
($vp) $id]] > 1 &&
1517 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1518 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1520 catch
{unset ordertok
}
1522 if {[info exists varcid
($view,$p)]} {
1523 fix_reversal
$p $a $view
1529 set scripts
[check_interest
$id $scripts]
1533 global numcommits hlview
1535 if {$view == $curview} {
1536 set numcommits
$commitidx($view)
1539 if {[info exists hlview
] && $view == $hlview} {
1540 # we never actually get here...
1543 foreach s
$scripts {
1550 proc chewcommits
{} {
1551 global curview hlview viewcomplete
1552 global pending_select
1555 if {$viewcomplete($curview)} {
1556 global commitidx varctok
1557 global numcommits startmsecs
1559 if {[info exists pending_select
]} {
1561 reset_pending_select
{}
1563 if {[commitinview
$pending_select $curview]} {
1564 selectline
[rowofcommit
$pending_select] 1
1566 set row
[first_real_row
]
1570 if {$commitidx($curview) > 0} {
1571 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1572 #puts "overall $ms ms for $numcommits commits"
1573 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1575 show_status
[mc
"No commits selected"]
1582 proc do_readcommit
{id
} {
1585 # Invoke git-log to handle automatic encoding conversion
1586 set fd
[open
[concat | git log
--no-color --pretty=raw
-1 $id] r
]
1587 # Read the results using i18n.logoutputencoding
1588 fconfigure
$fd -translation lf
-eofchar {}
1589 if {$tclencoding != {}} {
1590 fconfigure
$fd -encoding $tclencoding
1592 set contents
[read $fd]
1594 # Remove the heading line
1595 regsub
{^commit
[0-9a-f]+\n} $contents {} contents
1600 proc readcommit
{id
} {
1601 if {[catch
{set contents
[do_readcommit
$id]}]} return
1602 parsecommit
$id $contents 1
1605 proc parsecommit
{id contents listed
} {
1606 global commitinfo cdate
1615 set hdrend
[string first
"\n\n" $contents]
1617 # should never happen...
1618 set hdrend
[string length
$contents]
1620 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1621 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1622 foreach line
[split $header "\n"] {
1623 set line
[split $line " "]
1624 set tag
[lindex
$line 0]
1625 if {$tag == "author"} {
1626 set audate
[lindex
$line end-1
]
1627 set auname
[join [lrange
$line 1 end-2
] " "]
1628 } elseif
{$tag == "committer"} {
1629 set comdate
[lindex
$line end-1
]
1630 set comname
[join [lrange
$line 1 end-2
] " "]
1634 # take the first non-blank line of the comment as the headline
1635 set headline
[string trimleft
$comment]
1636 set i
[string first
"\n" $headline]
1638 set headline
[string range
$headline 0 $i]
1640 set headline
[string trimright
$headline]
1641 set i
[string first
"\r" $headline]
1643 set headline
[string trimright
[string range
$headline 0 $i]]
1646 # git log indents the comment by 4 spaces;
1647 # if we got this via git cat-file, add the indentation
1649 foreach line
[split $comment "\n"] {
1650 append newcomment
" "
1651 append newcomment
$line
1652 append newcomment
"\n"
1654 set comment
$newcomment
1656 if {$comdate != {}} {
1657 set cdate
($id) $comdate
1659 set commitinfo
($id) [list
$headline $auname $audate \
1660 $comname $comdate $comment]
1663 proc getcommit
{id
} {
1664 global commitdata commitinfo
1666 if {[info exists commitdata
($id)]} {
1667 parsecommit
$id $commitdata($id) 1
1670 if {![info exists commitinfo
($id)]} {
1671 set commitinfo
($id) [list
[mc
"No commit information available"]]
1677 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1678 # and are present in the current view.
1679 # This is fairly slow...
1680 proc longid
{prefix
} {
1681 global varcid curview
1684 foreach match
[array names varcid
"$curview,$prefix*"] {
1685 lappend ids
[lindex
[split $match ","] 1]
1691 global tagids idtags headids idheads tagobjid
1692 global otherrefids idotherrefs mainhead mainheadid
1693 global selecthead selectheadid
1696 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1699 set refd
[open
[list | git show-ref
-d] r
]
1700 while {[gets
$refd line
] >= 0} {
1701 if {[string index
$line 40] ne
" "} continue
1702 set id
[string range
$line 0 39]
1703 set ref
[string range
$line 41 end
]
1704 if {![string match
"refs/*" $ref]} continue
1705 set name
[string range
$ref 5 end
]
1706 if {[string match
"remotes/*" $name]} {
1707 if {![string match
"*/HEAD" $name] && !$hideremotes} {
1708 set headids
($name) $id
1709 lappend idheads
($id) $name
1711 } elseif
{[string match
"heads/*" $name]} {
1712 set name
[string range
$name 6 end
]
1713 set headids
($name) $id
1714 lappend idheads
($id) $name
1715 } elseif
{[string match
"tags/*" $name]} {
1716 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1717 # which is what we want since the former is the commit ID
1718 set name
[string range
$name 5 end
]
1719 if {[string match
"*^{}" $name]} {
1720 set name
[string range
$name 0 end-3
]
1722 set tagobjid
($name) $id
1724 set tagids
($name) $id
1725 lappend idtags
($id) $name
1727 set otherrefids
($name) $id
1728 lappend idotherrefs
($id) $name
1735 set mainheadid
[exec git rev-parse HEAD
]
1736 set thehead
[exec git symbolic-ref HEAD
]
1737 if {[string match
"refs/heads/*" $thehead]} {
1738 set mainhead
[string range
$thehead 11 end
]
1742 if {$selecthead ne
{}} {
1744 set selectheadid
[exec git rev-parse
--verify $selecthead]
1749 # skip over fake commits
1750 proc first_real_row
{} {
1751 global nullid nullid2 numcommits
1753 for {set row
0} {$row < $numcommits} {incr row
} {
1754 set id
[commitonrow
$row]
1755 if {$id ne
$nullid && $id ne
$nullid2} {
1762 # update things for a head moved to a child of its previous location
1763 proc movehead
{id name
} {
1764 global headids idheads
1766 removehead
$headids($name) $name
1767 set headids
($name) $id
1768 lappend idheads
($id) $name
1771 # update things when a head has been removed
1772 proc removehead
{id name
} {
1773 global headids idheads
1775 if {$idheads($id) eq
$name} {
1778 set i
[lsearch
-exact $idheads($id) $name]
1780 set idheads
($id) [lreplace
$idheads($id) $i $i]
1783 unset headids
($name)
1786 proc ttk_toplevel
{w args
} {
1788 eval [linsert
$args 0 ::toplevel
$w]
1790 place
[ttk
::frame
$w._toplevel_background
] -x 0 -y 0 -relwidth 1 -relheight 1
1795 proc make_transient
{window origin
} {
1798 # In MacOS Tk 8.4 transient appears to work by setting
1799 # overrideredirect, which is utterly useless, since the
1800 # windows get no border, and are not even kept above
1802 if {!$have_tk85 && [tk windowingsystem
] eq
{aqua
}} return
1804 wm transient
$window $origin
1806 # Windows fails to place transient windows normally, so
1807 # schedule a callback to center them on the parent.
1808 if {[tk windowingsystem
] eq
{win32
}} {
1809 after idle
[list tk
::PlaceWindow
$window widget
$origin]
1813 proc show_error
{w top msg
{mc mc
}} {
1815 if {![info exists NS
]} {set NS
""}
1816 if {[wm state
$top] eq
"withdrawn"} { wm deiconify
$top }
1817 message
$w.m
-text $msg -justify center
-aspect 400
1818 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1819 ${NS}::button
$w.ok
-default active
-text [$mc OK
] -command "destroy $top"
1820 pack
$w.ok
-side bottom
-fill x
1821 bind $top <Visibility
> "grab $top; focus $top"
1822 bind $top <Key-Return
> "destroy $top"
1823 bind $top <Key-space
> "destroy $top"
1824 bind $top <Key-Escape
> "destroy $top"
1828 proc error_popup
{msg
{owner .
}} {
1829 if {[tk windowingsystem
] eq
"win32"} {
1830 tk_messageBox
-icon error
-type ok
-title [wm title .
] \
1831 -parent $owner -message $msg
1835 make_transient
$w $owner
1836 show_error
$w $w $msg
1840 proc confirm_popup
{msg
{owner .
}} {
1841 global confirm_ok NS
1845 make_transient
$w $owner
1846 message
$w.m
-text $msg -justify center
-aspect 400
1847 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1848 ${NS}::button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1849 pack
$w.ok
-side left
-fill x
1850 ${NS}::button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1851 pack
$w.cancel
-side right
-fill x
1852 bind $w <Visibility
> "grab $w; focus $w"
1853 bind $w <Key-Return
> "set confirm_ok 1; destroy $w"
1854 bind $w <Key-space
> "set confirm_ok 1; destroy $w"
1855 bind $w <Key-Escape
> "destroy $w"
1856 tk
::PlaceWindow
$w widget
$owner
1861 proc setoptions
{} {
1862 if {[tk windowingsystem
] ne
"win32"} {
1863 option add
*Panedwindow.showHandle
1 startupFile
1864 option add
*Panedwindow.sashRelief raised startupFile
1865 if {[tk windowingsystem
] ne
"aqua"} {
1866 option add
*Menu.font uifont startupFile
1869 option add
*Menu.TearOff
0 startupFile
1871 option add
*Button.font uifont startupFile
1872 option add
*Checkbutton.font uifont startupFile
1873 option add
*Radiobutton.font uifont startupFile
1874 option add
*Menubutton.font uifont startupFile
1875 option add
*Label.font uifont startupFile
1876 option add
*Message.font uifont startupFile
1877 option add
*Entry.font uifont startupFile
1878 option add
*Labelframe.font uifont startupFile
1881 # Make a menu and submenus.
1882 # m is the window name for the menu, items is the list of menu items to add.
1883 # Each item is a list {mc label type description options...}
1884 # mc is ignored; it's so we can put mc there to alert xgettext
1885 # label is the string that appears in the menu
1886 # type is cascade, command or radiobutton (should add checkbutton)
1887 # description depends on type; it's the sublist for cascade, the
1888 # command to invoke for command, or {variable value} for radiobutton
1889 proc makemenu
{m items
} {
1891 if {[tk windowingsystem
] eq
{aqua
}} {
1897 set name
[mc
[lindex
$i 1]]
1898 set type [lindex
$i 2]
1899 set thing
[lindex
$i 3]
1900 set params
[list
$type]
1902 set u
[string first
"&" [string map
{&& x
} $name]]
1903 lappend params
-label [string map
{&& & & {}} $name]
1905 lappend params
-underline $u
1910 set submenu
[string tolower
[string map
{& ""} [lindex
$i 1]]]
1911 lappend params
-menu $m.
$submenu
1914 lappend params
-command $thing
1917 lappend params
-variable [lindex
$thing 0] \
1918 -value [lindex
$thing 1]
1921 set tail [lrange
$i 4 end
]
1922 regsub
-all {\yMeta1\y
} $tail $Meta1 tail
1923 eval $m add
$params $tail
1924 if {$type eq
"cascade"} {
1925 makemenu
$m.
$submenu $thing
1930 # translate string and remove ampersands
1932 return [string map
{&& & & {}} [mc
$str]]
1935 proc makedroplist
{w varname args
} {
1939 foreach label
$args {
1940 set cx
[string length
$label]
1941 if {$cx > $width} {set width
$cx}
1943 set gm
[ttk
::combobox
$w -width $width -state readonly\
1944 -textvariable $varname -values $args]
1946 set gm
[eval [linsert
$args 0 tk_optionMenu
$w $varname]]
1951 proc makewindow
{} {
1952 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1954 global findtype findtypemenu findloc findstring fstring geometry
1955 global entries sha1entry sha1string sha1but
1956 global diffcontextstring diffcontext
1958 global maincursor textcursor curtextcursor
1959 global rowctxmenu fakerowmenu mergemax wrapcomment
1960 global highlight_files gdttype
1961 global searchstring sstring
1962 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1963 global headctxmenu progresscanv progressitem progresscoords statusw
1964 global fprogitem fprogcoord lastprogupdate progupdatepending
1965 global rprogitem rprogcoord rownumsel numcommits
1966 global have_tk85 use_ttk NS
1968 # The "mc" arguments here are purely so that xgettext
1969 # sees the following string as needing to be translated
1972 {mc
"Update" command updatecommits
-accelerator F5
}
1973 {mc
"Reload" command reloadcommits
-accelerator Meta1-F5
}
1974 {mc
"Reread references" command rereadrefs
}
1975 {mc
"List references" command showrefs
-accelerator F2
}
1977 {mc
"Start git gui" command {exec git gui
&}}
1979 {mc
"Quit" command doquit
-accelerator Meta1-Q
}
1983 {mc
"Preferences" command doprefs
}
1987 {mc
"New view..." command {newview
0} -accelerator Shift-F4
}
1988 {mc
"Edit view..." command editview
-state disabled
-accelerator F4
}
1989 {mc
"Delete view" command delview
-state disabled
}
1991 {mc
"All files" radiobutton
{selectedview
0} -command {showview
0}}
1993 if {[tk windowingsystem
] ne
"aqua"} {
1996 {mc
"About gitk" command about
}
1997 {mc
"Key bindings" command keys
}
1999 set bar
[list
$file $edit $view $help]
2001 proc
::tk
::mac
::ShowPreferences
{} {doprefs
}
2002 proc
::tk
::mac
::Quit
{} {doquit
}
2003 lset
file end
[lreplace
[lindex
$file end
] end-1 end
]
2005 xx
"Apple" cascade
{
2006 {mc
"About gitk" command about
}
2011 {mc
"Key bindings" command keys
}
2013 set bar
[list
$apple $file $view $help]
2016 . configure
-menu .bar
2019 # cover the non-themed toplevel with a themed frame.
2020 place
[ttk
::frame ._main_background
] -x 0 -y 0 -relwidth 1 -relheight 1
2023 # the gui has upper and lower half, parts of a paned window.
2024 ${NS}::panedwindow .ctop
-orient vertical
2026 # possibly use assumed geometry
2027 if {![info exists geometry
(pwsash0
)]} {
2028 set geometry
(topheight
) [expr {15 * $linespc}]
2029 set geometry
(topwidth
) [expr {80 * $charspc}]
2030 set geometry
(botheight
) [expr {15 * $linespc}]
2031 set geometry
(botwidth
) [expr {50 * $charspc}]
2032 set geometry
(pwsash0
) [list
[expr {40 * $charspc}] 2]
2033 set geometry
(pwsash1
) [list
[expr {60 * $charspc}] 2]
2036 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2037 ${NS}::frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
2038 ${NS}::frame .tf.histframe
2039 ${NS}::panedwindow .tf.histframe.pwclist
-orient horizontal
2041 .tf.histframe.pwclist configure
-sashpad 0 -handlesize 4
2044 # create three canvases
2045 set cscroll .tf.histframe.csb
2046 set canv .tf.histframe.pwclist.canv
2048 -selectbackground $selectbgcolor \
2049 -background $bgcolor -bd 0 \
2050 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2051 .tf.histframe.pwclist add
$canv
2052 set canv2 .tf.histframe.pwclist.canv2
2054 -selectbackground $selectbgcolor \
2055 -background $bgcolor -bd 0 -yscrollincr $linespc
2056 .tf.histframe.pwclist add
$canv2
2057 set canv3 .tf.histframe.pwclist.canv3
2059 -selectbackground $selectbgcolor \
2060 -background $bgcolor -bd 0 -yscrollincr $linespc
2061 .tf.histframe.pwclist add
$canv3
2063 bind .tf.histframe.pwclist
<Map
> {
2065 .tf.histframe.pwclist sashpos
1 [lindex $
::geometry
(pwsash1
) 0]
2066 .tf.histframe.pwclist sashpos
0 [lindex $
::geometry
(pwsash0
) 0]
2069 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
2070 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
2073 # a scroll bar to rule them
2074 ${NS}::scrollbar
$cscroll -command {allcanvs yview
}
2075 if {!$use_ttk} {$cscroll configure
-highlightthickness 0}
2076 pack
$cscroll -side right
-fill y
2077 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
2078 lappend bglist
$canv $canv2 $canv3
2079 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
2081 # we have two button bars at bottom of top frame. Bar 1
2082 ${NS}::frame .tf.bar
2083 ${NS}::frame .tf.lbar
-height 15
2085 set sha1entry .tf.bar.sha1
2086 set entries
$sha1entry
2087 set sha1but .tf.bar.sha1label
2088 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
2089 -command gotocommit
-width 8
2090 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
2091 pack .tf.bar.sha1label
-side left
2092 ${NS}::entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
2093 trace add variable sha1string
write sha1change
2094 pack
$sha1entry -side left
-pady 2
2096 image create bitmap bm-left
-data {
2097 #define left_width 16
2098 #define left_height 16
2099 static unsigned char left_bits
[] = {
2100 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2101 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2102 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2104 image create bitmap bm-right
-data {
2105 #define right_width 16
2106 #define right_height 16
2107 static unsigned char right_bits
[] = {
2108 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2109 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2110 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2112 ${NS}::button .tf.bar.leftbut
-image bm-left
-command goback \
2113 -state disabled
-width 26
2114 pack .tf.bar.leftbut
-side left
-fill y
2115 ${NS}::button .tf.bar.rightbut
-image bm-right
-command goforw \
2116 -state disabled
-width 26
2117 pack .tf.bar.rightbut
-side left
-fill y
2119 ${NS}::label .tf.bar.rowlabel
-text [mc
"Row"]
2121 ${NS}::label .tf.bar.rownum
-width 7 -textvariable rownumsel \
2122 -relief sunken
-anchor e
2123 ${NS}::label .tf.bar.rowlabel2
-text "/"
2124 ${NS}::label .tf.bar.numcommits
-width 7 -textvariable numcommits \
2125 -relief sunken
-anchor e
2126 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2129 foreach w
{rownum numcommits
} {.tf.bar.
$w configure
-font textfont
}
2132 trace add variable selectedline
write selectedline_change
2134 # Status label and progress bar
2135 set statusw .tf.bar.status
2136 ${NS}::label
$statusw -width 15 -relief sunken
2137 pack
$statusw -side left
-padx 5
2139 set progresscanv
[ttk
::progressbar .tf.bar.progress
]
2141 set h
[expr {[font metrics uifont
-linespace] + 2}]
2142 set progresscanv .tf.bar.progress
2143 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
2144 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
2145 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
2146 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
2148 pack
$progresscanv -side right
-expand 1 -fill x
-padx {0 2}
2149 set progresscoords
{0 0}
2152 bind $progresscanv <Configure
> adjustprogress
2153 set lastprogupdate
[clock clicks
-milliseconds]
2154 set progupdatepending
0
2156 # build up the bottom bar of upper window
2157 ${NS}::label .tf.lbar.flabel
-text "[mc "Find
"] "
2158 ${NS}::button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
2159 ${NS}::button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
2160 ${NS}::label .tf.lbar.flab2
-text " [mc "commit
"] "
2161 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2163 set gdttype
[mc
"containing:"]
2164 set gm
[makedroplist .tf.lbar.gdttype gdttype \
2165 [mc
"containing:"] \
2166 [mc
"touching paths:"] \
2167 [mc
"adding/removing string:"]]
2168 trace add variable gdttype
write gdttype_change
2169 pack .tf.lbar.gdttype
-side left
-fill y
2172 set fstring .tf.lbar.findstring
2173 lappend entries
$fstring
2174 ${NS}::entry
$fstring -width 30 -font textfont
-textvariable findstring
2175 trace add variable findstring
write find_change
2176 set findtype
[mc
"Exact"]
2177 set findtypemenu
[makedroplist .tf.lbar.findtype \
2178 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
2179 trace add variable findtype
write findcom_change
2180 set findloc
[mc
"All fields"]
2181 makedroplist .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
2182 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
2183 trace add variable findloc
write find_change
2184 pack .tf.lbar.findloc
-side right
2185 pack .tf.lbar.findtype
-side right
2186 pack
$fstring -side left
-expand 1 -fill x
2188 # Finish putting the upper half of the viewer together
2189 pack .tf.lbar
-in .tf
-side bottom
-fill x
2190 pack .tf.bar
-in .tf
-side bottom
-fill x
2191 pack .tf.histframe
-fill both
-side top
-expand 1
2194 .ctop paneconfigure .tf
-height $geometry(topheight
)
2195 .ctop paneconfigure .tf
-width $geometry(topwidth
)
2198 # now build up the bottom
2199 ${NS}::panedwindow .pwbottom
-orient horizontal
2201 # lower left, a text box over search bar, scroll bar to the right
2202 # if we know window height, then that will set the lower text height, otherwise
2203 # we set lower text height which will drive window height
2204 if {[info exists geometry
(main
)]} {
2205 ${NS}::frame .bleft
-width $geometry(botwidth
)
2207 ${NS}::frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
2209 ${NS}::frame .bleft.top
2210 ${NS}::frame .bleft.mid
2211 ${NS}::frame .bleft.bottom
2213 ${NS}::button .bleft.top.search
-text [mc
"Search"] -command dosearch
2214 pack .bleft.top.search
-side left
-padx 5
2215 set sstring .bleft.top.sstring
2217 ${NS}::entry
$sstring -width 20 -font textfont
-textvariable searchstring
2218 lappend entries
$sstring
2219 trace add variable searchstring
write incrsearch
2220 pack
$sstring -side left
-expand 1 -fill x
2221 ${NS}::radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
2222 -command changediffdisp
-variable diffelide
-value {0 0}
2223 ${NS}::radiobutton .bleft.mid.old
-text [mc
"Old version"] \
2224 -command changediffdisp
-variable diffelide
-value {0 1}
2225 ${NS}::radiobutton .bleft.mid.new
-text [mc
"New version"] \
2226 -command changediffdisp
-variable diffelide
-value {1 0}
2227 ${NS}::label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
2228 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
2229 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
2230 -from 0 -increment 1 -to 10000000 \
2231 -validate all
-validatecommand "diffcontextvalidate %P" \
2232 -textvariable diffcontextstring
2233 .bleft.mid.diffcontext
set $diffcontext
2234 trace add variable diffcontextstring
write diffcontextchange
2235 lappend entries .bleft.mid.diffcontext
2236 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
2237 ${NS}::checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
2238 -command changeignorespace
-variable ignorespace
2239 pack .bleft.mid.ignspace
-side left
-padx 5
2240 set ctext .bleft.bottom.ctext
2241 text
$ctext -background $bgcolor -foreground $fgcolor \
2242 -state disabled
-font textfont \
2243 -yscrollcommand scrolltext
-wrap none \
2244 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2246 $ctext conf
-tabstyle wordprocessor
2248 ${NS}::scrollbar .bleft.bottom.sb
-command "$ctext yview"
2249 ${NS}::scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h
2250 pack .bleft.top
-side top
-fill x
2251 pack .bleft.mid
-side top
-fill x
2252 grid
$ctext .bleft.bottom.sb
-sticky nsew
2253 grid .bleft.bottom.sbhorizontal
-sticky ew
2254 grid columnconfigure .bleft.bottom
0 -weight 1
2255 grid rowconfigure .bleft.bottom
0 -weight 1
2256 grid rowconfigure .bleft.bottom
1 -weight 0
2257 pack .bleft.bottom
-side top
-fill both
-expand 1
2258 lappend bglist
$ctext
2259 lappend fglist
$ctext
2261 $ctext tag conf comment
-wrap $wrapcomment
2262 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
2263 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
2264 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
2265 $ctext tag conf dresult
-fore [lindex
$diffcolors 1]
2266 $ctext tag conf m0
-fore red
2267 $ctext tag conf m1
-fore blue
2268 $ctext tag conf m2
-fore green
2269 $ctext tag conf m3
-fore purple
2270 $ctext tag conf
m4 -fore brown
2271 $ctext tag conf m5
-fore "#009090"
2272 $ctext tag conf m6
-fore magenta
2273 $ctext tag conf m7
-fore "#808000"
2274 $ctext tag conf m8
-fore "#009000"
2275 $ctext tag conf m9
-fore "#ff0080"
2276 $ctext tag conf m10
-fore cyan
2277 $ctext tag conf m11
-fore "#b07070"
2278 $ctext tag conf m12
-fore "#70b0f0"
2279 $ctext tag conf m13
-fore "#70f0b0"
2280 $ctext tag conf m14
-fore "#f0b070"
2281 $ctext tag conf m15
-fore "#ff70b0"
2282 $ctext tag conf mmax
-fore darkgrey
2284 $ctext tag conf mresult
-font textfontbold
2285 $ctext tag conf msep
-font textfontbold
2286 $ctext tag conf found
-back yellow
2288 .pwbottom add .bleft
2290 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2294 ${NS}::frame .bright
2295 ${NS}::frame .bright.mode
2296 ${NS}::radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2297 -command reselectline
-variable cmitmode
-value "patch"
2298 ${NS}::radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2299 -command reselectline
-variable cmitmode
-value "tree"
2300 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2301 pack .bright.mode
-side top
-fill x
2302 set cflist .bright.cfiles
2303 set indent
[font measure mainfont
"nn"]
2305 -selectbackground $selectbgcolor \
2306 -background $bgcolor -foreground $fgcolor \
2308 -tabs [list
$indent [expr {2 * $indent}]] \
2309 -yscrollcommand ".bright.sb set" \
2310 -cursor [. cget
-cursor] \
2311 -spacing1 1 -spacing3 1
2312 lappend bglist
$cflist
2313 lappend fglist
$cflist
2314 ${NS}::scrollbar .bright.sb
-command "$cflist yview"
2315 pack .bright.sb
-side right
-fill y
2316 pack
$cflist -side left
-fill both
-expand 1
2317 $cflist tag configure highlight \
2318 -background [$cflist cget
-selectbackground]
2319 $cflist tag configure bold
-font mainfontbold
2321 .pwbottom add .bright
2324 # restore window width & height if known
2325 if {[info exists geometry
(main
)]} {
2326 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2327 if {$w > [winfo screenwidth .
]} {
2328 set w
[winfo screenwidth .
]
2330 if {$h > [winfo screenheight .
]} {
2331 set h
[winfo screenheight .
]
2333 wm geometry .
"${w}x$h"
2337 if {[info exists geometry
(state
)] && $geometry(state
) eq
"zoomed"} {
2338 wm state .
$geometry(state
)
2341 if {[tk windowingsystem
] eq
{aqua
}} {
2352 %W sashpos
0 $
::geometry
(topheight
)
2354 bind .pwbottom
<Map
> {
2356 %W sashpos
0 $
::geometry
(botwidth
)
2360 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2361 pack .ctop
-fill both
-expand 1
2362 bindall
<1> {selcanvline
%W
%x
%y
}
2363 #bindall <B1-Motion> {selcanvline %W %x %y}
2364 if {[tk windowingsystem
] == "win32"} {
2365 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2366 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2368 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2369 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2370 if {[tk windowingsystem
] eq
"aqua"} {
2371 bindall
<MouseWheel
> {
2372 set delta
[expr {- (%D
)}]
2373 allcanvs yview scroll
$delta units
2375 bindall
<Shift-MouseWheel
> {
2376 set delta
[expr {- (%D
)}]
2377 $canv xview scroll
$delta units
2381 bindall
<$
::BM
> "canvscan mark %W %x %y"
2382 bindall
<B$
::BM-Motion
> "canvscan dragto %W %x %y"
2383 bindkey
<Home
> selfirstline
2384 bindkey
<End
> sellastline
2385 bind .
<Key-Up
> "selnextline -1"
2386 bind .
<Key-Down
> "selnextline 1"
2387 bind .
<Shift-Key-Up
> "dofind -1 0"
2388 bind .
<Shift-Key-Down
> "dofind 1 0"
2389 bindkey
<Key-Right
> "goforw"
2390 bindkey
<Key-Left
> "goback"
2391 bind .
<Key-Prior
> "selnextpage -1"
2392 bind .
<Key-Next
> "selnextpage 1"
2393 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2394 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2395 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2396 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2397 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2398 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2399 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2400 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2401 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2402 bindkey p
"selnextline -1"
2403 bindkey n
"selnextline 1"
2406 bindkey i
"selnextline -1"
2407 bindkey k
"selnextline 1"
2411 bindkey d
"$ctext yview scroll 18 units"
2412 bindkey u
"$ctext yview scroll -18 units"
2413 bindkey
/ {focus
$fstring}
2414 bindkey
<Key-KP_Divide
> {focus
$fstring}
2415 bindkey
<Key-Return
> {dofind
1 1}
2416 bindkey ?
{dofind
-1 1}
2418 bind .
<F5
> updatecommits
2419 bind .
<$M1B-F5> reloadcommits
2420 bind .
<F2
> showrefs
2421 bind .
<Shift-F4
> {newview
0}
2422 catch
{ bind .
<Shift-Key-XF86_Switch_VT_4
> {newview
0} }
2423 bind .
<F4
> edit_or_newview
2424 bind .
<$M1B-q> doquit
2425 bind .
<$M1B-f> {dofind
1 1}
2426 bind .
<$M1B-g> {dofind
1 0}
2427 bind .
<$M1B-r> dosearchback
2428 bind .
<$M1B-s> dosearch
2429 bind .
<$M1B-equal> {incrfont
1}
2430 bind .
<$M1B-plus> {incrfont
1}
2431 bind .
<$M1B-KP_Add> {incrfont
1}
2432 bind .
<$M1B-minus> {incrfont
-1}
2433 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2434 wm protocol . WM_DELETE_WINDOW doquit
2435 bind .
<Destroy
> {stop_backends
}
2436 bind .
<Button-1
> "click %W"
2437 bind $fstring <Key-Return
> {dofind
1 1}
2438 bind $sha1entry <Key-Return
> {gotocommit
; break}
2439 bind $sha1entry <<PasteSelection>> clearsha1
2440 bind $cflist <1> {sel_flist %W %x %y; break}
2441 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2442 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2444 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2445 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2447 set maincursor [. cget -cursor]
2448 set textcursor [$ctext cget -cursor]
2449 set curtextcursor $textcursor
2451 set rowctxmenu .rowctxmenu
2452 makemenu $rowctxmenu {
2453 {mc "Diff this -> selected" command {diffvssel 0}}
2454 {mc "Diff selected -> this" command {diffvssel 1}}
2455 {mc "Make patch" command mkpatch}
2456 {mc "Create tag" command mktag}
2457 {mc "Write commit to file" command writecommit}
2458 {mc "Create new branch" command mkbranch}
2459 {mc "Cherry-pick this commit" command cherrypick}
2460 {mc "Reset HEAD branch to here" command resethead}
2461 {mc "Mark this commit" command markhere}
2462 {mc "Return to mark" command gotomark}
2463 {mc "Find descendant of this and mark" command find_common_desc}
2464 {mc "Compare with marked commit" command compare_commits}
2466 $rowctxmenu configure -tearoff 0
2468 set fakerowmenu .fakerowmenu
2469 makemenu $fakerowmenu {
2470 {mc "Diff this -> selected" command {diffvssel 0}}
2471 {mc "Diff selected -> this" command {diffvssel 1}}
2472 {mc "Make patch" command mkpatch}
2474 $fakerowmenu configure -tearoff 0
2476 set headctxmenu .headctxmenu
2477 makemenu $headctxmenu {
2478 {mc "Check out this branch" command cobranch}
2479 {mc "Remove this branch" command rmbranch}
2481 $headctxmenu configure -tearoff 0
2484 set flist_menu .flistctxmenu
2485 makemenu $flist_menu {
2486 {mc "Highlight this too" command {flist_hl 0}}
2487 {mc "Highlight this only" command {flist_hl 1}}
2488 {mc "External diff" command {external_diff}}
2489 {mc "Blame parent commit" command {external_blame 1}}
2491 $flist_menu configure -tearoff 0
2494 set diff_menu .diffctxmenu
2495 makemenu $diff_menu {
2496 {mc "Show origin of this line" command show_line_source}
2497 {mc "Run git gui blame on this line" command {external_blame_diff}}
2499 $diff_menu configure -tearoff 0
2502 # Windows sends all mouse wheel events to the current focused window, not
2503 # the one where the mouse hovers, so bind those events here and redirect
2504 # to the correct window
2505 proc windows_mousewheel_redirector {W X Y D} {
2506 global canv canv2 canv3
2507 set w [winfo containing -displayof $W $X $Y]
2509 set u [expr {$D < 0 ? 5 : -5}]
2510 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2511 allcanvs yview scroll $u units
2514 $w yview scroll $u units
2520 # Update row number label when selectedline changes
2521 proc selectedline_change {n1 n2 op} {
2522 global selectedline rownumsel
2524 if {$selectedline eq {}} {
2527 set rownumsel [expr {$selectedline + 1}]
2531 # mouse-2 makes all windows scan vertically, but only the one
2532 # the cursor is in scans horizontally
2533 proc canvscan {op w x y} {
2534 global canv canv2 canv3
2535 foreach c [list $canv $canv2 $canv3] {
2544 proc scrollcanv {cscroll f0 f1} {
2545 $cscroll set $f0 $f1
2550 # when we make a key binding for the toplevel, make sure
2551 # it doesn't get triggered when that key is pressed in the
2552 # find string entry widget.
2553 proc bindkey {ev script} {
2556 set escript [bind Entry $ev]
2557 if {$escript == {}} {
2558 set escript [bind Entry <Key>]
2560 foreach e $entries {
2561 bind $e $ev "$escript; break"
2565 # set the focus back to the toplevel for any click outside
2568 global ctext entries
2569 foreach e [concat $entries $ctext] {
2570 if {$w == $e} return
2575 # Adjust the progress bar for a change in requested extent or canvas size
2576 proc adjustprogress {} {
2577 global progresscanv progressitem progresscoords
2578 global fprogitem fprogcoord lastprogupdate progupdatepending
2579 global rprogitem rprogcoord use_ttk
2582 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2586 set w [expr {[winfo width $progresscanv] - 4}]
2587 set x0 [expr {$w * [lindex $progresscoords 0]}]
2588 set x1 [expr {$w * [lindex $progresscoords 1]}]
2589 set h [winfo height $progresscanv]
2590 $progresscanv coords $progressitem $x0 0 $x1 $h
2591 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2592 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2593 set now [clock clicks -milliseconds]
2594 if {$now >= $lastprogupdate + 100} {
2595 set progupdatepending 0
2597 } elseif {!$progupdatepending} {
2598 set progupdatepending 1
2599 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2603 proc doprogupdate {} {
2604 global lastprogupdate progupdatepending
2606 if {$progupdatepending} {
2607 set progupdatepending 0
2608 set lastprogupdate [clock clicks -milliseconds]
2613 proc savestuff {w} {
2614 global canv canv2 canv3 mainfont textfont uifont tabstop
2615 global stuffsaved findmergefiles maxgraphpct
2616 global maxwidth showneartags showlocalchanges
2617 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2618 global cmitmode wrapcomment datetimeformat limitdiffs
2619 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2620 global autoselect extdifftool perfile_attrs markbgcolor use_ttk
2621 global hideremotes want_ttk
2623 if {$stuffsaved} return
2624 if {![winfo viewable .]} return
2626 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2627 set f [open "~/.gitk-new" w]
2628 if {$::tcl_platform(platform) eq {windows}} {
2629 file attributes "~/.gitk-new" -hidden true
2631 puts $f [list set mainfont $mainfont]
2632 puts $f [list set textfont $textfont]
2633 puts $f [list set uifont $uifont]
2634 puts $f [list set tabstop $tabstop]
2635 puts $f [list set findmergefiles $findmergefiles]
2636 puts $f [list set maxgraphpct $maxgraphpct]
2637 puts $f [list set maxwidth $maxwidth]
2638 puts $f [list set cmitmode $cmitmode]
2639 puts $f [list set wrapcomment $wrapcomment]
2640 puts $f [list set autoselect $autoselect]
2641 puts $f [list set showneartags $showneartags]
2642 puts $f [list set hideremotes $hideremotes]
2643 puts $f [list set showlocalchanges $showlocalchanges]
2644 puts $f [list set datetimeformat $datetimeformat]
2645 puts $f [list set limitdiffs $limitdiffs]
2646 puts $f [list set uicolor $uicolor]
2647 puts $f [list set want_ttk $want_ttk]
2648 puts $f [list set bgcolor $bgcolor]
2649 puts $f [list set fgcolor $fgcolor]
2650 puts $f [list set colors $colors]
2651 puts $f [list set diffcolors $diffcolors]
2652 puts $f [list set markbgcolor $markbgcolor]
2653 puts $f [list set diffcontext $diffcontext]
2654 puts $f [list set selectbgcolor $selectbgcolor]
2655 puts $f [list set extdifftool $extdifftool]
2656 puts $f [list set perfile_attrs $perfile_attrs]
2658 puts $f "set geometry(main) [wm geometry .]"
2659 puts $f "set geometry(state) [wm state .]"
2660 puts $f "set geometry(topwidth) [winfo width .tf]"
2661 puts $f "set geometry(topheight) [winfo height .tf]"
2663 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2664 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2666 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2667 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2669 puts $f "set geometry(botwidth) [winfo width .bleft]"
2670 puts $f "set geometry(botheight) [winfo height .bleft]"
2672 puts -nonewline $f "set permviews {"
2673 for {set v 0} {$v < $nextviewnum} {incr v} {
2674 if {$viewperm($v)} {
2675 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2680 file rename -force "~/.gitk-new" "~/.gitk"
2685 proc resizeclistpanes {win w} {
2686 global oldwidth use_ttk
2687 if {[info exists oldwidth($win)]} {
2689 set s0 [$win sashpos 0]
2690 set s1 [$win sashpos 1]
2692 set s0 [$win sash coord 0]
2693 set s1 [$win sash coord 1]
2696 set sash0 [expr {int($w/2 - 2)}]
2697 set sash1 [expr {int($w*5/6 - 2)}]
2699 set factor [expr {1.0 * $w / $oldwidth($win)}]
2700 set sash0 [expr {int($factor * [lindex $s0 0])}]
2701 set sash1 [expr {int($factor * [lindex $s1 0])}]
2705 if {$sash1 < $sash0 + 20} {
2706 set sash1 [expr {$sash0 + 20}]
2708 if {$sash1 > $w - 10} {
2709 set sash1 [expr {$w - 10}]
2710 if {$sash0 > $sash1 - 20} {
2711 set sash0 [expr {$sash1 - 20}]
2716 $win sashpos 0 $sash0
2717 $win sashpos 1 $sash1
2719 $win sash place 0 $sash0 [lindex $s0 1]
2720 $win sash place 1 $sash1 [lindex $s1 1]
2723 set oldwidth($win) $w
2726 proc resizecdetpanes {win w} {
2727 global oldwidth use_ttk
2728 if {[info exists oldwidth($win)]} {
2730 set s0 [$win sashpos 0]
2732 set s0 [$win sash coord 0]
2735 set sash0 [expr {int($w*3/4 - 2)}]
2737 set factor [expr {1.0 * $w / $oldwidth($win)}]
2738 set sash0 [expr {int($factor * [lindex $s0 0])}]
2742 if {$sash0 > $w - 15} {
2743 set sash0 [expr {$w - 15}]
2747 $win sashpos 0 $sash0
2749 $win sash place 0 $sash0 [lindex $s0 1]
2752 set oldwidth($win) $w
2755 proc allcanvs args {
2756 global canv canv2 canv3
2762 proc bindall {event action} {
2763 global canv canv2 canv3
2764 bind $canv $event $action
2765 bind $canv2 $event $action
2766 bind $canv3 $event $action
2772 if {[winfo exists $w]} {
2777 wm title $w [mc "About gitk"]
2779 message $w.m -text [mc "
2780 Gitk - a commit viewer for git
2782 Copyright \u00a9 2005-2009 Paul Mackerras
2784 Use and redistribute under the terms of the GNU General Public License"] \
2785 -justify center -aspect 400 -border 2 -bg white -relief groove
2786 pack $w.m -side top -fill x -padx 2 -pady 2
2787 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2788 pack $w.ok -side bottom
2789 bind $w <Visibility> "focus $w.ok"
2790 bind $w <Key-Escape> "destroy $w"
2791 bind $w <Key-Return> "destroy $w"
2792 tk::PlaceWindow $w widget .
2798 if {[winfo exists $w]} {
2802 if {[tk windowingsystem] eq {aqua}} {
2808 wm title $w [mc "Gitk key bindings"]
2810 message $w.m -text "
2811 [mc "Gitk key bindings:"]
2813 [mc "<%s-Q> Quit" $M1T]
2814 [mc "<Home> Move to first commit"]
2815 [mc "<End> Move to last commit"]
2816 [mc "<Up>, p, i Move up one commit"]
2817 [mc "<Down>, n, k Move down one commit"]
2818 [mc "<Left>, z, j Go back in history list"]
2819 [mc "<Right>, x, l Go forward in history list"]
2820 [mc "<PageUp> Move up one page in commit list"]
2821 [mc "<PageDown> Move down one page in commit list"]
2822 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2823 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2824 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2825 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2826 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2827 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2828 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2829 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2830 [mc "<Delete>, b Scroll diff view up one page"]
2831 [mc "<Backspace> Scroll diff view up one page"]
2832 [mc "<Space> Scroll diff view down one page"]
2833 [mc "u Scroll diff view up 18 lines"]
2834 [mc "d Scroll diff view down 18 lines"]
2835 [mc "<%s-F> Find" $M1T]
2836 [mc "<%s-G> Move to next find hit" $M1T]
2837 [mc "<Return> Move to next find hit"]
2838 [mc "/ Focus the search box"]
2839 [mc "? Move to previous find hit"]
2840 [mc "f Scroll diff view to next file"]
2841 [mc "<%s-S> Search for next hit in diff view" $M1T]
2842 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2843 [mc "<%s-KP+> Increase font size" $M1T]
2844 [mc "<%s-plus> Increase font size" $M1T]
2845 [mc "<%s-KP-> Decrease font size" $M1T]
2846 [mc "<%s-minus> Decrease font size" $M1T]
2849 -justify left -bg white -border 2 -relief groove
2850 pack $w.m -side top -fill both -padx 2 -pady 2
2851 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2852 bind $w <Key-Escape> [list destroy $w]
2853 pack $w.ok -side bottom
2854 bind $w <Visibility> "focus $w.ok"
2855 bind $w <Key-Escape> "destroy $w"
2856 bind $w <Key-Return> "destroy $w"
2859 # Procedures for manipulating the file list window at the
2860 # bottom right of the overall window.
2862 proc treeview {w l openlevs} {
2863 global treecontents treediropen treeheight treeparent treeindex
2873 set treecontents() {}
2874 $w conf -state normal
2876 while {[string range $f 0 $prefixend] ne $prefix} {
2877 if {$lev <= $openlevs} {
2878 $w mark set e:$treeindex($prefix) "end -1c"
2879 $w mark gravity e:$treeindex($prefix) left
2881 set treeheight($prefix) $ht
2882 incr ht [lindex $htstack end]
2883 set htstack [lreplace $htstack end end]
2884 set prefixend [lindex $prefendstack end]
2885 set prefendstack [lreplace $prefendstack end end]
2886 set prefix [string range $prefix 0 $prefixend]
2889 set tail [string range $f [expr {$prefixend+1}] end]
2890 while {[set slash [string first "/" $tail]] >= 0} {
2893 lappend prefendstack $prefixend
2894 incr prefixend [expr {$slash + 1}]
2895 set d [string range $tail 0 $slash]
2896 lappend treecontents($prefix) $d
2897 set oldprefix $prefix
2899 set treecontents($prefix) {}
2900 set treeindex($prefix) [incr ix]
2901 set treeparent($prefix) $oldprefix
2902 set tail [string range $tail [expr {$slash+1}] end]
2903 if {$lev <= $openlevs} {
2905 set treediropen($prefix) [expr {$lev < $openlevs}]
2906 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2907 $w mark set d:$ix "end -1c"
2908 $w mark gravity d:$ix left
2910 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2912 $w image create end -align center -image $bm -padx 1 \
2914 $w insert end $d [highlight_tag $prefix]
2915 $w mark set s:$ix "end -1c"
2916 $w mark gravity s:$ix left
2921 if {$lev <= $openlevs} {
2924 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2926 $w insert end $tail [highlight_tag $f]
2928 lappend treecontents($prefix) $tail
2931 while {$htstack ne {}} {
2932 set treeheight($prefix) $ht
2933 incr ht [lindex $htstack end]
2934 set htstack [lreplace $htstack end end]
2935 set prefixend [lindex $prefendstack end]
2936 set prefendstack [lreplace $prefendstack end end]
2937 set prefix [string range $prefix 0 $prefixend]
2939 $w conf -state disabled
2942 proc linetoelt {l} {
2943 global treeheight treecontents
2948 foreach e $treecontents($prefix) {
2953 if {[string index $e end] eq "/"} {
2954 set n $treeheight($prefix$e)
2966 proc highlight_tree {y prefix} {
2967 global treeheight treecontents cflist
2969 foreach e $treecontents($prefix) {
2971 if {[highlight_tag $path] ne {}} {
2972 $cflist tag add bold $y.0 "$y.0 lineend"
2975 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2976 set y [highlight_tree $y $path]
2982 proc treeclosedir {w dir} {
2983 global treediropen treeheight treeparent treeindex
2985 set ix $treeindex($dir)
2986 $w conf -state normal
2987 $w delete s:$ix e:$ix
2988 set treediropen($dir) 0
2989 $w image configure a:$ix -image tri-rt
2990 $w conf -state disabled
2991 set n [expr {1 - $treeheight($dir)}]
2992 while {$dir ne {}} {
2993 incr treeheight($dir) $n
2994 set dir $treeparent($dir)
2998 proc treeopendir {w dir} {
2999 global treediropen treeheight treeparent treecontents treeindex
3001 set ix $treeindex($dir)
3002 $w conf -state normal
3003 $w image configure a:$ix -image tri-dn
3004 $w mark set e:$ix s:$ix
3005 $w mark gravity e:$ix right
3008 set n [llength $treecontents($dir)]
3009 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3012 incr treeheight($x) $n
3014 foreach e $treecontents($dir) {
3016 if {[string index $e end] eq "/"} {
3017 set iy $treeindex($de)
3018 $w mark set d:$iy e:$ix
3019 $w mark gravity d:$iy left
3020 $w insert e:$ix $str
3021 set treediropen($de) 0
3022 $w image create e:$ix -align center -image tri-rt -padx 1 \
3024 $w insert e:$ix $e [highlight_tag $de]
3025 $w mark set s:$iy e:$ix
3026 $w mark gravity s:$iy left
3027 set treeheight($de) 1
3029 $w insert e:$ix $str
3030 $w insert e:$ix $e [highlight_tag $de]
3033 $w mark gravity e:$ix right
3034 $w conf -state disabled
3035 set treediropen($dir) 1
3036 set top [lindex [split [$w index @0,0] .] 0]
3037 set ht [$w cget -height]
3038 set l [lindex [split [$w index s:$ix] .] 0]
3041 } elseif {$l + $n + 1 > $top + $ht} {
3042 set top [expr {$l + $n + 2 - $ht}]
3050 proc treeclick {w x y} {
3051 global treediropen cmitmode ctext cflist cflist_top
3053 if {$cmitmode ne "tree"} return
3054 if {![info exists cflist_top]} return
3055 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3056 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3057 $cflist tag add highlight $l.0 "$l.0 lineend"
3063 set e [linetoelt $l]
3064 if {[string index $e end] ne "/"} {
3066 } elseif {$treediropen($e)} {
3073 proc setfilelist {id} {
3074 global treefilelist cflist jump_to_here
3076 treeview $cflist $treefilelist($id) 0
3077 if {$jump_to_here ne {}} {
3078 set f [lindex $jump_to_here 0]
3079 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3085 image create bitmap tri-rt -background black -foreground blue -data {
3086 #define tri-rt_width 13
3087 #define tri-rt_height 13
3088 static unsigned char tri-rt_bits[] = {
3089 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3090 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3093 #define tri-rt-mask_width 13
3094 #define tri-rt-mask_height 13
3095 static unsigned char tri-rt-mask_bits[] = {
3096 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3097 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3100 image create bitmap tri-dn -background black -foreground blue -data {
3101 #define tri-dn_width 13
3102 #define tri-dn_height 13
3103 static unsigned char tri-dn_bits[] = {
3104 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3105 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3108 #define tri-dn-mask_width 13
3109 #define tri-dn-mask_height 13
3110 static unsigned char tri-dn-mask_bits[] = {
3111 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3112 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3116 image create bitmap reficon-T -background black -foreground yellow -data {
3117 #define tagicon_width 13
3118 #define tagicon_height 9
3119 static unsigned char tagicon_bits[] = {
3120 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3121 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3123 #define tagicon-mask_width 13
3124 #define tagicon-mask_height 9
3125 static unsigned char tagicon-mask_bits[] = {
3126 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3127 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3130 #define headicon_width 13
3131 #define headicon_height 9
3132 static unsigned char headicon_bits[] = {
3133 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3134 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3137 #define headicon-mask_width 13
3138 #define headicon-mask_height 9
3139 static unsigned char headicon-mask_bits[] = {
3140 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3141 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3143 image create bitmap reficon-H -background black -foreground green \
3144 -data $rectdata -maskdata $rectmask
3145 image create bitmap reficon-o -background black -foreground "#ddddff" \
3146 -data $rectdata -maskdata $rectmask
3148 proc init_flist {first} {
3149 global cflist cflist_top difffilestart
3151 $cflist conf -state normal
3152 $cflist delete 0.0 end
3154 $cflist insert end $first
3156 $cflist tag add highlight 1.0 "1.0 lineend"
3158 catch {unset cflist_top}
3160 $cflist conf -state disabled
3161 set difffilestart {}
3164 proc highlight_tag {f} {
3165 global highlight_paths
3167 foreach p $highlight_paths {
3168 if {[string match $p $f]} {
3175 proc highlight_filelist {} {
3176 global cmitmode cflist
3178 $cflist conf -state normal
3179 if {$cmitmode ne "tree"} {
3180 set end [lindex [split [$cflist index end] .] 0]
3181 for {set l 2} {$l < $end} {incr l} {
3182 set line [$cflist get $l.0 "$l.0 lineend"]
3183 if {[highlight_tag $line] ne {}} {
3184 $cflist tag add bold $l.0 "$l.0 lineend"
3190 $cflist conf -state disabled
3193 proc unhighlight_filelist {} {
3196 $cflist conf -state normal
3197 $cflist tag remove bold 1.0 end
3198 $cflist conf -state disabled
3201 proc add_flist {fl} {
3204 $cflist conf -state normal
3206 $cflist insert end "\n"
3207 $cflist insert end $f [highlight_tag $f]
3209 $cflist conf -state disabled
3212 proc sel_flist {w x y} {
3213 global ctext difffilestart cflist cflist_top cmitmode
3215 if {$cmitmode eq "tree"} return
3216 if {![info exists cflist_top]} return
3217 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3218 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3219 $cflist tag add highlight $l.0 "$l.0 lineend"
3224 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3228 proc pop_flist_menu {w X Y x y} {
3229 global ctext cflist cmitmode flist_menu flist_menu_file
3230 global treediffs diffids
3233 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3235 if {$cmitmode eq "tree"} {
3236 set e [linetoelt $l]
3237 if {[string index $e end] eq "/"} return
3239 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3241 set flist_menu_file $e
3242 set xdiffstate "normal"
3243 if {$cmitmode eq "tree"} {
3244 set xdiffstate "disabled"
3246 # Disable "External diff" item in tree mode
3247 $flist_menu entryconf 2 -state $xdiffstate
3248 tk_popup $flist_menu $X $Y
3251 proc find_ctext_fileinfo {line} {
3252 global ctext_file_names ctext_file_lines
3254 set ok [bsearch $ctext_file_lines $line]
3255 set tline [lindex $ctext_file_lines $ok]
3257 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3260 return [list [lindex $ctext_file_names $ok] $tline]
3264 proc pop_diff_menu {w X Y x y} {
3265 global ctext diff_menu flist_menu_file
3266 global diff_menu_txtpos diff_menu_line
3267 global diff_menu_filebase
3269 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3270 set diff_menu_line [lindex $diff_menu_txtpos 0]
3271 # don't pop up the menu on hunk-separator or file-separator lines
3272 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3276 set f [find_ctext_fileinfo $diff_menu_line]
3277 if {$f eq {}} return
3278 set flist_menu_file [lindex $f 0]
3279 set diff_menu_filebase [lindex $f 1]
3280 tk_popup $diff_menu $X $Y
3283 proc flist_hl {only} {
3284 global flist_menu_file findstring gdttype
3286 set x [shellquote $flist_menu_file]
3287 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3290 append findstring " " $x
3292 set gdttype [mc "touching paths:"]
3295 proc gitknewtmpdir {} {
3296 global diffnum gitktmpdir gitdir
3298 if {![info exists gitktmpdir]} {
3299 set gitktmpdir [file join [file dirname $gitdir] \
3300 [format ".gitk-tmp.%s" [pid]]]
3301 if {[catch {file mkdir $gitktmpdir} err]} {
3302 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3309 set diffdir [file join $gitktmpdir $diffnum]
3310 if {[catch {file mkdir $diffdir} err]} {
3311 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3317 proc save_file_from_commit {filename output what} {
3320 if {[catch {exec git show $filename -- > $output} err]} {
3321 if {[string match "fatal: bad revision *" $err]} {
3324 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3330 proc external_diff_get_one_file {diffid filename diffdir} {
3331 global nullid nullid2 nullfile
3334 if {$diffid == $nullid} {
3335 set difffile [file join [file dirname $gitdir] $filename]
3336 if {[file exists $difffile]} {
3341 if {$diffid == $nullid2} {
3342 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3343 return [save_file_from_commit :$filename $difffile index]
3345 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3346 return [save_file_from_commit $diffid:$filename $difffile \
3350 proc external_diff {} {
3351 global nullid nullid2
3352 global flist_menu_file
3356 if {[llength $diffids] == 1} {
3357 # no reference commit given
3358 set diffidto [lindex $diffids 0]
3359 if {$diffidto eq $nullid} {
3360 # diffing working copy with index
3361 set diffidfrom $nullid2
3362 } elseif {$diffidto eq $nullid2} {
3363 # diffing index with HEAD
3364 set diffidfrom "HEAD"
3366 # use first parent commit
3367 global parentlist selectedline
3368 set diffidfrom [lindex $parentlist $selectedline 0]
3371 set diffidfrom [lindex $diffids 0]
3372 set diffidto [lindex $diffids 1]
3375 # make sure that several diffs wont collide
3376 set diffdir [gitknewtmpdir]
3377 if {$diffdir eq {}} return
3379 # gather files to diff
3380 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3381 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3383 if {$difffromfile ne {} && $difftofile ne {}} {
3384 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3385 if {[catch {set fl [open |$cmd r]} err]} {
3386 file delete -force $diffdir
3387 error_popup "$extdifftool: [mc "command failed:"] $err"
3389 fconfigure $fl -blocking 0
3390 filerun $fl [list delete_at_eof $fl $diffdir]
3395 proc find_hunk_blamespec {base line} {
3398 # Find and parse the hunk header
3399 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3400 if {$s_lix eq {}} return
3402 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3403 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3404 s_line old_specs osz osz1 new_line nsz]} {
3408 # base lines for the parents
3409 set base_lines [list $new_line]
3410 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3411 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3412 old_spec old_line osz]} {
3415 lappend base_lines $old_line
3418 # Now scan the lines to determine offset within the hunk
3419 set max_parent [expr {[llength $base_lines]-2}]
3421 set s_lno [lindex [split $s_lix "."] 0]
3423 # Determine if the line is removed
3424 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3425 if {[string match {[-+ ]*} $chunk]} {
3426 set removed_idx [string first "-" $chunk]
3427 # Choose a parent index
3428 if {$removed_idx >= 0} {
3429 set parent $removed_idx
3431 set unchanged_idx [string first " " $chunk]
3432 if {$unchanged_idx >= 0} {
3433 set parent $unchanged_idx
3435 # blame the current commit
3439 # then count other lines that belong to it
3440 for {set i $line} {[incr i -1] > $s_lno} {} {
3441 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3442 # Determine if the line is removed
3443 set removed_idx [string first "-" $chunk]
3445 set code [string index $chunk $parent]
3446 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3450 if {$removed_idx < 0} {
3460 incr dline [lindex $base_lines $parent]
3461 return [list $parent $dline]
3464 proc external_blame_diff {} {
3465 global currentid cmitmode
3466 global diff_menu_txtpos diff_menu_line
3467 global diff_menu_filebase flist_menu_file
3469 if {$cmitmode eq "tree"} {
3471 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3473 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3475 set parent_idx [lindex $hinfo 0]
3476 set line [lindex $hinfo 1]
3483 external_blame $parent_idx $line
3486 # Find the SHA1 ID of the blob for file $fname in the index
3488 proc index_sha1 {fname} {
3489 set f [open [list | git ls-files -s $fname] r]
3490 while {[gets $f line] >= 0} {
3491 set info [lindex [split $line "\t"] 0]
3492 set stage [lindex $info 2]
3493 if {$stage eq "0" || $stage eq "2"} {
3495 return [lindex $info 1]
3502 # Turn an absolute path into one relative to the current directory
3503 proc make_relative {f} {
3504 if {[file pathtype $f] eq "relative"} {
3507 set elts [file split $f]
3508 set here [file split [pwd]]
3513 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3520 set elts [concat $res [lrange $elts $ei end]]
3521 return [eval file join $elts]
3524 proc external_blame {parent_idx {line {}}} {
3525 global flist_menu_file gitdir
3526 global nullid nullid2
3527 global parentlist selectedline currentid
3529 if {$parent_idx > 0} {
3530 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3532 set base_commit $currentid
3535 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3536 error_popup [mc "No such commit"]
3540 set cmdline [list git gui blame]
3541 if {$line ne {} && $line > 1} {
3542 lappend cmdline "--line=$line"
3544 set f [file join [file dirname $gitdir] $flist_menu_file]
3545 # Unfortunately it seems git gui blame doesn't like
3546 # being given an absolute path...
3547 set f [make_relative $f]
3548 lappend cmdline $base_commit $f
3549 if {[catch {eval exec $cmdline &} err]} {
3550 error_popup "[mc "git gui blame: command failed:"] $err"
3554 proc show_line_source {} {
3555 global cmitmode currentid parents curview blamestuff blameinst
3556 global diff_menu_line diff_menu_filebase flist_menu_file
3557 global nullid nullid2 gitdir
3560 if {$cmitmode eq "tree"} {
3562 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3564 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3565 if {$h eq {}} return
3566 set pi [lindex $h 0]
3568 mark_ctext_line $diff_menu_line
3572 if {$currentid eq $nullid} {
3574 # must be a merge in progress...
3576 # get the last line from .git/MERGE_HEAD
3577 set f [open [file join $gitdir MERGE_HEAD] r]
3578 set id [lindex [split [read $f] "\n"] end-1]
3581 error_popup [mc "Couldn't read merge head: %s" $err]
3584 } elseif {$parents($curview,$currentid) eq $nullid2} {
3585 # need to do the blame from the index
3587 set from_index [index_sha1 $flist_menu_file]
3589 error_popup [mc "Error reading index: %s" $err]
3593 set id $parents($curview,$currentid)
3596 set id [lindex $parents($curview,$currentid) $pi]
3598 set line [lindex $h 1]
3601 if {$from_index ne {}} {
3602 lappend blameargs | git cat-file blob $from_index
3604 lappend blameargs | git blame -p -L$line,+1
3605 if {$from_index ne {}} {
3606 lappend blameargs --contents -
3608 lappend blameargs $id
3610 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3612 set f [open $blameargs r]
3614 error_popup [mc "Couldn't start git blame: %s" $err]
3617 nowbusy blaming [mc "Searching"]
3618 fconfigure $f -blocking 0
3619 set i [reg_instance $f]
3620 set blamestuff($i) {}
3622 filerun $f [list read_line_source $f $i]
3625 proc stopblaming {} {
3628 if {[info exists blameinst]} {
3629 stop_instance $blameinst
3635 proc read_line_source {fd inst} {
3636 global blamestuff curview commfd blameinst nullid nullid2
3638 while {[gets $fd line] >= 0} {
3639 lappend blamestuff($inst) $line
3647 fconfigure $fd -blocking 1
3648 if {[catch {close $fd} err]} {
3649 error_popup [mc "Error running git blame: %s" $err]
3654 set line [split [lindex $blamestuff($inst) 0] " "]
3655 set id [lindex $line 0]
3656 set lnum [lindex $line 1]
3657 if {[string length $id] == 40 && [string is xdigit $id] &&
3658 [string is digit -strict $lnum]} {
3659 # look for "filename" line
3660 foreach l $blamestuff($inst) {
3661 if {[string match "filename *" $l]} {
3662 set fname [string range $l 9 end]
3668 # all looks good, select it
3669 if {$id eq $nullid} {
3670 # blame uses all-zeroes to mean not committed,
3671 # which would mean a change in the index
3674 if {[commitinview $id $curview]} {
3675 selectline [rowofcommit $id] 1 [list $fname $lnum]
3677 error_popup [mc "That line comes from commit %s, \
3678 which is not in this view" [shortids $id]]
3681 puts "oops couldn't parse git blame output"
3686 # delete $dir when we see eof on $f (presumably because the child has exited)
3687 proc delete_at_eof {f dir} {
3688 while {[gets $f line] >= 0} {}
3690 if {[catch {close $f} err]} {
3691 error_popup "[mc "External diff viewer failed:"] $err"
3693 file delete -force $dir
3699 # Functions for adding and removing shell-type quoting
3701 proc shellquote {str} {
3702 if {![string match "*\['\"\\ \t]*" $str]} {
3705 if {![string match "*\['\"\\]*" $str]} {
3708 if {![string match "*'*" $str]} {
3711 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3714 proc shellarglist {l} {
3720 append str [shellquote $a]
3725 proc shelldequote {str} {
3730 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3731 append ret [string range $str $used end]
3732 set used [string length $str]
3735 set first [lindex $first 0]
3736 set ch [string index $str $first]
3737 if {$first > $used} {
3738 append ret [string range $str $used [expr {$first - 1}]]
3741 if {$ch eq " " || $ch eq "\t"} break
3744 set first [string first "'" $str $used]
3746 error "unmatched single-quote"
3748 append ret [string range $str $used [expr {$first - 1}]]
3753 if {$used >= [string length $str]} {
3754 error "trailing backslash"
3756 append ret [string index $str $used]
3761 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3762 error "unmatched double-quote"
3764 set first [lindex $first 0]
3765 set ch [string index $str $first]
3766 if {$first > $used} {
3767 append ret [string range $str $used [expr {$first - 1}]]
3770 if {$ch eq "\""} break
3772 append ret [string index $str $used]
3776 return [list $used $ret]
3779 proc shellsplit {str} {
3782 set str [string trimleft $str]
3783 if {$str eq {}} break
3784 set dq [shelldequote $str]
3785 set n [lindex $dq 0]
3786 set word [lindex $dq 1]
3787 set str [string range $str $n end]
3793 # Code to implement multiple views
3795 proc newview {ishighlight} {
3796 global nextviewnum newviewname newishighlight
3797 global revtreeargs viewargscmd newviewopts curview
3799 set newishighlight $ishighlight
3801 if {[winfo exists $top]} {
3805 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3806 set newviewopts($nextviewnum,perm) 0
3807 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3808 decode_view_opts $nextviewnum $revtreeargs
3809 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3812 set known_view_options {
3813 {perm b . {} {mc "Remember this view"}}
3814 {reflabel l + {} {mc "References (space separated list):"}}
3815 {refs t15 .. {} {mc "Branches & tags:"}}
3816 {allrefs b *. "--all" {mc "All refs"}}
3817 {branches b . "--branches" {mc "All (local) branches"}}
3818 {tags b . "--tags" {mc "All tags"}}
3819 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3820 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3821 {author t15 .. "--author=*" {mc "Author:"}}
3822 {committer t15 . "--committer=*" {mc "Committer:"}}
3823 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3824 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3825 {changes_l l + {} {mc "Changes to Files:"}}
3826 {pickaxe_s r0 . {} {mc "Fixed String"}}
3827 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3828 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3829 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3830 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3831 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3832 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3833 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3834 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3835 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3836 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3837 {lright b . "--left-right" {mc "Mark branch sides"}}
3838 {first b . "--first-parent" {mc "Limit to first parent"}}
3839 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3840 {args t50 *. {} {mc "Additional arguments to git log:"}}
3841 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3842 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3845 proc encode_view_opts {n} {
3846 global known_view_options newviewopts
3849 foreach opt $known_view_options {
3850 set patterns [lindex $opt 3]
3851 if {$patterns eq {}} continue
3852 set pattern [lindex $patterns 0]
3854 if {[lindex $opt 1] eq "b"} {
3855 set val $newviewopts($n,[lindex $opt 0])
3857 lappend rargs $pattern
3859 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3860 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3861 set val $newviewopts($n,$button_id)
3862 if {$val eq $value} {
3863 lappend rargs $pattern
3866 set val $newviewopts($n,[lindex $opt 0])
3867 set val [string trim $val]
3869 set pfix [string range $pattern 0 end-1]
3870 lappend rargs $pfix$val
3874 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3875 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3878 proc decode_view_opts {n view_args} {
3879 global known_view_options newviewopts
3881 foreach opt $known_view_options {
3882 set id [lindex $opt 0]
3883 if {[lindex $opt 1] eq "b"} {
3886 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3888 regexp {^(.*_)} $id uselessvar id
3894 set newviewopts($n,$id) $val
3898 foreach arg $view_args {
3899 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3900 && ![info exists found(limit)]} {
3901 set newviewopts($n,limit) $cnt
3906 foreach opt $known_view_options {
3907 set id [lindex $opt 0]
3908 if {[info exists found($id)]} continue
3909 foreach pattern [lindex $opt 3] {
3910 if {![string match $pattern $arg]} continue
3911 if {[lindex $opt 1] eq "b"} {
3914 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3916 regexp {^(.*_)} $id uselessvar id
3920 set size [string length $pattern]
3921 set val [string range $arg [expr {$size-1}] end]
3923 set newviewopts($n,$id) $val
3927 if {[info exists val]} break
3929 if {[info exists val]} continue
3930 if {[regexp {^-} $arg]} {
3933 lappend refargs $arg
3936 set newviewopts($n,refs) [shellarglist $refargs]
3937 set newviewopts($n,args) [shellarglist $oargs]
3940 proc edit_or_newview {} {
3952 global viewname viewperm newviewname newviewopts
3953 global viewargs viewargscmd
3955 set top .gitkvedit-$curview
3956 if {[winfo exists $top]} {
3960 set newviewname($curview) $viewname($curview)
3961 set newviewopts($curview,perm) $viewperm($curview)
3962 set newviewopts($curview,cmd) $viewargscmd($curview)
3963 decode_view_opts $curview $viewargs($curview)
3964 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3967 proc vieweditor {top n title} {
3968 global newviewname newviewopts viewfiles bgcolor
3969 global known_view_options NS
3972 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3973 make_transient $top .
3976 ${NS}::frame $top.nfr
3977 ${NS}::label $top.nl -text [mc "View Name"]
3978 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
3979 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3980 pack $top.nl -in $top.nfr -side left -padx {0 5}
3981 pack $top.name -in $top.nfr -side left -padx {0 25}
3987 foreach opt $known_view_options {
3988 set id [lindex $opt 0]
3989 set type [lindex $opt 1]
3990 set flags [lindex $opt 2]
3991 set title [eval [lindex $opt 4]]
3994 if {$flags eq "+" || $flags eq "*"} {
3995 set cframe $top.fr$cnt
3997 ${NS}::frame $cframe
3998 pack $cframe -in $top -fill x -pady 3 -padx 3
3999 set cexpand [expr {$flags eq "*"}]
4000 } elseif {$flags eq ".." || $flags eq "*."} {
4001 set cframe $top.fr$cnt
4003 ${NS}::frame $cframe
4004 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4005 set cexpand [expr {$flags eq "*."}]
4011 ${NS}::label $cframe.l_$id -text $title
4012 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4013 } elseif {$type eq "b"} {
4014 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4015 pack $cframe.c_$id -in $cframe -side left \
4016 -padx [list $lxpad 0] -expand $cexpand -anchor w
4017 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4018 regexp {^(.*_)} $id uselessvar button_id
4019 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4020 pack $cframe.c_$id -in $cframe -side left \
4021 -padx [list $lxpad 0] -expand $cexpand -anchor w
4022 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4023 ${NS}::label $cframe.l_$id -text $title
4024 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4025 -textvariable newviewopts($n,$id)
4026 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4027 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4028 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4029 ${NS}::label $cframe.l_$id -text $title
4030 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4031 -textvariable newviewopts($n,$id)
4032 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4033 pack $cframe.e_$id -in $cframe -side top -fill x
4034 } elseif {$type eq "path"} {
4035 ${NS}::label $top.l -text $title
4036 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4037 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
4038 if {[info exists viewfiles($n)]} {
4039 foreach f $viewfiles($n) {
4040 $top.t insert end $f
4041 $top.t insert end "\n"
4043 $top.t delete {end - 1c} end
4044 $top.t mark set insert 0.0
4046 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4050 ${NS}::frame $top.buts
4051 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4052 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4053 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4054 bind $top <Control-Return> [list newviewok $top $n]
4055 bind $top <F5> [list newviewok $top $n 1]
4056 bind $top <Escape> [list destroy $top]
4057 grid $top.buts.ok $top.buts.apply $top.buts.can
4058 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4059 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4060 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4061 pack $top.buts -in $top -side top -fill x
4065 proc doviewmenu {m first cmd op argv} {
4066 set nmenu [$m index end]
4067 for {set i $first} {$i <= $nmenu} {incr i} {
4068 if {[$m entrycget $i -command] eq $cmd} {
4069 eval $m $op $i $argv
4075 proc allviewmenus {n op args} {
4078 doviewmenu .bar.view 5 [list showview $n] $op $args
4079 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4082 proc newviewok {top n {apply 0}} {
4083 global nextviewnum newviewperm newviewname newishighlight
4084 global viewname viewfiles viewperm selectedview curview
4085 global viewargs viewargscmd newviewopts viewhlmenu
4088 set newargs [encode_view_opts $n]
4090 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4094 foreach f [split [$top.t get 0.0 end] "\n"] {
4095 set ft [string trim $f]
4100 if {![info exists viewfiles($n)]} {
4101 # creating a new view
4103 set viewname($n) $newviewname($n)
4104 set viewperm($n) $newviewopts($n,perm)
4105 set viewfiles($n) $files
4106 set viewargs($n) $newargs
4107 set viewargscmd($n) $newviewopts($n,cmd)
4109 if {!$newishighlight} {
4112 run addvhighlight $n
4115 # editing an existing view
4116 set viewperm($n) $newviewopts($n,perm)
4117 if {$newviewname($n) ne $viewname($n)} {
4118 set viewname($n) $newviewname($n)
4119 doviewmenu .bar.view 5 [list showview $n] \
4120 entryconf [list -label $viewname($n)]
4121 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4122 # entryconf [list -label $viewname($n) -value $viewname($n)]
4124 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4125 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4126 set viewfiles($n) $files
4127 set viewargs($n) $newargs
4128 set viewargscmd($n) $newviewopts($n,cmd)
4129 if {$curview == $n} {
4135 catch {destroy $top}
4139 global curview viewperm hlview selectedhlview
4141 if {$curview == 0} return
4142 if {[info exists hlview] && $hlview == $curview} {
4143 set selectedhlview [mc "None"]
4146 allviewmenus $curview delete
4147 set viewperm($curview) 0
4151 proc addviewmenu {n} {
4152 global viewname viewhlmenu
4154 .bar.view add radiobutton -label $viewname($n) \
4155 -command [list showview $n] -variable selectedview -value $n
4156 #$viewhlmenu add radiobutton -label $viewname($n) \
4157 # -command [list addvhighlight $n] -variable selectedhlview
4161 global curview cached_commitrow ordertok
4162 global displayorder parentlist rowidlist rowisopt rowfinal
4163 global colormap rowtextx nextcolor canvxmax
4164 global numcommits viewcomplete
4165 global selectedline currentid canv canvy0
4167 global pending_select mainheadid
4170 global hlview selectedhlview commitinterest
4172 if {$n == $curview} return
4174 set ymax [lindex [$canv cget -scrollregion] 3]
4175 set span [$canv yview]
4176 set ytop [expr {[lindex $span 0] * $ymax}]
4177 set ybot [expr {[lindex $span 1] * $ymax}]
4178 set yscreen [expr {($ybot - $ytop) / 2}]
4179 if {$selectedline ne {}} {
4180 set selid $currentid
4181 set y [yc $selectedline]
4182 if {$ytop < $y && $y < $ybot} {
4183 set yscreen [expr {$y - $ytop}]
4185 } elseif {[info exists pending_select]} {
4186 set selid $pending_select
4187 unset pending_select
4191 catch {unset treediffs}
4193 if {[info exists hlview] && $hlview == $n} {
4195 set selectedhlview [mc "None"]
4197 catch {unset commitinterest}
4198 catch {unset cached_commitrow}
4199 catch {unset ordertok}
4203 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4204 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4207 if {![info exists viewcomplete($n)]} {
4217 set numcommits $commitidx($n)
4219 catch {unset colormap}
4220 catch {unset rowtextx}
4222 set canvxmax [$canv cget -width]
4228 if {$selid ne {} && [commitinview $selid $n]} {
4229 set row [rowofcommit $selid]
4230 # try to get the selected row in the same position on the screen
4231 set ymax [lindex [$canv cget -scrollregion] 3]
4232 set ytop [expr {[yc $row] - $yscreen}]
4236 set yf [expr {$ytop * 1.0 / $ymax}]
4238 allcanvs yview moveto $yf
4242 } elseif {!$viewcomplete($n)} {
4243 reset_pending_select $selid
4245 reset_pending_select {}
4247 if {[commitinview $pending_select $curview]} {
4248 selectline [rowofcommit $pending_select] 1
4250 set row [first_real_row]
4251 if {$row < $numcommits} {
4256 if {!$viewcomplete($n)} {
4257 if {$numcommits == 0} {
4258 show_status [mc "Reading commits..."]
4260 } elseif {$numcommits == 0} {
4261 show_status [mc "No commits selected"]
4265 # Stuff relating to the highlighting facility
4267 proc ishighlighted {id} {
4268 global vhighlights fhighlights nhighlights rhighlights
4270 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4271 return $nhighlights($id)
4273 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4274 return $vhighlights($id)
4276 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4277 return $fhighlights($id)
4279 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4280 return $rhighlights($id)
4285 proc bolden {id font} {
4286 global canv linehtag currentid boldids need_redisplay markedid
4288 # need_redisplay = 1 means the display is stale and about to be redrawn
4289 if {$need_redisplay} return
4291 $canv itemconf $linehtag($id) -font $font
4292 if {[info exists currentid] && $id eq $currentid} {
4294 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4295 -outline {{}} -tags secsel \
4296 -fill [$canv cget -selectbackground]]
4299 if {[info exists markedid] && $id eq $markedid} {
4304 proc bolden_name {id font} {
4305 global canv2 linentag currentid boldnameids need_redisplay
4307 if {$need_redisplay} return
4308 lappend boldnameids $id
4309 $canv2 itemconf $linentag($id) -font $font
4310 if {[info exists currentid] && $id eq $currentid} {
4311 $canv2 delete secsel
4312 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4313 -outline {{}} -tags secsel \
4314 -fill [$canv2 cget -selectbackground]]
4323 foreach id $boldids {
4324 if {![ishighlighted $id]} {
4327 lappend stillbold $id
4330 set boldids $stillbold
4333 proc addvhighlight {n} {
4334 global hlview viewcomplete curview vhl_done commitidx
4336 if {[info exists hlview]} {
4340 if {$n != $curview && ![info exists viewcomplete($n)]} {
4343 set vhl_done $commitidx($hlview)
4344 if {$vhl_done > 0} {
4349 proc delvhighlight {} {
4350 global hlview vhighlights
4352 if {![info exists hlview]} return
4354 catch {unset vhighlights}
4358 proc vhighlightmore {} {
4359 global hlview vhl_done commitidx vhighlights curview
4361 set max $commitidx($hlview)
4362 set vr [visiblerows]
4363 set r0 [lindex $vr 0]
4364 set r1 [lindex $vr 1]
4365 for {set i $vhl_done} {$i < $max} {incr i} {
4366 set id [commitonrow $i $hlview]
4367 if {[commitinview $id $curview]} {
4368 set row [rowofcommit $id]
4369 if {$r0 <= $row && $row <= $r1} {
4370 if {![highlighted $row]} {
4371 bolden $id mainfontbold
4373 set vhighlights($id) 1
4381 proc askvhighlight {row id} {
4382 global hlview vhighlights iddrawn
4384 if {[commitinview $id $hlview]} {
4385 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4386 bolden $id mainfontbold
4388 set vhighlights($id) 1
4390 set vhighlights($id) 0
4394 proc hfiles_change {} {
4395 global highlight_files filehighlight fhighlights fh_serial
4396 global highlight_paths
4398 if {[info exists filehighlight]} {
4399 # delete previous highlights
4400 catch {close $filehighlight}
4402 catch {unset fhighlights}
4404 unhighlight_filelist
4406 set highlight_paths {}
4407 after cancel do_file_hl $fh_serial
4409 if {$highlight_files ne {}} {
4410 after 300 do_file_hl $fh_serial
4414 proc gdttype_change {name ix op} {
4415 global gdttype highlight_files findstring findpattern
4418 if {$findstring ne {}} {
4419 if {$gdttype eq [mc "containing:"]} {
4420 if {$highlight_files ne {}} {
4421 set highlight_files {}
4426 if {$findpattern ne {}} {
4430 set highlight_files $findstring
4435 # enable/disable findtype/findloc menus too
4438 proc find_change {name ix op} {
4439 global gdttype findstring highlight_files
4442 if {$gdttype eq [mc "containing:"]} {
4445 if {$highlight_files ne $findstring} {
4446 set highlight_files $findstring
4453 proc findcom_change args {
4454 global nhighlights boldnameids
4455 global findpattern findtype findstring gdttype
4458 # delete previous highlights, if any
4459 foreach id $boldnameids {
4460 bolden_name $id mainfont
4463 catch {unset nhighlights}
4466 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4468 } elseif {$findtype eq [mc "Regexp"]} {
4469 set findpattern $findstring
4471 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4473 set findpattern "*$e*"
4477 proc makepatterns {l} {
4480 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4481 if {[string index $ee end] eq "/"} {
4491 proc do_file_hl {serial} {
4492 global highlight_files filehighlight highlight_paths gdttype fhl_list
4494 if {$gdttype eq [mc "touching paths:"]} {
4495 if {[catch {set paths [shellsplit $highlight_files]}]} return
4496 set highlight_paths [makepatterns $paths]
4498 set gdtargs [concat -- $paths]
4499 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4500 set gdtargs [list "-S$highlight_files"]
4502 # must be "containing:", i.e. we're searching commit info
4505 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4506 set filehighlight [open $cmd r+]
4507 fconfigure $filehighlight -blocking 0
4508 filerun $filehighlight readfhighlight
4514 proc flushhighlights {} {
4515 global filehighlight fhl_list
4517 if {[info exists filehighlight]} {
4519 puts $filehighlight ""
4520 flush $filehighlight
4524 proc askfilehighlight {row id} {
4525 global filehighlight fhighlights fhl_list
4527 lappend fhl_list $id
4528 set fhighlights($id) -1
4529 puts $filehighlight $id
4532 proc readfhighlight {} {
4533 global filehighlight fhighlights curview iddrawn
4534 global fhl_list find_dirn
4536 if {![info exists filehighlight]} {
4540 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4541 set line [string trim $line]
4542 set i [lsearch -exact $fhl_list $line]
4543 if {$i < 0} continue
4544 for {set j 0} {$j < $i} {incr j} {
4545 set id [lindex $fhl_list $j]
4546 set fhighlights($id) 0
4548 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4549 if {$line eq {}} continue
4550 if {![commitinview $line $curview]} continue
4551 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4552 bolden $line mainfontbold
4554 set fhighlights($line) 1
4556 if {[eof $filehighlight]} {
4558 puts "oops, git diff-tree died"
4559 catch {close $filehighlight}
4563 if {[info exists find_dirn]} {
4569 proc doesmatch {f} {
4570 global findtype findpattern
4572 if {$findtype eq [mc "Regexp"]} {
4573 return [regexp $findpattern $f]
4574 } elseif {$findtype eq [mc "IgnCase"]} {
4575 return [string match -nocase $findpattern $f]
4577 return [string match $findpattern $f]
4581 proc askfindhighlight {row id} {
4582 global nhighlights commitinfo iddrawn
4584 global markingmatches
4586 if {![info exists commitinfo($id)]} {
4589 set info $commitinfo($id)
4591 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4592 foreach f $info ty $fldtypes {
4593 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4595 if {$ty eq [mc "Author"]} {
4602 if {$isbold && [info exists iddrawn($id)]} {
4603 if {![ishighlighted $id]} {
4604 bolden $id mainfontbold
4606 bolden_name $id mainfontbold
4609 if {$markingmatches} {
4610 markrowmatches $row $id
4613 set nhighlights($id) $isbold
4616 proc markrowmatches {row id} {
4617 global canv canv2 linehtag linentag commitinfo findloc
4619 set headline [lindex $commitinfo($id) 0]
4620 set author [lindex $commitinfo($id) 1]
4621 $canv delete match$row
4622 $canv2 delete match$row
4623 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4624 set m [findmatches $headline]
4626 markmatches $canv $row $headline $linehtag($id) $m \
4627 [$canv itemcget $linehtag($id) -font] $row
4630 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4631 set m [findmatches $author]
4633 markmatches $canv2 $row $author $linentag($id) $m \
4634 [$canv2 itemcget $linentag($id) -font] $row
4639 proc vrel_change {name ix op} {
4640 global highlight_related
4643 if {$highlight_related ne [mc "None"]} {
4648 # prepare for testing whether commits are descendents or ancestors of a
4649 proc rhighlight_sel {a} {
4650 global descendent desc_todo ancestor anc_todo
4651 global highlight_related
4653 catch {unset descendent}
4654 set desc_todo [list $a]
4655 catch {unset ancestor}
4656 set anc_todo [list $a]
4657 if {$highlight_related ne [mc "None"]} {
4663 proc rhighlight_none {} {
4666 catch {unset rhighlights}
4670 proc is_descendent {a} {
4671 global curview children descendent desc_todo
4674 set la [rowofcommit $a]
4678 for {set i 0} {$i < [llength $todo]} {incr i} {
4679 set do [lindex $todo $i]
4680 if {[rowofcommit $do] < $la} {
4681 lappend leftover $do
4684 foreach nk $children($v,$do) {
4685 if {![info exists descendent($nk)]} {
4686 set descendent($nk) 1
4694 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4698 set descendent($a) 0
4699 set desc_todo $leftover
4702 proc is_ancestor {a} {
4703 global curview parents ancestor anc_todo
4706 set la [rowofcommit $a]
4710 for {set i 0} {$i < [llength $todo]} {incr i} {
4711 set do [lindex $todo $i]
4712 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4713 lappend leftover $do
4716 foreach np $parents($v,$do) {
4717 if {![info exists ancestor($np)]} {
4726 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4731 set anc_todo $leftover
4734 proc askrelhighlight {row id} {
4735 global descendent highlight_related iddrawn rhighlights
4736 global selectedline ancestor
4738 if {$selectedline eq {}} return
4740 if {$highlight_related eq [mc "Descendant"] ||
4741 $highlight_related eq [mc "Not descendant"]} {
4742 if {![info exists descendent($id)]} {
4745 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4748 } elseif {$highlight_related eq [mc "Ancestor"] ||
4749 $highlight_related eq [mc "Not ancestor"]} {
4750 if {![info exists ancestor($id)]} {
4753 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4757 if {[info exists iddrawn($id)]} {
4758 if {$isbold && ![ishighlighted $id]} {
4759 bolden $id mainfontbold
4762 set rhighlights($id) $isbold
4765 # Graph layout functions
4767 proc shortids {ids} {
4770 if {[llength $id] > 1} {
4771 lappend res [shortids $id]
4772 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4773 lappend res [string range $id 0 7]
4784 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4785 if {($n & $mask) != 0} {
4786 set ret [concat $ret $o]
4788 set o [concat $o $o]
4793 proc ordertoken {id} {
4794 global ordertok curview varcid varcstart varctok curview parents children
4795 global nullid nullid2
4797 if {[info exists ordertok($id)]} {
4798 return $ordertok($id)
4803 if {[info exists varcid($curview,$id)]} {
4804 set a $varcid($curview,$id)
4805 set p [lindex $varcstart($curview) $a]
4807 set p [lindex $children($curview,$id) 0]
4809 if {[info exists ordertok($p)]} {
4810 set tok $ordertok($p)
4813 set id [first_real_child $curview,$p]
4816 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4819 if {[llength $parents($curview,$id)] == 1} {
4820 lappend todo [list $p {}]
4822 set j [lsearch -exact $parents($curview,$id) $p]
4824 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4826 lappend todo [list $p [strrep $j]]
4829 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4830 set p [lindex $todo $i 0]
4831 append tok [lindex $todo $i 1]
4832 set ordertok($p) $tok
4834 set ordertok($origid) $tok
4838 # Work out where id should go in idlist so that order-token
4839 # values increase from left to right
4840 proc idcol {idlist id {i 0}} {
4841 set t [ordertoken $id]
4845 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4846 if {$i > [llength $idlist]} {
4847 set i [llength $idlist]
4849 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4852 if {$t > [ordertoken [lindex $idlist $i]]} {
4853 while {[incr i] < [llength $idlist] &&
4854 $t >= [ordertoken [lindex $idlist $i]]} {}
4860 proc initlayout {} {
4861 global rowidlist rowisopt rowfinal displayorder parentlist
4862 global numcommits canvxmax canv
4864 global colormap rowtextx
4873 set canvxmax [$canv cget -width]
4874 catch {unset colormap}
4875 catch {unset rowtextx}
4879 proc setcanvscroll {} {
4880 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4881 global lastscrollset lastscrollrows
4883 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4884 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4885 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4886 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4887 set lastscrollset [clock clicks -milliseconds]
4888 set lastscrollrows $numcommits
4891 proc visiblerows {} {
4892 global canv numcommits linespc
4894 set ymax [lindex [$canv cget -scrollregion] 3]
4895 if {$ymax eq {} || $ymax == 0} return
4897 set y0 [expr {int([lindex $f 0] * $ymax)}]
4898 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4902 set y1 [expr {int([lindex $f 1] * $ymax)}]
4903 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4904 if {$r1 >= $numcommits} {
4905 set r1 [expr {$numcommits - 1}]
4907 return [list $r0 $r1]
4910 proc layoutmore {} {
4911 global commitidx viewcomplete curview
4912 global numcommits pending_select curview
4913 global lastscrollset lastscrollrows
4915 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4916 [clock clicks -milliseconds] - $lastscrollset > 500} {
4919 if {[info exists pending_select] &&
4920 [commitinview $pending_select $curview]} {
4922 selectline [rowofcommit $pending_select] 1
4927 # With path limiting, we mightn't get the actual HEAD commit,
4928 # so ask git rev-list what is the first ancestor of HEAD that
4929 # touches a file in the path limit.
4930 proc get_viewmainhead {view} {
4931 global viewmainheadid vfilelimit viewinstances mainheadid
4934 set rfd [open [concat | git rev-list -1 $mainheadid \
4935 -- $vfilelimit($view)] r]
4936 set j [reg_instance $rfd]
4937 lappend viewinstances($view) $j
4938 fconfigure $rfd -blocking 0
4939 filerun $rfd [list getviewhead $rfd $j $view]
4940 set viewmainheadid($curview) {}
4944 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4945 proc getviewhead {fd inst view} {
4946 global viewmainheadid commfd curview viewinstances showlocalchanges
4949 if {[gets $fd line] < 0} {
4953 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4956 set viewmainheadid($view) $id
4959 set i [lsearch -exact $viewinstances($view) $inst]
4961 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4963 if {$showlocalchanges && $id ne {} && $view == $curview} {
4969 proc doshowlocalchanges {} {
4970 global curview viewmainheadid
4972 if {$viewmainheadid($curview) eq {}} return
4973 if {[commitinview $viewmainheadid($curview) $curview]} {
4976 interestedin $viewmainheadid($curview) dodiffindex
4980 proc dohidelocalchanges {} {
4981 global nullid nullid2 lserial curview
4983 if {[commitinview $nullid $curview]} {
4984 removefakerow $nullid
4986 if {[commitinview $nullid2 $curview]} {
4987 removefakerow $nullid2
4992 # spawn off a process to do git diff-index --cached HEAD
4993 proc dodiffindex {} {
4994 global lserial showlocalchanges vfilelimit curview
4997 if {!$showlocalchanges || !$isworktree} return
4999 set cmd "|git diff-index --cached HEAD"
5000 if {$vfilelimit($curview) ne {}} {
5001 set cmd [concat $cmd -- $vfilelimit($curview)]
5003 set fd [open $cmd r]
5004 fconfigure $fd -blocking 0
5005 set i [reg_instance $fd]
5006 filerun $fd [list readdiffindex $fd $lserial $i]
5009 proc readdiffindex {fd serial inst} {
5010 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5014 if {[gets $fd line] < 0} {
5020 # we only need to see one line and we don't really care what it says...
5023 if {$serial != $lserial} {
5027 # now see if there are any local changes not checked in to the index
5028 set cmd "|git diff-files"
5029 if {$vfilelimit($curview) ne {}} {
5030 set cmd [concat $cmd -- $vfilelimit($curview)]
5032 set fd [open $cmd r]
5033 fconfigure $fd -blocking 0
5034 set i [reg_instance $fd]
5035 filerun $fd [list readdifffiles $fd $serial $i]
5037 if {$isdiff && ![commitinview $nullid2 $curview]} {
5038 # add the line for the changes in the index to the graph
5039 set hl [mc "Local changes checked in to index but not committed"]
5040 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5041 set commitdata($nullid2) "\n $hl\n"
5042 if {[commitinview $nullid $curview]} {
5043 removefakerow $nullid
5045 insertfakerow $nullid2 $viewmainheadid($curview)
5046 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5047 if {[commitinview $nullid $curview]} {
5048 removefakerow $nullid
5050 removefakerow $nullid2
5055 proc readdifffiles {fd serial inst} {
5056 global viewmainheadid nullid nullid2 curview
5057 global commitinfo commitdata lserial
5060 if {[gets $fd line] < 0} {
5066 # we only need to see one line and we don't really care what it says...
5069 if {$serial != $lserial} {
5073 if {$isdiff && ![commitinview $nullid $curview]} {
5074 # add the line for the local diff to the graph
5075 set hl [mc "Local uncommitted changes, not checked in to index"]
5076 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5077 set commitdata($nullid) "\n $hl\n"
5078 if {[commitinview $nullid2 $curview]} {
5081 set p $viewmainheadid($curview)
5083 insertfakerow $nullid $p
5084 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5085 removefakerow $nullid
5090 proc nextuse {id row} {
5091 global curview children
5093 if {[info exists children($curview,$id)]} {
5094 foreach kid $children($curview,$id) {
5095 if {![commitinview $kid $curview]} {
5098 if {[rowofcommit $kid] > $row} {
5099 return [rowofcommit $kid]
5103 if {[commitinview $id $curview]} {
5104 return [rowofcommit $id]
5109 proc prevuse {id row} {
5110 global curview children
5113 if {[info exists children($curview,$id)]} {
5114 foreach kid $children($curview,$id) {
5115 if {![commitinview $kid $curview]} break
5116 if {[rowofcommit $kid] < $row} {
5117 set ret [rowofcommit $kid]
5124 proc make_idlist {row} {
5125 global displayorder parentlist uparrowlen downarrowlen mingaplen
5126 global commitidx curview children
5128 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5132 set ra [expr {$row - $downarrowlen}]
5136 set rb [expr {$row + $uparrowlen}]
5137 if {$rb > $commitidx($curview)} {
5138 set rb $commitidx($curview)
5140 make_disporder $r [expr {$rb + 1}]
5142 for {} {$r < $ra} {incr r} {
5143 set nextid [lindex $displayorder [expr {$r + 1}]]
5144 foreach p [lindex $parentlist $r] {
5145 if {$p eq $nextid} continue
5146 set rn [nextuse $p $r]
5148 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5149 lappend ids [list [ordertoken $p] $p]
5153 for {} {$r < $row} {incr r} {
5154 set nextid [lindex $displayorder [expr {$r + 1}]]
5155 foreach p [lindex $parentlist $r] {
5156 if {$p eq $nextid} continue
5157 set rn [nextuse $p $r]
5158 if {$rn < 0 || $rn >= $row} {
5159 lappend ids [list [ordertoken $p] $p]
5163 set id [lindex $displayorder $row]
5164 lappend ids [list [ordertoken $id] $id]
5166 foreach p [lindex $parentlist $r] {
5167 set firstkid [lindex $children($curview,$p) 0]
5168 if {[rowofcommit $firstkid] < $row} {
5169 lappend ids [list [ordertoken $p] $p]
5173 set id [lindex $displayorder $r]
5175 set firstkid [lindex $children($curview,$id) 0]
5176 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5177 lappend ids [list [ordertoken $id] $id]
5182 foreach idx [lsort -unique $ids] {
5183 lappend idlist [lindex $idx 1]
5188 proc rowsequal {a b} {
5189 while {[set i [lsearch -exact $a {}]] >= 0} {
5190 set a [lreplace $a $i $i]
5192 while {[set i [lsearch -exact $b {}]] >= 0} {
5193 set b [lreplace $b $i $i]
5195 return [expr {$a eq $b}]
5198 proc makeupline {id row rend col} {
5199 global rowidlist uparrowlen downarrowlen mingaplen
5201 for {set r $rend} {1} {set r $rstart} {
5202 set rstart [prevuse $id $r]
5203 if {$rstart < 0} return
5204 if {$rstart < $row} break
5206 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5207 set rstart [expr {$rend - $uparrowlen - 1}]
5209 for {set r $rstart} {[incr r] <= $row} {} {
5210 set idlist [lindex $rowidlist $r]
5211 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5212 set col [idcol $idlist $id $col]
5213 lset rowidlist $r [linsert $idlist $col $id]
5219 proc layoutrows {row endrow} {
5220 global rowidlist rowisopt rowfinal displayorder
5221 global uparrowlen downarrowlen maxwidth mingaplen
5222 global children parentlist
5223 global commitidx viewcomplete curview
5225 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5228 set rm1 [expr {$row - 1}]
5229 foreach id [lindex $rowidlist $rm1] {
5234 set final [lindex $rowfinal $rm1]
5236 for {} {$row < $endrow} {incr row} {
5237 set rm1 [expr {$row - 1}]
5238 if {$rm1 < 0 || $idlist eq {}} {
5239 set idlist [make_idlist $row]
5242 set id [lindex $displayorder $rm1]
5243 set col [lsearch -exact $idlist $id]
5244 set idlist [lreplace $idlist $col $col]
5245 foreach p [lindex $parentlist $rm1] {
5246 if {[lsearch -exact $idlist $p] < 0} {
5247 set col [idcol $idlist $p $col]
5248 set idlist [linsert $idlist $col $p]
5249 # if not the first child, we have to insert a line going up
5250 if {$id ne [lindex $children($curview,$p) 0]} {
5251 makeupline $p $rm1 $row $col
5255 set id [lindex $displayorder $row]
5256 if {$row > $downarrowlen} {
5257 set termrow [expr {$row - $downarrowlen - 1}]
5258 foreach p [lindex $parentlist $termrow] {
5259 set i [lsearch -exact $idlist $p]
5260 if {$i < 0} continue
5261 set nr [nextuse $p $termrow]
5262 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5263 set idlist [lreplace $idlist $i $i]
5267 set col [lsearch -exact $idlist $id]
5269 set col [idcol $idlist $id]
5270 set idlist [linsert $idlist $col $id]
5271 if {$children($curview,$id) ne {}} {
5272 makeupline $id $rm1 $row $col
5275 set r [expr {$row + $uparrowlen - 1}]
5276 if {$r < $commitidx($curview)} {
5278 foreach p [lindex $parentlist $r] {
5279 if {[lsearch -exact $idlist $p] >= 0} continue
5280 set fk [lindex $children($curview,$p) 0]
5281 if {[rowofcommit $fk] < $row} {
5282 set x [idcol $idlist $p $x]
5283 set idlist [linsert $idlist $x $p]
5286 if {[incr r] < $commitidx($curview)} {
5287 set p [lindex $displayorder $r]
5288 if {[lsearch -exact $idlist $p] < 0} {
5289 set fk [lindex $children($curview,$p) 0]
5290 if {$fk ne {} && [rowofcommit $fk] < $row} {
5291 set x [idcol $idlist $p $x]
5292 set idlist [linsert $idlist $x $p]
5298 if {$final && !$viewcomplete($curview) &&
5299 $row + $uparrowlen + $mingaplen + $downarrowlen
5300 >= $commitidx($curview)} {
5303 set l [llength $rowidlist]
5305 lappend rowidlist $idlist
5307 lappend rowfinal $final
5308 } elseif {$row < $l} {
5309 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5310 lset rowidlist $row $idlist
5313 lset rowfinal $row $final
5315 set pad [ntimes [expr {$row - $l}] {}]
5316 set rowidlist [concat $rowidlist $pad]
5317 lappend rowidlist $idlist
5318 set rowfinal [concat $rowfinal $pad]
5319 lappend rowfinal $final
5320 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5326 proc changedrow {row} {
5327 global displayorder iddrawn rowisopt need_redisplay
5329 set l [llength $rowisopt]
5331 lset rowisopt $row 0
5332 if {$row + 1 < $l} {
5333 lset rowisopt [expr {$row + 1}] 0
5334 if {$row + 2 < $l} {
5335 lset rowisopt [expr {$row + 2}] 0
5339 set id [lindex $displayorder $row]
5340 if {[info exists iddrawn($id)]} {
5341 set need_redisplay 1
5345 proc insert_pad {row col npad} {
5348 set pad [ntimes $npad {}]
5349 set idlist [lindex $rowidlist $row]
5350 set bef [lrange $idlist 0 [expr {$col - 1}]]
5351 set aft [lrange $idlist $col end]
5352 set i [lsearch -exact $aft {}]
5354 set aft [lreplace $aft $i $i]
5356 lset rowidlist $row [concat $bef $pad $aft]
5360 proc optimize_rows {row col endrow} {
5361 global rowidlist rowisopt displayorder curview children
5366 for {} {$row < $endrow} {incr row; set col 0} {
5367 if {[lindex $rowisopt $row]} continue
5369 set y0 [expr {$row - 1}]
5370 set ym [expr {$row - 2}]
5371 set idlist [lindex $rowidlist $row]
5372 set previdlist [lindex $rowidlist $y0]
5373 if {$idlist eq {} || $previdlist eq {}} continue
5375 set pprevidlist [lindex $rowidlist $ym]
5376 if {$pprevidlist eq {}} continue
5382 for {} {$col < [llength $idlist]} {incr col} {
5383 set id [lindex $idlist $col]
5384 if {[lindex $previdlist $col] eq $id} continue
5389 set x0 [lsearch -exact $previdlist $id]
5390 if {$x0 < 0} continue
5391 set z [expr {$x0 - $col}]
5395 set xm [lsearch -exact $pprevidlist $id]
5397 set z0 [expr {$xm - $x0}]
5401 # if row y0 is the first child of $id then it's not an arrow
5402 if {[lindex $children($curview,$id) 0] ne
5403 [lindex $displayorder $y0]} {
5407 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5408 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5411 # Looking at lines from this row to the previous row,
5412 # make them go straight up if they end in an arrow on
5413 # the previous row; otherwise make them go straight up
5415 if {$z < -1 || ($z < 0 && $isarrow)} {
5416 # Line currently goes left too much;
5417 # insert pads in the previous row, then optimize it
5418 set npad [expr {-1 - $z + $isarrow}]
5419 insert_pad $y0 $x0 $npad
5421 optimize_rows $y0 $x0 $row
5423 set previdlist [lindex $rowidlist $y0]
5424 set x0 [lsearch -exact $previdlist $id]
5425 set z [expr {$x0 - $col}]
5427 set pprevidlist [lindex $rowidlist $ym]
5428 set xm [lsearch -exact $pprevidlist $id]
5429 set z0 [expr {$xm - $x0}]
5431 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5432 # Line currently goes right too much;
5433 # insert pads in this line
5434 set npad [expr {$z - 1 + $isarrow}]
5435 insert_pad $row $col $npad
5436 set idlist [lindex $rowidlist $row]
5438 set z [expr {$x0 - $col}]
5441 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5442 # this line links to its first child on row $row-2
5443 set id [lindex $displayorder $ym]
5444 set xc [lsearch -exact $pprevidlist $id]
5446 set z0 [expr {$xc - $x0}]
5449 # avoid lines jigging left then immediately right
5450 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5451 insert_pad $y0 $x0 1
5453 optimize_rows $y0 $x0 $row
5454 set previdlist [lindex $rowidlist $y0]
5458 # Find the first column that doesn't have a line going right
5459 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5460 set id [lindex $idlist $col]
5461 if {$id eq {}} break
5462 set x0 [lsearch -exact $previdlist $id]
5464 # check if this is the link to the first child
5465 set kid [lindex $displayorder $y0]
5466 if {[lindex $children($curview,$id) 0] eq $kid} {
5467 # it is, work out offset to child
5468 set x0 [lsearch -exact $previdlist $kid]
5471 if {$x0 <= $col} break
5473 # Insert a pad at that column as long as it has a line and
5474 # isn't the last column
5475 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5476 set idlist [linsert $idlist $col {}]
5477 lset rowidlist $row $idlist
5485 global canvx0 linespc
5486 return [expr {$canvx0 + $col * $linespc}]
5490 global canvy0 linespc
5491 return [expr {$canvy0 + $row * $linespc}]
5494 proc linewidth {id} {
5495 global thickerline lthickness
5498 if {[info exists thickerline] && $id eq $thickerline} {
5499 set wid [expr {2 * $lthickness}]
5504 proc rowranges {id} {
5505 global curview children uparrowlen downarrowlen
5508 set kids $children($curview,$id)
5514 foreach child $kids {
5515 if {![commitinview $child $curview]} break
5516 set row [rowofcommit $child]
5517 if {![info exists prev]} {
5518 lappend ret [expr {$row + 1}]
5520 if {$row <= $prevrow} {
5521 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5523 # see if the line extends the whole way from prevrow to row
5524 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5525 [lsearch -exact [lindex $rowidlist \
5526 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5527 # it doesn't, see where it ends
5528 set r [expr {$prevrow + $downarrowlen}]
5529 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5530 while {[incr r -1] > $prevrow &&
5531 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5533 while {[incr r] <= $row &&
5534 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5538 # see where it starts up again
5539 set r [expr {$row - $uparrowlen}]
5540 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5541 while {[incr r] < $row &&
5542 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5544 while {[incr r -1] >= $prevrow &&
5545 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5551 if {$child eq $id} {
5560 proc drawlineseg {id row endrow arrowlow} {
5561 global rowidlist displayorder iddrawn linesegs
5562 global canv colormap linespc curview maxlinelen parentlist
5564 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5565 set le [expr {$row + 1}]
5568 set c [lsearch -exact [lindex $rowidlist $le] $id]
5574 set x [lindex $displayorder $le]
5579 if {[info exists iddrawn($x)] || $le == $endrow} {
5580 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5596 if {[info exists linesegs($id)]} {
5597 set lines $linesegs($id)
5599 set r0 [lindex $li 0]
5601 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5611 set li [lindex $lines [expr {$i-1}]]
5612 set r1 [lindex $li 1]
5613 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5618 set x [lindex $cols [expr {$le - $row}]]
5619 set xp [lindex $cols [expr {$le - 1 - $row}]]
5620 set dir [expr {$xp - $x}]
5622 set ith [lindex $lines $i 2]
5623 set coords [$canv coords $ith]
5624 set ah [$canv itemcget $ith -arrow]
5625 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5626 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5627 if {$x2 ne {} && $x - $x2 == $dir} {
5628 set coords [lrange $coords 0 end-2]
5631 set coords [list [xc $le $x] [yc $le]]
5634 set itl [lindex $lines [expr {$i-1}] 2]
5635 set al [$canv itemcget $itl -arrow]
5636 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5637 } elseif {$arrowlow} {
5638 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5639 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5643 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5644 for {set y $le} {[incr y -1] > $row} {} {
5646 set xp [lindex $cols [expr {$y - 1 - $row}]]
5647 set ndir [expr {$xp - $x}]
5648 if {$dir != $ndir || $xp < 0} {
5649 lappend coords [xc $y $x] [yc $y]
5655 # join parent line to first child
5656 set ch [lindex $displayorder $row]
5657 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5659 puts "oops: drawlineseg: child $ch not on row $row"
5660 } elseif {$xc != $x} {
5661 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5662 set d [expr {int(0.5 * $linespc)}]
5665 set x2 [expr {$x1 - $d}]
5667 set x2 [expr {$x1 + $d}]
5670 set y1 [expr {$y2 + $d}]
5671 lappend coords $x1 $y1 $x2 $y2
5672 } elseif {$xc < $x - 1} {
5673 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5674 } elseif {$xc > $x + 1} {
5675 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5679 lappend coords [xc $row $x] [yc $row]
5681 set xn [xc $row $xp]
5683 lappend coords $xn $yn
5687 set t [$canv create line $coords -width [linewidth $id] \
5688 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5691 set lines [linsert $lines $i [list $row $le $t]]
5693 $canv coords $ith $coords
5694 if {$arrow ne $ah} {
5695 $canv itemconf $ith -arrow $arrow
5697 lset lines $i 0 $row
5700 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5701 set ndir [expr {$xo - $xp}]
5702 set clow [$canv coords $itl]
5703 if {$dir == $ndir} {
5704 set clow [lrange $clow 2 end]
5706 set coords [concat $coords $clow]
5708 lset lines [expr {$i-1}] 1 $le
5710 # coalesce two pieces
5712 set b [lindex $lines [expr {$i-1}] 0]
5713 set e [lindex $lines $i 1]
5714 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5716 $canv coords $itl $coords
5717 if {$arrow ne $al} {
5718 $canv itemconf $itl -arrow $arrow
5722 set linesegs($id) $lines
5726 proc drawparentlinks {id row} {
5727 global rowidlist canv colormap curview parentlist
5728 global idpos linespc
5730 set rowids [lindex $rowidlist $row]
5731 set col [lsearch -exact $rowids $id]
5732 if {$col < 0} return
5733 set olds [lindex $parentlist $row]
5734 set row2 [expr {$row + 1}]
5735 set x [xc $row $col]
5738 set d [expr {int(0.5 * $linespc)}]
5739 set ymid [expr {$y + $d}]
5740 set ids [lindex $rowidlist $row2]
5741 # rmx = right-most X coord used
5744 set i [lsearch -exact $ids $p]
5746 puts "oops, parent $p of $id not in list"
5749 set x2 [xc $row2 $i]
5753 set j [lsearch -exact $rowids $p]
5755 # drawlineseg will do this one for us
5759 # should handle duplicated parents here...
5760 set coords [list $x $y]
5762 # if attaching to a vertical segment, draw a smaller
5763 # slant for visual distinctness
5766 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5768 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5770 } elseif {$i < $col && $i < $j} {
5771 # segment slants towards us already
5772 lappend coords [xc $row $j] $y
5774 if {$i < $col - 1} {
5775 lappend coords [expr {$x2 + $linespc}] $y
5776 } elseif {$i > $col + 1} {
5777 lappend coords [expr {$x2 - $linespc}] $y
5779 lappend coords $x2 $y2
5782 lappend coords $x2 $y2
5784 set t [$canv create line $coords -width [linewidth $p] \
5785 -fill $colormap($p) -tags lines.$p]
5789 if {$rmx > [lindex $idpos($id) 1]} {
5790 lset idpos($id) 1 $rmx
5795 proc drawlines {id} {
5798 $canv itemconf lines.$id -width [linewidth $id]
5801 proc drawcmittext {id row col} {
5802 global linespc canv canv2 canv3 fgcolor curview
5803 global cmitlisted commitinfo rowidlist parentlist
5804 global rowtextx idpos idtags idheads idotherrefs
5805 global linehtag linentag linedtag selectedline
5806 global canvxmax boldids boldnameids fgcolor markedid
5807 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5809 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5810 set listed $cmitlisted($curview,$id)
5811 if {$id eq $nullid} {
5813 } elseif {$id eq $nullid2} {
5815 } elseif {$id eq $mainheadid} {
5818 set ofill [lindex $circlecolors $listed]
5820 set x [xc $row $col]
5822 set orad [expr {$linespc / 3}]
5824 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5825 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5826 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5827 } elseif {$listed == 3} {
5828 # triangle pointing left for left-side commits
5829 set t [$canv create polygon \
5830 [expr {$x - $orad}] $y \
5831 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5832 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5833 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5835 # triangle pointing right for right-side commits
5836 set t [$canv create polygon \
5837 [expr {$x + $orad - 1}] $y \
5838 [expr {$x - $orad}] [expr {$y - $orad}] \
5839 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5840 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5842 set circleitem($row) $t
5844 $canv bind $t <1> {selcanvline {} %x %y}
5845 set rmx [llength [lindex $rowidlist $row]]
5846 set olds [lindex $parentlist $row]
5848 set nextids [lindex $rowidlist [expr {$row + 1}]]
5850 set i [lsearch -exact $nextids $p]
5856 set xt [xc $row $rmx]
5857 set rowtextx($row) $xt
5858 set idpos($id) [list $x $xt $y]
5859 if {[info exists idtags($id)] || [info exists idheads($id)]
5860 || [info exists idotherrefs($id)]} {
5861 set xt [drawtags $id $x $xt $y]
5863 set headline [lindex $commitinfo($id) 0]
5864 set name [lindex $commitinfo($id) 1]
5865 set date [lindex $commitinfo($id) 2]
5866 set date [formatdate $date]
5869 set isbold [ishighlighted $id]
5872 set font mainfontbold
5874 lappend boldnameids $id
5875 set nfont mainfontbold
5878 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5879 -text $headline -font $font -tags text]
5880 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5881 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5882 -text $name -font $nfont -tags text]
5883 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5884 -text $date -font mainfont -tags text]
5885 if {$selectedline == $row} {
5888 if {[info exists markedid] && $markedid eq $id} {
5891 set xr [expr {$xt + [font measure $font $headline]}]
5892 if {$xr > $canvxmax} {
5898 proc drawcmitrow {row} {
5899 global displayorder rowidlist nrows_drawn
5900 global iddrawn markingmatches
5901 global commitinfo numcommits
5902 global filehighlight fhighlights findpattern nhighlights
5903 global hlview vhighlights
5904 global highlight_related rhighlights
5906 if {$row >= $numcommits} return
5908 set id [lindex $displayorder $row]
5909 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5910 askvhighlight $row $id
5912 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5913 askfilehighlight $row $id
5915 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5916 askfindhighlight $row $id
5918 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5919 askrelhighlight $row $id
5921 if {![info exists iddrawn($id)]} {
5922 set col [lsearch -exact [lindex $rowidlist $row] $id]
5924 puts "oops, row $row id $id not in list"
5927 if {![info exists commitinfo($id)]} {
5931 drawcmittext $id $row $col
5935 if {$markingmatches} {
5936 markrowmatches $row $id
5940 proc drawcommits {row {endrow {}}} {
5941 global numcommits iddrawn displayorder curview need_redisplay
5942 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5947 if {$endrow eq {}} {
5950 if {$endrow >= $numcommits} {
5951 set endrow [expr {$numcommits - 1}]
5954 set rl1 [expr {$row - $downarrowlen - 3}]
5958 set ro1 [expr {$row - 3}]
5962 set r2 [expr {$endrow + $uparrowlen + 3}]
5963 if {$r2 > $numcommits} {
5966 for {set r $rl1} {$r < $r2} {incr r} {
5967 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5971 set rl1 [expr {$r + 1}]
5977 optimize_rows $ro1 0 $r2
5978 if {$need_redisplay || $nrows_drawn > 2000} {
5982 # make the lines join to already-drawn rows either side
5983 set r [expr {$row - 1}]
5984 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5987 set er [expr {$endrow + 1}]
5988 if {$er >= $numcommits ||
5989 ![info exists iddrawn([lindex $displayorder $er])]} {
5992 for {} {$r <= $er} {incr r} {
5993 set id [lindex $displayorder $r]
5994 set wasdrawn [info exists iddrawn($id)]
5996 if {$r == $er} break
5997 set nextid [lindex $displayorder [expr {$r + 1}]]
5998 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5999 drawparentlinks $id $r
6001 set rowids [lindex $rowidlist $r]
6002 foreach lid $rowids {
6003 if {$lid eq {}} continue
6004 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6006 # see if this is the first child of any of its parents
6007 foreach p [lindex $parentlist $r] {
6008 if {[lsearch -exact $rowids $p] < 0} {
6009 # make this line extend up to the child
6010 set lineend($p) [drawlineseg $p $r $er 0]
6014 set lineend($lid) [drawlineseg $lid $r $er 1]
6020 proc undolayout {row} {
6021 global uparrowlen mingaplen downarrowlen
6022 global rowidlist rowisopt rowfinal need_redisplay
6024 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6028 if {[llength $rowidlist] > $r} {
6030 set rowidlist [lrange $rowidlist 0 $r]
6031 set rowfinal [lrange $rowfinal 0 $r]
6032 set rowisopt [lrange $rowisopt 0 $r]
6033 set need_redisplay 1
6038 proc drawvisible {} {
6039 global canv linespc curview vrowmod selectedline targetrow targetid
6040 global need_redisplay cscroll numcommits
6042 set fs [$canv yview]
6043 set ymax [lindex [$canv cget -scrollregion] 3]
6044 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6045 set f0 [lindex $fs 0]
6046 set f1 [lindex $fs 1]
6047 set y0 [expr {int($f0 * $ymax)}]
6048 set y1 [expr {int($f1 * $ymax)}]
6050 if {[info exists targetid]} {
6051 if {[commitinview $targetid $curview]} {
6052 set r [rowofcommit $targetid]
6053 if {$r != $targetrow} {
6054 # Fix up the scrollregion and change the scrolling position
6055 # now that our target row has moved.
6056 set diff [expr {($r - $targetrow) * $linespc}]
6059 set ymax [lindex [$canv cget -scrollregion] 3]
6062 set f0 [expr {$y0 / $ymax}]
6063 set f1 [expr {$y1 / $ymax}]
6064 allcanvs yview moveto $f0
6065 $cscroll set $f0 $f1
6066 set need_redisplay 1
6073 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6074 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6075 if {$endrow >= $vrowmod($curview)} {
6076 update_arcrows $curview
6078 if {$selectedline ne {} &&
6079 $row <= $selectedline && $selectedline <= $endrow} {
6080 set targetrow $selectedline
6081 } elseif {[info exists targetid]} {
6082 set targetrow [expr {int(($row + $endrow) / 2)}]
6084 if {[info exists targetrow]} {
6085 if {$targetrow >= $numcommits} {
6086 set targetrow [expr {$numcommits - 1}]
6088 set targetid [commitonrow $targetrow]
6090 drawcommits $row $endrow
6093 proc clear_display {} {
6094 global iddrawn linesegs need_redisplay nrows_drawn
6095 global vhighlights fhighlights nhighlights rhighlights
6096 global linehtag linentag linedtag boldids boldnameids
6099 catch {unset iddrawn}
6100 catch {unset linesegs}
6101 catch {unset linehtag}
6102 catch {unset linentag}
6103 catch {unset linedtag}
6106 catch {unset vhighlights}
6107 catch {unset fhighlights}
6108 catch {unset nhighlights}
6109 catch {unset rhighlights}
6110 set need_redisplay 0
6114 proc findcrossings {id} {
6115 global rowidlist parentlist numcommits displayorder
6119 foreach {s e} [rowranges $id] {
6120 if {$e >= $numcommits} {
6121 set e [expr {$numcommits - 1}]
6123 if {$e <= $s} continue
6124 for {set row $e} {[incr row -1] >= $s} {} {
6125 set x [lsearch -exact [lindex $rowidlist $row] $id]
6127 set olds [lindex $parentlist $row]
6128 set kid [lindex $displayorder $row]
6129 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6130 if {$kidx < 0} continue
6131 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6133 set px [lsearch -exact $nextrow $p]
6134 if {$px < 0} continue
6135 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6136 if {[lsearch -exact $ccross $p] >= 0} continue
6137 if {$x == $px + ($kidx < $px? -1: 1)} {
6139 } elseif {[lsearch -exact $cross $p] < 0} {
6146 return [concat $ccross {{}} $cross]
6149 proc assigncolor {id} {
6150 global colormap colors nextcolor
6151 global parents children children curview
6153 if {[info exists colormap($id)]} return
6154 set ncolors [llength $colors]
6155 if {[info exists children($curview,$id)]} {
6156 set kids $children($curview,$id)
6160 if {[llength $kids] == 1} {
6161 set child [lindex $kids 0]
6162 if {[info exists colormap($child)]
6163 && [llength $parents($curview,$child)] == 1} {
6164 set colormap($id) $colormap($child)
6170 foreach x [findcrossings $id] {
6172 # delimiter between corner crossings and other crossings
6173 if {[llength $badcolors] >= $ncolors - 1} break
6174 set origbad $badcolors
6176 if {[info exists colormap($x)]
6177 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6178 lappend badcolors $colormap($x)
6181 if {[llength $badcolors] >= $ncolors} {
6182 set badcolors $origbad
6184 set origbad $badcolors
6185 if {[llength $badcolors] < $ncolors - 1} {
6186 foreach child $kids {
6187 if {[info exists colormap($child)]
6188 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6189 lappend badcolors $colormap($child)
6191 foreach p $parents($curview,$child) {
6192 if {[info exists colormap($p)]
6193 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6194 lappend badcolors $colormap($p)
6198 if {[llength $badcolors] >= $ncolors} {
6199 set badcolors $origbad
6202 for {set i 0} {$i <= $ncolors} {incr i} {
6203 set c [lindex $colors $nextcolor]
6204 if {[incr nextcolor] >= $ncolors} {
6207 if {[lsearch -exact $badcolors $c]} break
6209 set colormap($id) $c
6212 proc bindline {t id} {
6215 $canv bind $t <Enter> "lineenter %x %y $id"
6216 $canv bind $t <Motion> "linemotion %x %y $id"
6217 $canv bind $t <Leave> "lineleave $id"
6218 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6221 proc drawtags {id x xt y1} {
6222 global idtags idheads idotherrefs mainhead
6223 global linespc lthickness
6224 global canv rowtextx curview fgcolor bgcolor ctxbut
6229 if {[info exists idtags($id)]} {
6230 set marks $idtags($id)
6231 set ntags [llength $marks]
6233 if {[info exists idheads($id)]} {
6234 set marks [concat $marks $idheads($id)]
6235 set nheads [llength $idheads($id)]
6237 if {[info exists idotherrefs($id)]} {
6238 set marks [concat $marks $idotherrefs($id)]
6244 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6245 set yt [expr {$y1 - 0.5 * $linespc}]
6246 set yb [expr {$yt + $linespc - 1}]
6250 foreach tag $marks {
6252 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6253 set wid [font measure mainfontbold $tag]
6255 set wid [font measure mainfont $tag]
6259 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6261 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6262 -width $lthickness -fill black -tags tag.$id]
6264 foreach tag $marks x $xvals wid $wvals {
6265 set xl [expr {$x + $delta}]
6266 set xr [expr {$x + $delta + $wid + $lthickness}]
6268 if {[incr ntags -1] >= 0} {
6270 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6271 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6272 -width 1 -outline black -fill yellow -tags tag.$id]
6273 $canv bind $t <1> [list showtag $tag 1]
6274 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6276 # draw a head or other ref
6277 if {[incr nheads -1] >= 0} {
6279 if {$tag eq $mainhead} {
6280 set font mainfontbold
6285 set xl [expr {$xl - $delta/2}]
6286 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6287 -width 1 -outline black -fill $col -tags tag.$id
6288 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6289 set rwid [font measure mainfont $remoteprefix]
6290 set xi [expr {$x + 1}]
6291 set yti [expr {$yt + 1}]
6292 set xri [expr {$x + $rwid}]
6293 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6294 -width 0 -fill "#ffddaa" -tags tag.$id
6297 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6298 -font $font -tags [list tag.$id text]]
6300 $canv bind $t <1> [list showtag $tag 1]
6301 } elseif {$nheads >= 0} {
6302 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6308 proc xcoord {i level ln} {
6309 global canvx0 xspc1 xspc2
6311 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6312 if {$i > 0 && $i == $level} {
6313 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6314 } elseif {$i > $level} {
6315 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6320 proc show_status {msg} {
6324 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6325 -tags text -fill $fgcolor
6328 # Don't change the text pane cursor if it is currently the hand cursor,
6329 # showing that we are over a sha1 ID link.
6330 proc settextcursor {c} {
6331 global ctext curtextcursor
6333 if {[$ctext cget -cursor] == $curtextcursor} {
6334 $ctext config -cursor $c
6336 set curtextcursor $c
6339 proc nowbusy {what {name {}}} {
6340 global isbusy busyname statusw
6342 if {[array names isbusy] eq {}} {
6343 . config -cursor watch
6347 set busyname($what) $name
6349 $statusw conf -text $name
6353 proc notbusy {what} {
6354 global isbusy maincursor textcursor busyname statusw
6358 if {$busyname($what) ne {} &&
6359 [$statusw cget -text] eq $busyname($what)} {
6360 $statusw conf -text {}
6363 if {[array names isbusy] eq {}} {
6364 . config -cursor $maincursor
6365 settextcursor $textcursor
6369 proc findmatches {f} {
6370 global findtype findstring
6371 if {$findtype == [mc "Regexp"]} {
6372 set matches [regexp -indices -all -inline $findstring $f]
6375 if {$findtype == [mc "IgnCase"]} {
6376 set f [string tolower $f]
6377 set fs [string tolower $fs]
6381 set l [string length $fs]
6382 while {[set j [string first $fs $f $i]] >= 0} {
6383 lappend matches [list $j [expr {$j+$l-1}]]
6384 set i [expr {$j + $l}]
6390 proc dofind {{dirn 1} {wrap 1}} {
6391 global findstring findstartline findcurline selectedline numcommits
6392 global gdttype filehighlight fh_serial find_dirn findallowwrap
6394 if {[info exists find_dirn]} {
6395 if {$find_dirn == $dirn} return
6399 if {$findstring eq {} || $numcommits == 0} return
6400 if {$selectedline eq {}} {
6401 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6403 set findstartline $selectedline
6405 set findcurline $findstartline
6406 nowbusy finding [mc "Searching"]
6407 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6408 after cancel do_file_hl $fh_serial
6409 do_file_hl $fh_serial
6412 set findallowwrap $wrap
6416 proc stopfinding {} {
6417 global find_dirn findcurline fprogcoord
6419 if {[info exists find_dirn]} {
6430 global commitdata commitinfo numcommits findpattern findloc
6431 global findstartline findcurline findallowwrap
6432 global find_dirn gdttype fhighlights fprogcoord
6433 global curview varcorder vrownum varccommits vrowmod
6435 if {![info exists find_dirn]} {
6438 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6441 if {$find_dirn > 0} {
6443 if {$l >= $numcommits} {
6446 if {$l <= $findstartline} {
6447 set lim [expr {$findstartline + 1}]
6450 set moretodo $findallowwrap
6457 if {$l >= $findstartline} {
6458 set lim [expr {$findstartline - 1}]
6461 set moretodo $findallowwrap
6464 set n [expr {($lim - $l) * $find_dirn}]
6469 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6470 update_arcrows $curview
6474 set ai [bsearch $vrownum($curview) $l]
6475 set a [lindex $varcorder($curview) $ai]
6476 set arow [lindex $vrownum($curview) $ai]
6477 set ids [lindex $varccommits($curview,$a)]
6478 set arowend [expr {$arow + [llength $ids]}]
6479 if {$gdttype eq [mc "containing:"]} {
6480 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6481 if {$l < $arow || $l >= $arowend} {
6483 set a [lindex $varcorder($curview) $ai]
6484 set arow [lindex $vrownum($curview) $ai]
6485 set ids [lindex $varccommits($curview,$a)]
6486 set arowend [expr {$arow + [llength $ids]}]
6488 set id [lindex $ids [expr {$l - $arow}]]
6489 # shouldn't happen unless git log doesn't give all the commits...
6490 if {![info exists commitdata($id)] ||
6491 ![doesmatch $commitdata($id)]} {
6494 if {![info exists commitinfo($id)]} {
6497 set info $commitinfo($id)
6498 foreach f $info ty $fldtypes {
6499 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6508 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6509 if {$l < $arow || $l >= $arowend} {
6511 set a [lindex $varcorder($curview) $ai]
6512 set arow [lindex $vrownum($curview) $ai]
6513 set ids [lindex $varccommits($curview,$a)]
6514 set arowend [expr {$arow + [llength $ids]}]
6516 set id [lindex $ids [expr {$l - $arow}]]
6517 if {![info exists fhighlights($id)]} {
6518 # this sets fhighlights($id) to -1
6519 askfilehighlight $l $id
6521 if {$fhighlights($id) > 0} {
6525 if {$fhighlights($id) < 0} {
6528 set findcurline [expr {$l - $find_dirn}]
6533 if {$found || ($domore && !$moretodo)} {
6549 set findcurline [expr {$l - $find_dirn}]
6551 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6555 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6560 proc findselectline {l} {
6561 global findloc commentend ctext findcurline markingmatches gdttype
6563 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6566 if {$markingmatches &&
6567 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6568 # highlight the matches in the comments
6569 set f [$ctext get 1.0 $commentend]
6570 set matches [findmatches $f]
6571 foreach match $matches {
6572 set start [lindex $match 0]
6573 set end [expr {[lindex $match 1] + 1}]
6574 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6580 # mark the bits of a headline or author that match a find string
6581 proc markmatches {canv l str tag matches font row} {
6584 set bbox [$canv bbox $tag]
6585 set x0 [lindex $bbox 0]
6586 set y0 [lindex $bbox 1]
6587 set y1 [lindex $bbox 3]
6588 foreach match $matches {
6589 set start [lindex $match 0]
6590 set end [lindex $match 1]
6591 if {$start > $end} continue
6592 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6593 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6594 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6595 [expr {$x0+$xlen+2}] $y1 \
6596 -outline {} -tags [list match$l matches] -fill yellow]
6598 if {$row == $selectedline} {
6599 $canv raise $t secsel
6604 proc unmarkmatches {} {
6605 global markingmatches
6607 allcanvs delete matches
6608 set markingmatches 0
6612 proc selcanvline {w x y} {
6613 global canv canvy0 ctext linespc
6615 set ymax [lindex [$canv cget -scrollregion] 3]
6616 if {$ymax == {}} return
6617 set yfrac [lindex [$canv yview] 0]
6618 set y [expr {$y + $yfrac * $ymax}]
6619 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6624 set xmax [lindex [$canv cget -scrollregion] 2]
6625 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6626 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6632 proc commit_descriptor {p} {
6634 if {![info exists commitinfo($p)]} {
6638 if {[llength $commitinfo($p)] > 1} {
6639 set l [lindex $commitinfo($p) 0]
6644 # append some text to the ctext widget, and make any SHA1 ID
6645 # that we know about be a clickable link.
6646 proc appendwithlinks {text tags} {
6647 global ctext linknum curview
6649 set start [$ctext index "end - 1c"]
6650 $ctext insert end $text $tags
6651 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6655 set linkid [string range $text $s $e]
6657 $ctext tag delete link$linknum
6658 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6659 setlink $linkid link$linknum
6664 proc setlink {id lk} {
6665 global curview ctext pendinglinks
6668 if {[string length $id] < 40} {
6669 set matches [longid $id]
6670 if {[llength $matches] > 0} {
6671 if {[llength $matches] > 1} return
6673 set id [lindex $matches 0]
6676 set known [commitinview $id $curview]
6679 $ctext tag conf $lk -foreground blue -underline 1
6680 $ctext tag bind $lk <1> [list selbyid $id]
6681 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6682 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6684 lappend pendinglinks($id) $lk
6685 interestedin $id {makelink %P}
6689 proc appendshortlink {id {pre {}} {post {}}} {
6690 global ctext linknum
6692 $ctext insert end $pre
6693 $ctext tag delete link$linknum
6694 $ctext insert end [string range $id 0 7] link$linknum
6695 $ctext insert end $post
6696 setlink $id link$linknum
6700 proc makelink {id} {
6703 if {![info exists pendinglinks($id)]} return
6704 foreach lk $pendinglinks($id) {
6707 unset pendinglinks($id)
6710 proc linkcursor {w inc} {
6711 global linkentercount curtextcursor
6713 if {[incr linkentercount $inc] > 0} {
6714 $w configure -cursor hand2
6716 $w configure -cursor $curtextcursor
6717 if {$linkentercount < 0} {
6718 set linkentercount 0
6723 proc viewnextline {dir} {
6727 set ymax [lindex [$canv cget -scrollregion] 3]
6728 set wnow [$canv yview]
6729 set wtop [expr {[lindex $wnow 0] * $ymax}]
6730 set newtop [expr {$wtop + $dir * $linespc}]
6733 } elseif {$newtop > $ymax} {
6736 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6739 # add a list of tag or branch names at position pos
6740 # returns the number of names inserted
6741 proc appendrefs {pos ids var} {
6742 global ctext linknum curview $var maxrefs
6744 if {[catch {$ctext index $pos}]} {
6747 $ctext conf -state normal
6748 $ctext delete $pos "$pos lineend"
6751 foreach tag [set $var\($id\)] {
6752 lappend tags [list $tag $id]
6755 if {[llength $tags] > $maxrefs} {
6756 $ctext insert $pos "[mc "many"] ([llength $tags])"
6758 set tags [lsort -index 0 -decreasing $tags]
6761 set id [lindex $ti 1]
6764 $ctext tag delete $lk
6765 $ctext insert $pos $sep
6766 $ctext insert $pos [lindex $ti 0] $lk
6771 $ctext conf -state disabled
6772 return [llength $tags]
6775 # called when we have finished computing the nearby tags
6776 proc dispneartags {delay} {
6777 global selectedline currentid showneartags tagphase
6779 if {$selectedline eq {} || !$showneartags} return
6780 after cancel dispnexttag
6782 after 200 dispnexttag
6785 after idle dispnexttag
6790 proc dispnexttag {} {
6791 global selectedline currentid showneartags tagphase ctext
6793 if {$selectedline eq {} || !$showneartags} return
6794 switch -- $tagphase {
6796 set dtags [desctags $currentid]
6798 appendrefs precedes $dtags idtags
6802 set atags [anctags $currentid]
6804 appendrefs follows $atags idtags
6808 set dheads [descheads $currentid]
6809 if {$dheads ne {}} {
6810 if {[appendrefs branch $dheads idheads] > 1
6811 && [$ctext get "branch -3c"] eq "h"} {
6812 # turn "Branch" into "Branches"
6813 $ctext conf -state normal
6814 $ctext insert "branch -2c" "es"
6815 $ctext conf -state disabled
6820 if {[incr tagphase] <= 2} {
6821 after idle dispnexttag
6825 proc make_secsel {id} {
6826 global linehtag linentag linedtag canv canv2 canv3
6828 if {![info exists linehtag($id)]} return
6830 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6831 -tags secsel -fill [$canv cget -selectbackground]]
6833 $canv2 delete secsel
6834 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6835 -tags secsel -fill [$canv2 cget -selectbackground]]
6837 $canv3 delete secsel
6838 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6839 -tags secsel -fill [$canv3 cget -selectbackground]]
6843 proc make_idmark {id} {
6844 global linehtag canv fgcolor
6846 if {![info exists linehtag($id)]} return
6848 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6849 -tags markid -outline $fgcolor]
6853 proc selectline {l isnew {desired_loc {}}} {
6854 global canv ctext commitinfo selectedline
6855 global canvy0 linespc parents children curview
6856 global currentid sha1entry
6857 global commentend idtags linknum
6858 global mergemax numcommits pending_select
6859 global cmitmode showneartags allcommits
6860 global targetrow targetid lastscrollrows
6861 global autoselect jump_to_here
6863 catch {unset pending_select}
6868 if {$l < 0 || $l >= $numcommits} return
6869 set id [commitonrow $l]
6874 if {$lastscrollrows < $numcommits} {
6878 set y [expr {$canvy0 + $l * $linespc}]
6879 set ymax [lindex [$canv cget -scrollregion] 3]
6880 set ytop [expr {$y - $linespc - 1}]
6881 set ybot [expr {$y + $linespc + 1}]
6882 set wnow [$canv yview]
6883 set wtop [expr {[lindex $wnow 0] * $ymax}]
6884 set wbot [expr {[lindex $wnow 1] * $ymax}]
6885 set wh [expr {$wbot - $wtop}]
6887 if {$ytop < $wtop} {
6888 if {$ybot < $wtop} {
6889 set newtop [expr {$y - $wh / 2.0}]
6892 if {$newtop > $wtop - $linespc} {
6893 set newtop [expr {$wtop - $linespc}]
6896 } elseif {$ybot > $wbot} {
6897 if {$ytop > $wbot} {
6898 set newtop [expr {$y - $wh / 2.0}]
6900 set newtop [expr {$ybot - $wh}]
6901 if {$newtop < $wtop + $linespc} {
6902 set newtop [expr {$wtop + $linespc}]
6906 if {$newtop != $wtop} {
6910 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6917 addtohistory [list selbyid $id 0] savecmitpos
6920 $sha1entry delete 0 end
6921 $sha1entry insert 0 $id
6923 $sha1entry selection range 0 end
6927 $ctext conf -state normal
6930 if {![info exists commitinfo($id)]} {
6933 set info $commitinfo($id)
6934 set date [formatdate [lindex $info 2]]
6935 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6936 set date [formatdate [lindex $info 4]]
6937 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6938 if {[info exists idtags($id)]} {
6939 $ctext insert end [mc "Tags:"]
6940 foreach tag $idtags($id) {
6941 $ctext insert end " $tag"
6943 $ctext insert end "\n"
6947 set olds $parents($curview,$id)
6948 if {[llength $olds] > 1} {
6951 if {$np >= $mergemax} {
6956 $ctext insert end "[mc "Parent"]: " $tag
6957 appendwithlinks [commit_descriptor $p] {}
6962 append headers "[mc "Parent"]: [commit_descriptor $p]"
6966 foreach c $children($curview,$id) {
6967 append headers "[mc "Child"]: [commit_descriptor $c]"
6970 # make anything that looks like a SHA1 ID be a clickable link
6971 appendwithlinks $headers {}
6972 if {$showneartags} {
6973 if {![info exists allcommits]} {
6976 $ctext insert end "[mc "Branch"]: "
6977 $ctext mark set branch "end -1c"
6978 $ctext mark gravity branch left
6979 $ctext insert end "\n[mc "Follows"]: "
6980 $ctext mark set follows "end -1c"
6981 $ctext mark gravity follows left
6982 $ctext insert end "\n[mc "Precedes"]: "
6983 $ctext mark set precedes "end -1c"
6984 $ctext mark gravity precedes left
6985 $ctext insert end "\n"
6988 $ctext insert end "\n"
6989 set comment [lindex $info 5]
6990 if {[string first "\r" $comment] >= 0} {
6991 set comment [string map {"\r" "\n "} $comment]
6993 appendwithlinks $comment {comment}
6995 $ctext tag remove found 1.0 end
6996 $ctext conf -state disabled
6997 set commentend [$ctext index "end - 1c"]
6999 set jump_to_here $desired_loc
7000 init_flist [mc "Comments"]
7001 if {$cmitmode eq "tree"} {
7003 } elseif {[llength $olds] <= 1} {
7010 proc selfirstline {} {
7015 proc sellastline {} {
7018 set l [expr {$numcommits - 1}]
7022 proc selnextline {dir} {
7025 if {$selectedline eq {}} return
7026 set l [expr {$selectedline + $dir}]
7031 proc selnextpage {dir} {
7032 global canv linespc selectedline numcommits
7034 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7038 allcanvs yview scroll [expr {$dir * $lpp}] units
7040 if {$selectedline eq {}} return
7041 set l [expr {$selectedline + $dir * $lpp}]
7044 } elseif {$l >= $numcommits} {
7045 set l [expr $numcommits - 1]
7051 proc unselectline {} {
7052 global selectedline currentid
7055 catch {unset currentid}
7056 allcanvs delete secsel
7060 proc reselectline {} {
7063 if {$selectedline ne {}} {
7064 selectline $selectedline 0
7068 proc addtohistory {cmd {saveproc {}}} {
7069 global history historyindex curview
7073 set elt [list $curview $cmd $saveproc {}]
7074 if {$historyindex > 0
7075 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7079 if {$historyindex < [llength $history]} {
7080 set history [lreplace $history $historyindex end $elt]
7082 lappend history $elt
7085 if {$historyindex > 1} {
7086 .tf.bar.leftbut conf -state normal
7088 .tf.bar.leftbut conf -state disabled
7090 .tf.bar.rightbut conf -state disabled
7093 # save the scrolling position of the diff display pane
7094 proc save_position {} {
7095 global historyindex history
7097 if {$historyindex < 1} return
7098 set hi [expr {$historyindex - 1}]
7099 set fn [lindex $history $hi 2]
7101 lset history $hi 3 [eval $fn]
7105 proc unset_posvars {} {
7108 if {[info exists last_posvars]} {
7109 foreach {var val} $last_posvars {
7118 global curview last_posvars
7120 set view [lindex $elt 0]
7121 set cmd [lindex $elt 1]
7122 set pv [lindex $elt 3]
7123 if {$curview != $view} {
7127 foreach {var val} $pv {
7131 set last_posvars $pv
7136 global history historyindex
7139 if {$historyindex > 1} {
7141 incr historyindex -1
7142 godo [lindex $history [expr {$historyindex - 1}]]
7143 .tf.bar.rightbut conf -state normal
7145 if {$historyindex <= 1} {
7146 .tf.bar.leftbut conf -state disabled
7151 global history historyindex
7154 if {$historyindex < [llength $history]} {
7156 set cmd [lindex $history $historyindex]
7159 .tf.bar.leftbut conf -state normal
7161 if {$historyindex >= [llength $history]} {
7162 .tf.bar.rightbut conf -state disabled
7167 global treefilelist treeidlist diffids diffmergeid treepending
7168 global nullid nullid2
7171 catch {unset diffmergeid}
7172 if {![info exists treefilelist($id)]} {
7173 if {![info exists treepending]} {
7174 if {$id eq $nullid} {
7175 set cmd [list | git ls-files]
7176 } elseif {$id eq $nullid2} {
7177 set cmd [list | git ls-files --stage -t]
7179 set cmd [list | git ls-tree -r $id]
7181 if {[catch {set gtf [open $cmd r]}]} {
7185 set treefilelist($id) {}
7186 set treeidlist($id) {}
7187 fconfigure $gtf -blocking 0 -encoding binary
7188 filerun $gtf [list gettreeline $gtf $id]
7195 proc gettreeline {gtf id} {
7196 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7199 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7200 if {$diffids eq $nullid} {
7203 set i [string first "\t" $line]
7204 if {$i < 0} continue
7205 set fname [string range $line [expr {$i+1}] end]
7206 set line [string range $line 0 [expr {$i-1}]]
7207 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7208 set sha1 [lindex $line 2]
7209 lappend treeidlist($id) $sha1
7211 if {[string index $fname 0] eq "\""} {
7212 set fname [lindex $fname 0]
7214 set fname [encoding convertfrom $fname]
7215 lappend treefilelist($id) $fname
7218 return [expr {$nl >= 1000? 2: 1}]
7222 if {$cmitmode ne "tree"} {
7223 if {![info exists diffmergeid]} {
7224 gettreediffs $diffids
7226 } elseif {$id ne $diffids} {
7235 global treefilelist treeidlist diffids nullid nullid2
7236 global ctext_file_names ctext_file_lines
7237 global ctext commentend
7239 set i [lsearch -exact $treefilelist($diffids) $f]
7241 puts "oops, $f not in list for id $diffids"
7244 if {$diffids eq $nullid} {
7245 if {[catch {set bf [open $f r]} err]} {
7246 puts "oops, can't read $f: $err"
7250 set blob [lindex $treeidlist($diffids) $i]
7251 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7252 puts "oops, error reading blob $blob: $err"
7256 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7257 filerun $bf [list getblobline $bf $diffids]
7258 $ctext config -state normal
7259 clear_ctext $commentend
7260 lappend ctext_file_names $f
7261 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7262 $ctext insert end "\n"
7263 $ctext insert end "$f\n" filesep
7264 $ctext config -state disabled
7265 $ctext yview $commentend
7269 proc getblobline {bf id} {
7270 global diffids cmitmode ctext
7272 if {$id ne $diffids || $cmitmode ne "tree"} {
7276 $ctext config -state normal
7278 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7279 $ctext insert end "$line\n"
7282 global jump_to_here ctext_file_names commentend
7284 # delete last newline
7285 $ctext delete "end - 2c" "end - 1c"
7287 if {$jump_to_here ne {} &&
7288 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7289 set lnum [expr {[lindex $jump_to_here 1] +
7290 [lindex [split $commentend .] 0]}]
7291 mark_ctext_line $lnum
7295 $ctext config -state disabled
7296 return [expr {$nl >= 1000? 2: 1}]
7299 proc mark_ctext_line {lnum} {
7300 global ctext markbgcolor
7302 $ctext tag delete omark
7303 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7304 $ctext tag conf omark -background $markbgcolor
7308 proc mergediff {id} {
7310 global diffids treediffs
7311 global parents curview
7315 set treediffs($id) {}
7316 set np [llength $parents($curview,$id)]
7321 proc startdiff {ids} {
7322 global treediffs diffids treepending diffmergeid nullid nullid2
7326 catch {unset diffmergeid}
7327 if {![info exists treediffs($ids)] ||
7328 [lsearch -exact $ids $nullid] >= 0 ||
7329 [lsearch -exact $ids $nullid2] >= 0} {
7330 if {![info exists treepending]} {
7338 proc path_filter {filter name} {
7340 set l [string length $p]
7341 if {[string index $p end] eq "/"} {
7342 if {[string compare -length $l $p $name] == 0} {
7346 if {[string compare -length $l $p $name] == 0 &&
7347 ([string length $name] == $l ||
7348 [string index $name $l] eq "/")} {
7356 proc addtocflist {ids} {
7359 add_flist $treediffs($ids)
7363 proc diffcmd {ids flags} {
7364 global nullid nullid2
7366 set i [lsearch -exact $ids $nullid]
7367 set j [lsearch -exact $ids $nullid2]
7369 if {[llength $ids] > 1 && $j < 0} {
7370 # comparing working directory with some specific revision
7371 set cmd [concat | git diff-index $flags]
7373 lappend cmd -R [lindex $ids 1]
7375 lappend cmd [lindex $ids 0]
7378 # comparing working directory with index
7379 set cmd [concat | git diff-files $flags]
7384 } elseif {$j >= 0} {
7385 set cmd [concat | git diff-index --cached $flags]
7386 if {[llength $ids] > 1} {
7387 # comparing index with specific revision
7389 lappend cmd -R [lindex $ids 1]
7391 lappend cmd [lindex $ids 0]
7394 # comparing index with HEAD
7398 set cmd [concat | git diff-tree -r $flags $ids]
7403 proc gettreediffs {ids} {
7404 global treediff treepending
7406 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7408 set treepending $ids
7410 fconfigure $gdtf -blocking 0 -encoding binary
7411 filerun $gdtf [list gettreediffline $gdtf $ids]
7414 proc gettreediffline {gdtf ids} {
7415 global treediff treediffs treepending diffids diffmergeid
7416 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7421 if {$perfile_attrs} {
7422 # cache_gitattr is slow, and even slower on win32 where we
7423 # have to invoke it for only about 30 paths at a time
7425 if {[tk windowingsystem] == "win32"} {
7429 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7430 set i [string first "\t" $line]
7432 set file [string range $line [expr {$i+1}] end]
7433 if {[string index $file 0] eq "\""} {
7434 set file [lindex $file 0]
7436 set file [encoding convertfrom $file]
7437 if {$file ne [lindex $treediff end]} {
7438 lappend treediff $file
7439 lappend sublist $file
7443 if {$perfile_attrs} {
7444 cache_gitattr encoding $sublist
7447 return [expr {$nr >= $max? 2: 1}]
7450 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7452 foreach f $treediff {
7453 if {[path_filter $vfilelimit($curview) $f]} {
7457 set treediffs($ids) $flist
7459 set treediffs($ids) $treediff
7462 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7464 } elseif {$ids != $diffids} {
7465 if {![info exists diffmergeid]} {
7466 gettreediffs $diffids
7474 # empty string or positive integer
7475 proc diffcontextvalidate {v} {
7476 return [regexp {^(|[1-9][0-9]*)$} $v]
7479 proc diffcontextchange {n1 n2 op} {
7480 global diffcontextstring diffcontext
7482 if {[string is integer -strict $diffcontextstring]} {
7483 if {$diffcontextstring >= 0} {
7484 set diffcontext $diffcontextstring
7490 proc changeignorespace {} {
7494 proc getblobdiffs {ids} {
7495 global blobdifffd diffids env
7496 global diffinhdr treediffs
7499 global limitdiffs vfilelimit curview
7500 global diffencoding targetline diffnparents
7504 if {[package vcompare $git_version "1.6.1"] >= 0} {
7505 set textconv "--textconv"
7508 if {[package vcompare $git_version "1.6.6"] >= 0} {
7509 set submodule "--submodule"
7511 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7515 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7516 set cmd [concat $cmd -- $vfilelimit($curview)]
7518 if {[catch {set bdf [open $cmd r]} err]} {
7519 error_popup [mc "Error getting diffs: %s" $err]
7525 set diffencoding [get_path_encoding {}]
7526 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7527 set blobdifffd($ids) $bdf
7528 filerun $bdf [list getblobdiffline $bdf $diffids]
7531 proc savecmitpos {} {
7532 global ctext cmitmode
7534 if {$cmitmode eq "tree"} {
7537 return [list target_scrollpos [$ctext index @0,0]]
7540 proc savectextpos {} {
7543 return [list target_scrollpos [$ctext index @0,0]]
7546 proc maybe_scroll_ctext {ateof} {
7547 global ctext target_scrollpos
7549 if {![info exists target_scrollpos]} return
7551 set nlines [expr {[winfo height $ctext]
7552 / [font metrics textfont -linespace]}]
7553 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7555 $ctext yview $target_scrollpos
7556 unset target_scrollpos
7559 proc setinlist {var i val} {
7562 while {[llength [set $var]] < $i} {
7565 if {[llength [set $var]] == $i} {
7572 proc makediffhdr {fname ids} {
7573 global ctext curdiffstart treediffs diffencoding
7574 global ctext_file_names jump_to_here targetline diffline
7576 set fname [encoding convertfrom $fname]
7577 set diffencoding [get_path_encoding $fname]
7578 set i [lsearch -exact $treediffs($ids) $fname]
7580 setinlist difffilestart $i $curdiffstart
7582 lset ctext_file_names end $fname
7583 set l [expr {(78 - [string length $fname]) / 2}]
7584 set pad [string range "----------------------------------------" 1 $l]
7585 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7587 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7588 set targetline [lindex $jump_to_here 1]
7593 proc getblobdiffline {bdf ids} {
7594 global diffids blobdifffd ctext curdiffstart
7595 global diffnexthead diffnextnote difffilestart
7596 global ctext_file_names ctext_file_lines
7597 global diffinhdr treediffs mergemax diffnparents
7598 global diffencoding jump_to_here targetline diffline
7601 $ctext conf -state normal
7602 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7603 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7607 if {![string compare -length 5 "diff " $line]} {
7608 if {![regexp {^diff (--cc|--git) } $line m type]} {
7609 set line [encoding convertfrom $line]
7610 $ctext insert end "$line\n" hunksep
7613 # start of a new file
7615 $ctext insert end "\n"
7616 set curdiffstart [$ctext index "end - 1c"]
7617 lappend ctext_file_names ""
7618 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7619 $ctext insert end "\n" filesep
7621 if {$type eq "--cc"} {
7622 # start of a new file in a merge diff
7623 set fname [string range $line 10 end]
7624 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7625 lappend treediffs($ids) $fname
7626 add_flist [list $fname]
7630 set line [string range $line 11 end]
7631 # If the name hasn't changed the length will be odd,
7632 # the middle char will be a space, and the two bits either
7633 # side will be a/name and b/name, or "a/name" and "b/name".
7634 # If the name has changed we'll get "rename from" and
7635 # "rename to" or "copy from" and "copy to" lines following
7636 # this, and we'll use them to get the filenames.
7637 # This complexity is necessary because spaces in the
7638 # filename(s) don't get escaped.
7639 set l [string length $line]
7640 set i [expr {$l / 2}]
7641 if {!(($l & 1) && [string index $line $i] eq " " &&
7642 [string range $line 2 [expr {$i - 1}]] eq \
7643 [string range $line [expr {$i + 3}] end])} {
7646 # unescape if quoted and chop off the a/ from the front
7647 if {[string index $line 0] eq "\""} {
7648 set fname [string range [lindex $line 0] 2 end]
7650 set fname [string range $line 2 [expr {$i - 1}]]
7653 makediffhdr $fname $ids
7655 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7656 set fname [encoding convertfrom [string range $line 16 end]]
7657 $ctext insert end "\n"
7658 set curdiffstart [$ctext index "end - 1c"]
7659 lappend ctext_file_names $fname
7660 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7661 $ctext insert end "$line\n" filesep
7662 set i [lsearch -exact $treediffs($ids) $fname]
7664 setinlist difffilestart $i $curdiffstart
7667 } elseif {![string compare -length 2 "@@" $line]} {
7668 regexp {^@@+} $line ats
7669 set line [encoding convertfrom $diffencoding $line]
7670 $ctext insert end "$line\n" hunksep
7671 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7674 set diffnparents [expr {[string length $ats] - 1}]
7677 } elseif {![string compare -length 10 "Submodule " $line]} {
7678 # start of a new submodule
7679 if {[string compare [$ctext get "end - 4c" end] "\n \n\n"]} {
7680 $ctext insert end "\n"; # Add newline after commit message
7682 set curdiffstart [$ctext index "end - 1c"]
7683 lappend ctext_file_names ""
7684 set fname [string range $line 10 [expr [string last " " $line] - 1]]
7685 lappend ctext_file_lines $fname
7686 makediffhdr $fname $ids
7687 $ctext insert end "\n$line\n" filesep
7688 } elseif {![string compare -length 3 " >" $line]} {
7689 $ctext insert end "$line\n" dresult
7690 } elseif {![string compare -length 3 " <" $line]} {
7691 $ctext insert end "$line\n" d0
7692 } elseif {$diffinhdr} {
7693 if {![string compare -length 12 "rename from " $line]} {
7694 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7695 if {[string index $fname 0] eq "\""} {
7696 set fname [lindex $fname 0]
7698 set fname [encoding convertfrom $fname]
7699 set i [lsearch -exact $treediffs($ids) $fname]
7701 setinlist difffilestart $i $curdiffstart
7703 } elseif {![string compare -length 10 $line "rename to "] ||
7704 ![string compare -length 8 $line "copy to "]} {
7705 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7706 if {[string index $fname 0] eq "\""} {
7707 set fname [lindex $fname 0]
7709 makediffhdr $fname $ids
7710 } elseif {[string compare -length 3 $line "---"] == 0} {
7713 } elseif {[string compare -length 3 $line "+++"] == 0} {
7717 $ctext insert end "$line\n" filesep
7720 set line [string map {\x1A ^Z} \
7721 [encoding convertfrom $diffencoding $line]]
7722 # parse the prefix - one ' ', '-' or '+' for each parent
7723 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7724 set tag [expr {$diffnparents > 1? "m": "d"}]
7725 if {[string trim $prefix " -+"] eq {}} {
7726 # prefix only has " ", "-" and "+" in it: normal diff line
7727 set num [string first "-" $prefix]
7729 # removed line, first parent with line is $num
7730 if {$num >= $mergemax} {
7733 $ctext insert end "$line\n" $tag$num
7736 if {[string first "+" $prefix] >= 0} {
7738 lappend tags ${tag}result
7739 if {$diffnparents > 1} {
7740 set num [string first " " $prefix]
7742 if {$num >= $mergemax} {
7749 if {$targetline ne {}} {
7750 if {$diffline == $targetline} {
7751 set seehere [$ctext index "end - 1 chars"]
7757 $ctext insert end "$line\n" $tags
7760 # "\ No newline at end of file",
7761 # or something else we don't recognize
7762 $ctext insert end "$line\n" hunksep
7766 if {[info exists seehere]} {
7767 mark_ctext_line [lindex [split $seehere .] 0]
7769 maybe_scroll_ctext [eof $bdf]
7770 $ctext conf -state disabled
7775 return [expr {$nr >= 1000? 2: 1}]
7778 proc changediffdisp {} {
7779 global ctext diffelide
7781 $ctext tag conf d0 -elide [lindex $diffelide 0]
7782 $ctext tag conf dresult -elide [lindex $diffelide 1]
7785 proc highlightfile {loc cline} {
7786 global ctext cflist cflist_top
7789 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7790 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7791 $cflist see $cline.0
7792 set cflist_top $cline
7796 global difffilestart ctext cmitmode
7798 if {$cmitmode eq "tree"} return
7801 set here [$ctext index @0,0]
7802 foreach loc $difffilestart {
7803 if {[$ctext compare $loc >= $here]} {
7804 highlightfile $prev $prevline
7810 highlightfile $prev $prevline
7814 global difffilestart ctext cmitmode
7816 if {$cmitmode eq "tree"} return
7817 set here [$ctext index @0,0]
7819 foreach loc $difffilestart {
7821 if {[$ctext compare $loc > $here]} {
7822 highlightfile $loc $line
7828 proc clear_ctext {{first 1.0}} {
7829 global ctext smarktop smarkbot
7830 global ctext_file_names ctext_file_lines
7833 set l [lindex [split $first .] 0]
7834 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7837 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7840 $ctext delete $first end
7841 if {$first eq "1.0"} {
7842 catch {unset pendinglinks}
7844 set ctext_file_names {}
7845 set ctext_file_lines {}
7848 proc settabs {{firstab {}}} {
7849 global firsttabstop tabstop ctext have_tk85
7851 if {$firstab ne {} && $have_tk85} {
7852 set firsttabstop $firstab
7854 set w [font measure textfont "0"]
7855 if {$firsttabstop != 0} {
7856 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7857 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7858 } elseif {$have_tk85 || $tabstop != 8} {
7859 $ctext conf -tabs [expr {$tabstop * $w}]
7861 $ctext conf -tabs {}
7865 proc incrsearch {name ix op} {
7866 global ctext searchstring searchdirn
7868 $ctext tag remove found 1.0 end
7869 if {[catch {$ctext index anchor}]} {
7870 # no anchor set, use start of selection, or of visible area
7871 set sel [$ctext tag ranges sel]
7873 $ctext mark set anchor [lindex $sel 0]
7874 } elseif {$searchdirn eq "-forwards"} {
7875 $ctext mark set anchor @0,0
7877 $ctext mark set anchor @0,[winfo height $ctext]
7880 if {$searchstring ne {}} {
7881 set here [$ctext search $searchdirn -- $searchstring anchor]
7890 global sstring ctext searchstring searchdirn
7893 $sstring icursor end
7894 set searchdirn -forwards
7895 if {$searchstring ne {}} {
7896 set sel [$ctext tag ranges sel]
7898 set start "[lindex $sel 0] + 1c"
7899 } elseif {[catch {set start [$ctext index anchor]}]} {
7902 set match [$ctext search -count mlen -- $searchstring $start]
7903 $ctext tag remove sel 1.0 end
7909 set mend "$match + $mlen c"
7910 $ctext tag add sel $match $mend
7911 $ctext mark unset anchor
7915 proc dosearchback {} {
7916 global sstring ctext searchstring searchdirn
7919 $sstring icursor end
7920 set searchdirn -backwards
7921 if {$searchstring ne {}} {
7922 set sel [$ctext tag ranges sel]
7924 set start [lindex $sel 0]
7925 } elseif {[catch {set start [$ctext index anchor]}]} {
7926 set start @0,[winfo height $ctext]
7928 set match [$ctext search -backwards -count ml -- $searchstring $start]
7929 $ctext tag remove sel 1.0 end
7935 set mend "$match + $ml c"
7936 $ctext tag add sel $match $mend
7937 $ctext mark unset anchor
7941 proc searchmark {first last} {
7942 global ctext searchstring
7946 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7947 if {$match eq {}} break
7948 set mend "$match + $mlen c"
7949 $ctext tag add found $match $mend
7953 proc searchmarkvisible {doall} {
7954 global ctext smarktop smarkbot
7956 set topline [lindex [split [$ctext index @0,0] .] 0]
7957 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7958 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7959 # no overlap with previous
7960 searchmark $topline $botline
7961 set smarktop $topline
7962 set smarkbot $botline
7964 if {$topline < $smarktop} {
7965 searchmark $topline [expr {$smarktop-1}]
7966 set smarktop $topline
7968 if {$botline > $smarkbot} {
7969 searchmark [expr {$smarkbot+1}] $botline
7970 set smarkbot $botline
7975 proc scrolltext {f0 f1} {
7978 .bleft.bottom.sb set $f0 $f1
7979 if {$searchstring ne {}} {
7985 global linespc charspc canvx0 canvy0
7986 global xspc1 xspc2 lthickness
7988 set linespc [font metrics mainfont -linespace]
7989 set charspc [font measure mainfont "m"]
7990 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7991 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7992 set lthickness [expr {int($linespc / 9) + 1}]
7993 set xspc1(0) $linespc
8001 set ymax [lindex [$canv cget -scrollregion] 3]
8002 if {$ymax eq {} || $ymax == 0} return
8003 set span [$canv yview]
8006 allcanvs yview moveto [lindex $span 0]
8008 if {$selectedline ne {}} {
8009 selectline $selectedline 0
8010 allcanvs yview moveto [lindex $span 0]
8014 proc parsefont {f n} {
8017 set fontattr($f,family) [lindex $n 0]
8019 if {$s eq {} || $s == 0} {
8022 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8024 set fontattr($f,size) $s
8025 set fontattr($f,weight) normal
8026 set fontattr($f,slant) roman
8027 foreach style [lrange $n 2 end] {
8030 "bold" {set fontattr($f,weight) $style}
8032 "italic" {set fontattr($f,slant) $style}
8037 proc fontflags {f {isbold 0}} {
8040 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8041 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8042 -slant $fontattr($f,slant)]
8048 set n [list $fontattr($f,family) $fontattr($f,size)]
8049 if {$fontattr($f,weight) eq "bold"} {
8052 if {$fontattr($f,slant) eq "italic"} {
8058 proc incrfont {inc} {
8059 global mainfont textfont ctext canv cflist showrefstop
8060 global stopped entries fontattr
8063 set s $fontattr(mainfont,size)
8068 set fontattr(mainfont,size) $s
8069 font config mainfont -size $s
8070 font config mainfontbold -size $s
8071 set mainfont [fontname mainfont]
8072 set s $fontattr(textfont,size)
8077 set fontattr(textfont,size) $s
8078 font config textfont -size $s
8079 font config textfontbold -size $s
8080 set textfont [fontname textfont]
8087 global sha1entry sha1string
8088 if {[string length $sha1string] == 40} {
8089 $sha1entry delete 0 end
8093 proc sha1change {n1 n2 op} {
8094 global sha1string currentid sha1but
8095 if {$sha1string == {}
8096 || ([info exists currentid] && $sha1string == $currentid)} {
8101 if {[$sha1but cget -state] == $state} return
8102 if {$state == "normal"} {
8103 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8105 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8109 proc gotocommit {} {
8110 global sha1string tagids headids curview varcid
8112 if {$sha1string == {}
8113 || ([info exists currentid] && $sha1string == $currentid)} return
8114 if {[info exists tagids($sha1string)]} {
8115 set id $tagids($sha1string)
8116 } elseif {[info exists headids($sha1string)]} {
8117 set id $headids($sha1string)
8119 set id [string tolower $sha1string]
8120 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8121 set matches [longid $id]
8122 if {$matches ne {}} {
8123 if {[llength $matches] > 1} {
8124 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8127 set id [lindex $matches 0]
8130 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8131 error_popup [mc "Revision %s is not known" $sha1string]
8136 if {[commitinview $id $curview]} {
8137 selectline [rowofcommit $id] 1
8140 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8141 set msg [mc "SHA1 id %s is not known" $sha1string]
8143 set msg [mc "Revision %s is not in the current view" $sha1string]
8148 proc lineenter {x y id} {
8149 global hoverx hovery hoverid hovertimer
8150 global commitinfo canv
8152 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8156 if {[info exists hovertimer]} {
8157 after cancel $hovertimer
8159 set hovertimer [after 500 linehover]
8163 proc linemotion {x y id} {
8164 global hoverx hovery hoverid hovertimer
8166 if {[info exists hoverid] && $id == $hoverid} {
8169 if {[info exists hovertimer]} {
8170 after cancel $hovertimer
8172 set hovertimer [after 500 linehover]
8176 proc lineleave {id} {
8177 global hoverid hovertimer canv
8179 if {[info exists hoverid] && $id == $hoverid} {
8181 if {[info exists hovertimer]} {
8182 after cancel $hovertimer
8190 global hoverx hovery hoverid hovertimer
8191 global canv linespc lthickness
8194 set text [lindex $commitinfo($hoverid) 0]
8195 set ymax [lindex [$canv cget -scrollregion] 3]
8196 if {$ymax == {}} return
8197 set yfrac [lindex [$canv yview] 0]
8198 set x [expr {$hoverx + 2 * $linespc}]
8199 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8200 set x0 [expr {$x - 2 * $lthickness}]
8201 set y0 [expr {$y - 2 * $lthickness}]
8202 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8203 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8204 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8205 -fill \#ffff80 -outline black -width 1 -tags hover]
8207 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8212 proc clickisonarrow {id y} {
8215 set ranges [rowranges $id]
8216 set thresh [expr {2 * $lthickness + 6}]
8217 set n [expr {[llength $ranges] - 1}]
8218 for {set i 1} {$i < $n} {incr i} {
8219 set row [lindex $ranges $i]
8220 if {abs([yc $row] - $y) < $thresh} {
8227 proc arrowjump {id n y} {
8230 # 1 <-> 2, 3 <-> 4, etc...
8231 set n [expr {(($n - 1) ^ 1) + 1}]
8232 set row [lindex [rowranges $id] $n]
8234 set ymax [lindex [$canv cget -scrollregion] 3]
8235 if {$ymax eq {} || $ymax <= 0} return
8236 set view [$canv yview]
8237 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8238 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8242 allcanvs yview moveto $yfrac
8245 proc lineclick {x y id isnew} {
8246 global ctext commitinfo children canv thickerline curview
8248 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8253 # draw this line thicker than normal
8257 set ymax [lindex [$canv cget -scrollregion] 3]
8258 if {$ymax eq {}} return
8259 set yfrac [lindex [$canv yview] 0]
8260 set y [expr {$y + $yfrac * $ymax}]
8262 set dirn [clickisonarrow $id $y]
8264 arrowjump $id $dirn $y
8269 addtohistory [list lineclick $x $y $id 0] savectextpos
8271 # fill the details pane with info about this line
8272 $ctext conf -state normal
8275 $ctext insert end "[mc "Parent"]:\t"
8276 $ctext insert end $id link0
8278 set info $commitinfo($id)
8279 $ctext insert end "\n\t[lindex $info 0]\n"
8280 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8281 set date [formatdate [lindex $info 2]]
8282 $ctext insert end "\t[mc "Date"]:\t$date\n"
8283 set kids $children($curview,$id)
8285 $ctext insert end "\n[mc "Children"]:"
8287 foreach child $kids {
8289 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8290 set info $commitinfo($child)
8291 $ctext insert end "\n\t"
8292 $ctext insert end $child link$i
8293 setlink $child link$i
8294 $ctext insert end "\n\t[lindex $info 0]"
8295 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8296 set date [formatdate [lindex $info 2]]
8297 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8300 maybe_scroll_ctext 1
8301 $ctext conf -state disabled
8305 proc normalline {} {
8307 if {[info exists thickerline]} {
8314 proc selbyid {id {isnew 1}} {
8316 if {[commitinview $id $curview]} {
8317 selectline [rowofcommit $id] $isnew
8323 if {![info exists startmstime]} {
8324 set startmstime [clock clicks -milliseconds]
8326 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8329 proc rowmenu {x y id} {
8330 global rowctxmenu selectedline rowmenuid curview
8331 global nullid nullid2 fakerowmenu mainhead markedid
8335 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8340 if {$id ne $nullid && $id ne $nullid2} {
8341 set menu $rowctxmenu
8342 if {$mainhead ne {}} {
8343 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8345 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8347 if {[info exists markedid] && $markedid ne $id} {
8348 $menu entryconfigure 9 -state normal
8349 $menu entryconfigure 10 -state normal
8350 $menu entryconfigure 11 -state normal
8352 $menu entryconfigure 9 -state disabled
8353 $menu entryconfigure 10 -state disabled
8354 $menu entryconfigure 11 -state disabled
8357 set menu $fakerowmenu
8359 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8360 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8361 $menu entryconfigure [mca "Make patch"] -state $state
8362 tk_popup $menu $x $y
8366 global rowmenuid markedid canv
8368 set markedid $rowmenuid
8369 make_idmark $markedid
8375 if {[info exists markedid]} {
8380 proc replace_by_kids {l r} {
8381 global curview children
8383 set id [commitonrow $r]
8384 set l [lreplace $l 0 0]
8385 foreach kid $children($curview,$id) {
8386 lappend l [rowofcommit $kid]
8388 return [lsort -integer -decreasing -unique $l]
8391 proc find_common_desc {} {
8392 global markedid rowmenuid curview children
8394 if {![info exists markedid]} return
8395 if {![commitinview $markedid $curview] ||
8396 ![commitinview $rowmenuid $curview]} return
8397 #set t1 [clock clicks -milliseconds]
8398 set l1 [list [rowofcommit $markedid]]
8399 set l2 [list [rowofcommit $rowmenuid]]
8401 set r1 [lindex $l1 0]
8402 set r2 [lindex $l2 0]
8403 if {$r1 eq {} || $r2 eq {}} break
8409 set l1 [replace_by_kids $l1 $r1]
8411 set l2 [replace_by_kids $l2 $r2]
8414 #set t2 [clock clicks -milliseconds]
8415 #puts "took [expr {$t2-$t1}]ms"
8418 proc compare_commits {} {
8419 global markedid rowmenuid curview children
8421 if {![info exists markedid]} return
8422 if {![commitinview $markedid $curview]} return
8423 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8424 do_cmp_commits $markedid $rowmenuid
8427 proc getpatchid {id} {
8430 if {![info exists patchids($id)]} {
8431 set cmd [diffcmd [list $id] {-p --root}]
8432 # trim off the initial "|"
8433 set cmd [lrange $cmd 1 end]
8435 set x [eval exec $cmd | git patch-id]
8436 set patchids($id) [lindex $x 0]
8438 set patchids($id) "error"
8441 return $patchids($id)
8444 proc do_cmp_commits {a b} {
8445 global ctext curview parents children patchids commitinfo
8447 $ctext conf -state normal
8450 for {set i 0} {$i < 100} {incr i} {
8453 if {[llength $parents($curview,$a)] > 1} {
8454 appendshortlink $a [mc "Skipping merge commit "] "\n"
8457 set patcha [getpatchid $a]
8459 if {[llength $parents($curview,$b)] > 1} {
8460 appendshortlink $b [mc "Skipping merge commit "] "\n"
8463 set patchb [getpatchid $b]
8465 if {!$skipa && !$skipb} {
8466 set heada [lindex $commitinfo($a) 0]
8467 set headb [lindex $commitinfo($b) 0]
8468 if {$patcha eq "error"} {
8469 appendshortlink $a [mc "Error getting patch ID for "] \
8470 [mc " - stopping\n"]
8473 if {$patchb eq "error"} {
8474 appendshortlink $b [mc "Error getting patch ID for "] \
8475 [mc " - stopping\n"]
8478 if {$patcha eq $patchb} {
8479 if {$heada eq $headb} {
8480 appendshortlink $a [mc "Commit "]
8481 appendshortlink $b " == " " $heada\n"
8483 appendshortlink $a [mc "Commit "] " $heada\n"
8484 appendshortlink $b [mc " is the same patch as\n "] \
8490 $ctext insert end "\n"
8491 appendshortlink $a [mc "Commit "] " $heada\n"
8492 appendshortlink $b [mc " differs from\n "] \
8494 $ctext insert end [mc "Diff of commits:\n\n"]
8495 $ctext conf -state disabled
8502 set kids [real_children $curview,$a]
8503 if {[llength $kids] != 1} {
8504 $ctext insert end "\n"
8505 appendshortlink $a [mc "Commit "] \
8506 [mc " has %s children - stopping\n" [llength $kids]]
8509 set a [lindex $kids 0]
8512 set kids [real_children $curview,$b]
8513 if {[llength $kids] != 1} {
8514 appendshortlink $b [mc "Commit "] \
8515 [mc " has %s children - stopping\n" [llength $kids]]
8518 set b [lindex $kids 0]
8521 $ctext conf -state disabled
8524 proc diffcommits {a b} {
8525 global diffcontext diffids blobdifffd diffinhdr
8527 set tmpdir [gitknewtmpdir]
8528 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8529 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8531 exec git diff-tree -p --pretty $a >$fna
8532 exec git diff-tree -p --pretty $b >$fnb
8534 error_popup [mc "Error writing commit to file: %s" $err]
8538 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8540 error_popup [mc "Error diffing commits: %s" $err]
8543 set diffids [list commits $a $b]
8544 set blobdifffd($diffids) $fd
8546 filerun $fd [list getblobdiffline $fd $diffids]
8549 proc diffvssel {dirn} {
8550 global rowmenuid selectedline
8552 if {$selectedline eq {}} return
8554 set oldid [commitonrow $selectedline]
8555 set newid $rowmenuid
8557 set oldid $rowmenuid
8558 set newid [commitonrow $selectedline]
8560 addtohistory [list doseldiff $oldid $newid] savectextpos
8561 doseldiff $oldid $newid
8564 proc doseldiff {oldid newid} {
8568 $ctext conf -state normal
8570 init_flist [mc "Top"]
8571 $ctext insert end "[mc "From"] "
8572 $ctext insert end $oldid link0
8573 setlink $oldid link0
8574 $ctext insert end "\n "
8575 $ctext insert end [lindex $commitinfo($oldid) 0]
8576 $ctext insert end "\n\n[mc "To"] "
8577 $ctext insert end $newid link1
8578 setlink $newid link1
8579 $ctext insert end "\n "
8580 $ctext insert end [lindex $commitinfo($newid) 0]
8581 $ctext insert end "\n"
8582 $ctext conf -state disabled
8583 $ctext tag remove found 1.0 end
8584 startdiff [list $oldid $newid]
8588 global rowmenuid currentid commitinfo patchtop patchnum NS
8590 if {![info exists currentid]} return
8591 set oldid $currentid
8592 set oldhead [lindex $commitinfo($oldid) 0]
8593 set newid $rowmenuid
8594 set newhead [lindex $commitinfo($newid) 0]
8597 catch {destroy $top}
8599 make_transient $top .
8600 ${NS}::label $top.title -text [mc "Generate patch"]
8601 grid $top.title - -pady 10
8602 ${NS}::label $top.from -text [mc "From:"]
8603 ${NS}::entry $top.fromsha1 -width 40
8604 $top.fromsha1 insert 0 $oldid
8605 $top.fromsha1 conf -state readonly
8606 grid $top.from $top.fromsha1 -sticky w
8607 ${NS}::entry $top.fromhead -width 60
8608 $top.fromhead insert 0 $oldhead
8609 $top.fromhead conf -state readonly
8610 grid x $top.fromhead -sticky w
8611 ${NS}::label $top.to -text [mc "To:"]
8612 ${NS}::entry $top.tosha1 -width 40
8613 $top.tosha1 insert 0 $newid
8614 $top.tosha1 conf -state readonly
8615 grid $top.to $top.tosha1 -sticky w
8616 ${NS}::entry $top.tohead -width 60
8617 $top.tohead insert 0 $newhead
8618 $top.tohead conf -state readonly
8619 grid x $top.tohead -sticky w
8620 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8621 grid $top.rev x -pady 10 -padx 5
8622 ${NS}::label $top.flab -text [mc "Output file:"]
8623 ${NS}::entry $top.fname -width 60
8624 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8626 grid $top.flab $top.fname -sticky w
8627 ${NS}::frame $top.buts
8628 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8629 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8630 bind $top <Key-Return> mkpatchgo
8631 bind $top <Key-Escape> mkpatchcan
8632 grid $top.buts.gen $top.buts.can
8633 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8634 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8635 grid $top.buts - -pady 10 -sticky ew
8639 proc mkpatchrev {} {
8642 set oldid [$patchtop.fromsha1 get]
8643 set oldhead [$patchtop.fromhead get]
8644 set newid [$patchtop.tosha1 get]
8645 set newhead [$patchtop.tohead get]
8646 foreach e [list fromsha1 fromhead tosha1 tohead] \
8647 v [list $newid $newhead $oldid $oldhead] {
8648 $patchtop.$e conf -state normal
8649 $patchtop.$e delete 0 end
8650 $patchtop.$e insert 0 $v
8651 $patchtop.$e conf -state readonly
8656 global patchtop nullid nullid2
8658 set oldid [$patchtop.fromsha1 get]
8659 set newid [$patchtop.tosha1 get]
8660 set fname [$patchtop.fname get]
8661 set cmd [diffcmd [list $oldid $newid] -p]
8662 # trim off the initial "|"
8663 set cmd [lrange $cmd 1 end]
8664 lappend cmd >$fname &
8665 if {[catch {eval exec $cmd} err]} {
8666 error_popup "[mc "Error creating patch:"] $err" $patchtop
8668 catch {destroy $patchtop}
8672 proc mkpatchcan {} {
8675 catch {destroy $patchtop}
8680 global rowmenuid mktagtop commitinfo NS
8684 catch {destroy $top}
8686 make_transient $top .
8687 ${NS}::label $top.title -text [mc "Create tag"]
8688 grid $top.title - -pady 10
8689 ${NS}::label $top.id -text [mc "ID:"]
8690 ${NS}::entry $top.sha1 -width 40
8691 $top.sha1 insert 0 $rowmenuid
8692 $top.sha1 conf -state readonly
8693 grid $top.id $top.sha1 -sticky w
8694 ${NS}::entry $top.head -width 60
8695 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8696 $top.head conf -state readonly
8697 grid x $top.head -sticky w
8698 ${NS}::label $top.tlab -text [mc "Tag name:"]
8699 ${NS}::entry $top.tag -width 60
8700 grid $top.tlab $top.tag -sticky w
8701 ${NS}::frame $top.buts
8702 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8703 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8704 bind $top <Key-Return> mktaggo
8705 bind $top <Key-Escape> mktagcan
8706 grid $top.buts.gen $top.buts.can
8707 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8708 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8709 grid $top.buts - -pady 10 -sticky ew
8714 global mktagtop env tagids idtags
8716 set id [$mktagtop.sha1 get]
8717 set tag [$mktagtop.tag get]
8719 error_popup [mc "No tag name specified"] $mktagtop
8722 if {[info exists tagids($tag)]} {
8723 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8727 exec git tag $tag $id
8729 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8733 set tagids($tag) $id
8734 lappend idtags($id) $tag
8742 proc redrawtags {id} {
8743 global canv linehtag idpos currentid curview cmitlisted markedid
8744 global canvxmax iddrawn circleitem mainheadid circlecolors
8746 if {![commitinview $id $curview]} return
8747 if {![info exists iddrawn($id)]} return
8748 set row [rowofcommit $id]
8749 if {$id eq $mainheadid} {
8752 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8754 $canv itemconf $circleitem($row) -fill $ofill
8755 $canv delete tag.$id
8756 set xt [eval drawtags $id $idpos($id)]
8757 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8758 set text [$canv itemcget $linehtag($id) -text]
8759 set font [$canv itemcget $linehtag($id) -font]
8760 set xr [expr {$xt + [font measure $font $text]}]
8761 if {$xr > $canvxmax} {
8765 if {[info exists currentid] && $currentid == $id} {
8768 if {[info exists markedid] && $markedid eq $id} {
8776 catch {destroy $mktagtop}
8781 if {![domktag]} return
8785 proc writecommit {} {
8786 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8788 set top .writecommit
8790 catch {destroy $top}
8792 make_transient $top .
8793 ${NS}::label $top.title -text [mc "Write commit to file"]
8794 grid $top.title - -pady 10
8795 ${NS}::label $top.id -text [mc "ID:"]
8796 ${NS}::entry $top.sha1 -width 40
8797 $top.sha1 insert 0 $rowmenuid
8798 $top.sha1 conf -state readonly
8799 grid $top.id $top.sha1 -sticky w
8800 ${NS}::entry $top.head -width 60
8801 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8802 $top.head conf -state readonly
8803 grid x $top.head -sticky w
8804 ${NS}::label $top.clab -text [mc "Command:"]
8805 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8806 grid $top.clab $top.cmd -sticky w -pady 10
8807 ${NS}::label $top.flab -text [mc "Output file:"]
8808 ${NS}::entry $top.fname -width 60
8809 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8810 grid $top.flab $top.fname -sticky w
8811 ${NS}::frame $top.buts
8812 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8813 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8814 bind $top <Key-Return> wrcomgo
8815 bind $top <Key-Escape> wrcomcan
8816 grid $top.buts.gen $top.buts.can
8817 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8818 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8819 grid $top.buts - -pady 10 -sticky ew
8826 set id [$wrcomtop.sha1 get]
8827 set cmd "echo $id | [$wrcomtop.cmd get]"
8828 set fname [$wrcomtop.fname get]
8829 if {[catch {exec sh -c $cmd >$fname &} err]} {
8830 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8832 catch {destroy $wrcomtop}
8839 catch {destroy $wrcomtop}
8844 global rowmenuid mkbrtop NS
8847 catch {destroy $top}
8849 make_transient $top .
8850 ${NS}::label $top.title -text [mc "Create new branch"]
8851 grid $top.title - -pady 10
8852 ${NS}::label $top.id -text [mc "ID:"]
8853 ${NS}::entry $top.sha1 -width 40
8854 $top.sha1 insert 0 $rowmenuid
8855 $top.sha1 conf -state readonly
8856 grid $top.id $top.sha1 -sticky w
8857 ${NS}::label $top.nlab -text [mc "Name:"]
8858 ${NS}::entry $top.name -width 40
8859 grid $top.nlab $top.name -sticky w
8860 ${NS}::frame $top.buts
8861 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8862 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8863 bind $top <Key-Return> [list mkbrgo $top]
8864 bind $top <Key-Escape> "catch {destroy $top}"
8865 grid $top.buts.go $top.buts.can
8866 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8867 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8868 grid $top.buts - -pady 10 -sticky ew
8873 global headids idheads
8875 set name [$top.name get]
8876 set id [$top.sha1 get]
8880 error_popup [mc "Please specify a name for the new branch"] $top
8883 if {[info exists headids($name)]} {
8884 if {![confirm_popup [mc \
8885 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8888 set old_id $headids($name)
8891 catch {destroy $top}
8892 lappend cmdargs $name $id
8896 eval exec git branch $cmdargs
8902 if {$old_id ne {}} {
8908 set headids($name) $id
8909 lappend idheads($id) $name
8918 proc exec_citool {tool_args {baseid {}}} {
8919 global commitinfo env
8921 set save_env [array get env GIT_AUTHOR_*]
8923 if {$baseid ne {}} {
8924 if {![info exists commitinfo($baseid)]} {
8927 set author [lindex $commitinfo($baseid) 1]
8928 set date [lindex $commitinfo($baseid) 2]
8929 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8930 $author author name email]
8932 set env(GIT_AUTHOR_NAME) $name
8933 set env(GIT_AUTHOR_EMAIL) $email
8934 set env(GIT_AUTHOR_DATE) $date
8938 eval exec git citool $tool_args &
8940 array unset env GIT_AUTHOR_*
8941 array set env $save_env
8944 proc cherrypick {} {
8945 global rowmenuid curview
8946 global mainhead mainheadid
8948 set oldhead [exec git rev-parse HEAD]
8949 set dheads [descheads $rowmenuid]
8950 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8951 set ok [confirm_popup [mc "Commit %s is already\
8952 included in branch %s -- really re-apply it?" \
8953 [string range $rowmenuid 0 7] $mainhead]]
8956 nowbusy cherrypick [mc "Cherry-picking"]
8958 # Unfortunately git-cherry-pick writes stuff to stderr even when
8959 # no error occurs, and exec takes that as an indication of error...
8960 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8963 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8965 error_popup [mc "Cherry-pick failed because of local changes\
8966 to file '%s'.\nPlease commit, reset or stash\
8967 your changes and try again." $fname]
8968 } elseif {[regexp -line \
8969 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8971 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8972 conflict.\nDo you wish to run git citool to\
8974 # Force citool to read MERGE_MSG
8975 file delete [file join [gitdir] "GITGUI_MSG"]
8976 exec_citool {} $rowmenuid
8984 set newhead [exec git rev-parse HEAD]
8985 if {$newhead eq $oldhead} {
8987 error_popup [mc "No changes committed"]
8990 addnewchild $newhead $oldhead
8991 if {[commitinview $oldhead $curview]} {
8992 # XXX this isn't right if we have a path limit...
8993 insertrow $newhead $oldhead $curview
8994 if {$mainhead ne {}} {
8995 movehead $newhead $mainhead
8996 movedhead $newhead $mainhead
8998 set mainheadid $newhead
9007 global mainhead rowmenuid confirm_ok resettype NS
9010 set w ".confirmreset"
9013 wm title $w [mc "Confirm reset"]
9014 ${NS}::label $w.m -text \
9015 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9016 pack $w.m -side top -fill x -padx 20 -pady 20
9017 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9019 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9020 -text [mc "Soft: Leave working tree and index untouched"]
9021 grid $w.f.soft -sticky w
9022 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9023 -text [mc "Mixed: Leave working tree untouched, reset index"]
9024 grid $w.f.mixed -sticky w
9025 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9026 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9027 grid $w.f.hard -sticky w
9028 pack $w.f -side top -fill x -padx 4
9029 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9030 pack $w.ok -side left -fill x -padx 20 -pady 20
9031 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9032 bind $w <Key-Escape> [list destroy $w]
9033 pack $w.cancel -side right -fill x -padx 20 -pady 20
9034 bind $w <Visibility> "grab $w; focus $w"
9036 if {!$confirm_ok} return
9037 if {[catch {set fd [open \
9038 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9042 filerun $fd [list readresetstat $fd]
9043 nowbusy reset [mc "Resetting"]
9048 proc readresetstat {fd} {
9049 global mainhead mainheadid showlocalchanges rprogcoord
9051 if {[gets $fd line] >= 0} {
9052 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9053 set rprogcoord [expr {1.0 * $m / $n}]
9061 if {[catch {close $fd} err]} {
9064 set oldhead $mainheadid
9065 set newhead [exec git rev-parse HEAD]
9066 if {$newhead ne $oldhead} {
9067 movehead $newhead $mainhead
9068 movedhead $newhead $mainhead
9069 set mainheadid $newhead
9073 if {$showlocalchanges} {
9079 # context menu for a head
9080 proc headmenu {x y id head} {
9081 global headmenuid headmenuhead headctxmenu mainhead
9085 set headmenuhead $head
9087 if {[string match "remotes/*" $head]} {
9090 if {$head eq $mainhead} {
9093 $headctxmenu entryconfigure 0 -state $state
9094 $headctxmenu entryconfigure 1 -state $state
9095 tk_popup $headctxmenu $x $y
9099 global headmenuid headmenuhead headids
9100 global showlocalchanges
9102 # check the tree is clean first??
9103 nowbusy checkout [mc "Checking out"]
9107 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9111 if {$showlocalchanges} {
9115 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9119 proc readcheckoutstat {fd newhead newheadid} {
9120 global mainhead mainheadid headids showlocalchanges progresscoords
9121 global viewmainheadid curview
9123 if {[gets $fd line] >= 0} {
9124 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9125 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9130 set progresscoords {0 0}
9133 if {[catch {close $fd} err]} {
9136 set oldmainid $mainheadid
9137 set mainhead $newhead
9138 set mainheadid $newheadid
9139 set viewmainheadid($curview) $newheadid
9140 redrawtags $oldmainid
9141 redrawtags $newheadid
9143 if {$showlocalchanges} {
9149 global headmenuid headmenuhead mainhead
9152 set head $headmenuhead
9154 # this check shouldn't be needed any more...
9155 if {$head eq $mainhead} {
9156 error_popup [mc "Cannot delete the currently checked-out branch"]
9159 set dheads [descheads $id]
9160 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9161 # the stuff on this branch isn't on any other branch
9162 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9163 branch.\nReally delete branch %s?" $head $head]]} return
9167 if {[catch {exec git branch -D $head} err]} {
9172 removehead $id $head
9173 removedhead $id $head
9180 # Display a list of tags and heads
9182 global showrefstop bgcolor fgcolor selectbgcolor NS
9183 global bglist fglist reflistfilter reflist maincursor
9186 set showrefstop $top
9187 if {[winfo exists $top]} {
9193 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9194 make_transient $top .
9195 text $top.list -background $bgcolor -foreground $fgcolor \
9196 -selectbackground $selectbgcolor -font mainfont \
9197 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9198 -width 30 -height 20 -cursor $maincursor \
9199 -spacing1 1 -spacing3 1 -state disabled
9200 $top.list tag configure highlight -background $selectbgcolor
9201 lappend bglist $top.list
9202 lappend fglist $top.list
9203 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9204 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9205 grid $top.list $top.ysb -sticky nsew
9206 grid $top.xsb x -sticky ew
9208 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9209 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9210 set reflistfilter "*"
9211 trace add variable reflistfilter write reflistfilter_change
9212 pack $top.f.e -side right -fill x -expand 1
9213 pack $top.f.l -side left
9214 grid $top.f - -sticky ew -pady 2
9215 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9216 bind $top <Key-Escape> [list destroy $top]
9218 grid columnconfigure $top 0 -weight 1
9219 grid rowconfigure $top 0 -weight 1
9220 bind $top.list <1> {break}
9221 bind $top.list <B1-Motion> {break}
9222 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9227 proc sel_reflist {w x y} {
9228 global showrefstop reflist headids tagids otherrefids
9230 if {![winfo exists $showrefstop]} return
9231 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9232 set ref [lindex $reflist [expr {$l-1}]]
9233 set n [lindex $ref 0]
9234 switch -- [lindex $ref 1] {
9235 "H" {selbyid $headids($n)}
9236 "T" {selbyid $tagids($n)}
9237 "o" {selbyid $otherrefids($n)}
9239 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9242 proc unsel_reflist {} {
9245 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9246 $showrefstop.list tag remove highlight 0.0 end
9249 proc reflistfilter_change {n1 n2 op} {
9250 global reflistfilter
9252 after cancel refill_reflist
9253 after 200 refill_reflist
9256 proc refill_reflist {} {
9257 global reflist reflistfilter showrefstop headids tagids otherrefids
9260 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9262 foreach n [array names headids] {
9263 if {[string match $reflistfilter $n]} {
9264 if {[commitinview $headids($n) $curview]} {
9265 lappend refs [list $n H]
9267 interestedin $headids($n) {run refill_reflist}
9271 foreach n [array names tagids] {
9272 if {[string match $reflistfilter $n]} {
9273 if {[commitinview $tagids($n) $curview]} {
9274 lappend refs [list $n T]
9276 interestedin $tagids($n) {run refill_reflist}
9280 foreach n [array names otherrefids] {
9281 if {[string match $reflistfilter $n]} {
9282 if {[commitinview $otherrefids($n) $curview]} {
9283 lappend refs [list $n o]
9285 interestedin $otherrefids($n) {run refill_reflist}
9289 set refs [lsort -index 0 $refs]
9290 if {$refs eq $reflist} return
9292 # Update the contents of $showrefstop.list according to the
9293 # differences between $reflist (old) and $refs (new)
9294 $showrefstop.list conf -state normal
9295 $showrefstop.list insert end "\n"
9298 while {$i < [llength $reflist] || $j < [llength $refs]} {
9299 if {$i < [llength $reflist]} {
9300 if {$j < [llength $refs]} {
9301 set cmp [string compare [lindex $reflist $i 0] \
9302 [lindex $refs $j 0]]
9304 set cmp [string compare [lindex $reflist $i 1] \
9305 [lindex $refs $j 1]]
9315 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9323 set l [expr {$j + 1}]
9324 $showrefstop.list image create $l.0 -align baseline \
9325 -image reficon-[lindex $refs $j 1] -padx 2
9326 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9332 # delete last newline
9333 $showrefstop.list delete end-2c end-1c
9334 $showrefstop.list conf -state disabled
9337 # Stuff for finding nearby tags
9338 proc getallcommits {} {
9339 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9340 global idheads idtags idotherrefs allparents tagobjid
9342 if {![info exists allcommits]} {
9348 set allccache [file join [gitdir] "gitk.cache"]
9350 set f [open $allccache r]
9359 set cmd [list | git rev-list --parents]
9360 set allcupdate [expr {$seeds ne {}}]
9364 set refs [concat [array names idheads] [array names idtags] \
9365 [array names idotherrefs]]
9368 foreach name [array names tagobjid] {
9369 lappend tagobjs $tagobjid($name)
9371 foreach id [lsort -unique $refs] {
9372 if {![info exists allparents($id)] &&
9373 [lsearch -exact $tagobjs $id] < 0} {
9384 set fd [open [concat $cmd $ids] r]
9385 fconfigure $fd -blocking 0
9388 filerun $fd [list getallclines $fd]
9394 # Since most commits have 1 parent and 1 child, we group strings of
9395 # such commits into "arcs" joining branch/merge points (BMPs), which
9396 # are commits that either don't have 1 parent or don't have 1 child.
9398 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9399 # arcout(id) - outgoing arcs for BMP
9400 # arcids(a) - list of IDs on arc including end but not start
9401 # arcstart(a) - BMP ID at start of arc
9402 # arcend(a) - BMP ID at end of arc
9403 # growing(a) - arc a is still growing
9404 # arctags(a) - IDs out of arcids (excluding end) that have tags
9405 # archeads(a) - IDs out of arcids (excluding end) that have heads
9406 # The start of an arc is at the descendent end, so "incoming" means
9407 # coming from descendents, and "outgoing" means going towards ancestors.
9409 proc getallclines {fd} {
9410 global allparents allchildren idtags idheads nextarc
9411 global arcnos arcids arctags arcout arcend arcstart archeads growing
9412 global seeds allcommits cachedarcs allcupdate
9415 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9416 set id [lindex $line 0]
9417 if {[info exists allparents($id)]} {
9422 set olds [lrange $line 1 end]
9423 set allparents($id) $olds
9424 if {![info exists allchildren($id)]} {
9425 set allchildren($id) {}
9430 if {[llength $olds] == 1 && [llength $a] == 1} {
9431 lappend arcids($a) $id
9432 if {[info exists idtags($id)]} {
9433 lappend arctags($a) $id
9435 if {[info exists idheads($id)]} {
9436 lappend archeads($a) $id
9438 if {[info exists allparents($olds)]} {
9439 # seen parent already
9440 if {![info exists arcout($olds)]} {
9443 lappend arcids($a) $olds
9444 set arcend($a) $olds
9447 lappend allchildren($olds) $id
9448 lappend arcnos($olds) $a
9452 foreach a $arcnos($id) {
9453 lappend arcids($a) $id
9460 lappend allchildren($p) $id
9461 set a [incr nextarc]
9462 set arcstart($a) $id
9469 if {[info exists allparents($p)]} {
9470 # seen it already, may need to make a new branch
9471 if {![info exists arcout($p)]} {
9474 lappend arcids($a) $p
9478 lappend arcnos($p) $a
9483 global cached_dheads cached_dtags cached_atags
9484 catch {unset cached_dheads}
9485 catch {unset cached_dtags}
9486 catch {unset cached_atags}
9489 return [expr {$nid >= 1000? 2: 1}]
9493 fconfigure $fd -blocking 1
9496 # got an error reading the list of commits
9497 # if we were updating, try rereading the whole thing again
9503 error_popup "[mc "Error reading commit topology information;\
9504 branch and preceding/following tag information\
9505 will be incomplete."]\n($err)"
9508 if {[incr allcommits -1] == 0} {
9518 proc recalcarc {a} {
9519 global arctags archeads arcids idtags idheads
9523 foreach id [lrange $arcids($a) 0 end-1] {
9524 if {[info exists idtags($id)]} {
9527 if {[info exists idheads($id)]} {
9532 set archeads($a) $ah
9536 global arcnos arcids nextarc arctags archeads idtags idheads
9537 global arcstart arcend arcout allparents growing
9540 if {[llength $a] != 1} {
9541 puts "oops splitarc called but [llength $a] arcs already"
9545 set i [lsearch -exact $arcids($a) $p]
9547 puts "oops splitarc $p not in arc $a"
9550 set na [incr nextarc]
9551 if {[info exists arcend($a)]} {
9552 set arcend($na) $arcend($a)
9554 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9555 set j [lsearch -exact $arcnos($l) $a]
9556 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9558 set tail [lrange $arcids($a) [expr {$i+1}] end]
9559 set arcids($a) [lrange $arcids($a) 0 $i]
9561 set arcstart($na) $p
9563 set arcids($na) $tail
9564 if {[info exists growing($a)]} {
9570 if {[llength $arcnos($id)] == 1} {
9573 set j [lsearch -exact $arcnos($id) $a]
9574 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9578 # reconstruct tags and heads lists
9579 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9584 set archeads($na) {}
9588 # Update things for a new commit added that is a child of one
9589 # existing commit. Used when cherry-picking.
9590 proc addnewchild {id p} {
9591 global allparents allchildren idtags nextarc
9592 global arcnos arcids arctags arcout arcend arcstart archeads growing
9593 global seeds allcommits
9595 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9596 set allparents($id) [list $p]
9597 set allchildren($id) {}
9600 lappend allchildren($p) $id
9601 set a [incr nextarc]
9602 set arcstart($a) $id
9605 set arcids($a) [list $p]
9607 if {![info exists arcout($p)]} {
9610 lappend arcnos($p) $a
9611 set arcout($id) [list $a]
9614 # This implements a cache for the topology information.
9615 # The cache saves, for each arc, the start and end of the arc,
9616 # the ids on the arc, and the outgoing arcs from the end.
9617 proc readcache {f} {
9618 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9619 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9624 if {$lim - $a > 500} {
9625 set lim [expr {$a + 500}]
9629 # finish reading the cache and setting up arctags, etc.
9631 if {$line ne "1"} {error "bad final version"}
9633 foreach id [array names idtags] {
9634 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9635 [llength $allparents($id)] == 1} {
9636 set a [lindex $arcnos($id) 0]
9637 if {$arctags($a) eq {}} {
9642 foreach id [array names idheads] {
9643 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9644 [llength $allparents($id)] == 1} {
9645 set a [lindex $arcnos($id) 0]
9646 if {$archeads($a) eq {}} {
9651 foreach id [lsort -unique $possible_seeds] {
9652 if {$arcnos($id) eq {}} {
9658 while {[incr a] <= $lim} {
9660 if {[llength $line] != 3} {error "bad line"}
9661 set s [lindex $line 0]
9663 lappend arcout($s) $a
9664 if {![info exists arcnos($s)]} {
9665 lappend possible_seeds $s
9668 set e [lindex $line 1]
9673 if {![info exists arcout($e)]} {
9677 set arcids($a) [lindex $line 2]
9678 foreach id $arcids($a) {
9679 lappend allparents($s) $id
9681 lappend arcnos($id) $a
9683 if {![info exists allparents($s)]} {
9684 set allparents($s) {}
9689 set nextarc [expr {$a - 1}]
9702 global nextarc cachedarcs possible_seeds
9706 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9707 # make sure it's an integer
9708 set cachedarcs [expr {int([lindex $line 1])}]
9709 if {$cachedarcs < 0} {error "bad number of arcs"}
9711 set possible_seeds {}
9719 proc dropcache {err} {
9720 global allcwait nextarc cachedarcs seeds
9722 #puts "dropping cache ($err)"
9723 foreach v {arcnos arcout arcids arcstart arcend growing \
9724 arctags archeads allparents allchildren} {
9735 proc writecache {f} {
9736 global cachearc cachedarcs allccache
9737 global arcstart arcend arcnos arcids arcout
9741 if {$lim - $a > 1000} {
9742 set lim [expr {$a + 1000}]
9745 while {[incr a] <= $lim} {
9746 if {[info exists arcend($a)]} {
9747 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9749 puts $f [list $arcstart($a) {} $arcids($a)]
9754 catch {file delete $allccache}
9755 #puts "writing cache failed ($err)"
9758 set cachearc [expr {$a - 1}]
9759 if {$a > $cachedarcs} {
9768 global nextarc cachedarcs cachearc allccache
9770 if {$nextarc == $cachedarcs} return
9772 set cachedarcs $nextarc
9774 set f [open $allccache w]
9775 puts $f [list 1 $cachedarcs]
9780 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9781 # or 0 if neither is true.
9782 proc anc_or_desc {a b} {
9783 global arcout arcstart arcend arcnos cached_isanc
9785 if {$arcnos($a) eq $arcnos($b)} {
9786 # Both are on the same arc(s); either both are the same BMP,
9787 # or if one is not a BMP, the other is also not a BMP or is
9788 # the BMP at end of the arc (and it only has 1 incoming arc).
9789 # Or both can be BMPs with no incoming arcs.
9790 if {$a eq $b || $arcnos($a) eq {}} {
9793 # assert {[llength $arcnos($a)] == 1}
9794 set arc [lindex $arcnos($a) 0]
9795 set i [lsearch -exact $arcids($arc) $a]
9796 set j [lsearch -exact $arcids($arc) $b]
9797 if {$i < 0 || $i > $j} {
9804 if {![info exists arcout($a)]} {
9805 set arc [lindex $arcnos($a) 0]
9806 if {[info exists arcend($arc)]} {
9807 set aend $arcend($arc)
9811 set a $arcstart($arc)
9815 if {![info exists arcout($b)]} {
9816 set arc [lindex $arcnos($b) 0]
9817 if {[info exists arcend($arc)]} {
9818 set bend $arcend($arc)
9822 set b $arcstart($arc)
9832 if {[info exists cached_isanc($a,$bend)]} {
9833 if {$cached_isanc($a,$bend)} {
9837 if {[info exists cached_isanc($b,$aend)]} {
9838 if {$cached_isanc($b,$aend)} {
9841 if {[info exists cached_isanc($a,$bend)]} {
9846 set todo [list $a $b]
9849 for {set i 0} {$i < [llength $todo]} {incr i} {
9850 set x [lindex $todo $i]
9851 if {$anc($x) eq {}} {
9854 foreach arc $arcnos($x) {
9855 set xd $arcstart($arc)
9857 set cached_isanc($a,$bend) 1
9858 set cached_isanc($b,$aend) 0
9860 } elseif {$xd eq $aend} {
9861 set cached_isanc($b,$aend) 1
9862 set cached_isanc($a,$bend) 0
9865 if {![info exists anc($xd)]} {
9866 set anc($xd) $anc($x)
9868 } elseif {$anc($xd) ne $anc($x)} {
9873 set cached_isanc($a,$bend) 0
9874 set cached_isanc($b,$aend) 0
9878 # This identifies whether $desc has an ancestor that is
9879 # a growing tip of the graph and which is not an ancestor of $anc
9880 # and returns 0 if so and 1 if not.
9881 # If we subsequently discover a tag on such a growing tip, and that
9882 # turns out to be a descendent of $anc (which it could, since we
9883 # don't necessarily see children before parents), then $desc
9884 # isn't a good choice to display as a descendent tag of
9885 # $anc (since it is the descendent of another tag which is
9886 # a descendent of $anc). Similarly, $anc isn't a good choice to
9887 # display as a ancestor tag of $desc.
9889 proc is_certain {desc anc} {
9890 global arcnos arcout arcstart arcend growing problems
9893 if {[llength $arcnos($anc)] == 1} {
9894 # tags on the same arc are certain
9895 if {$arcnos($desc) eq $arcnos($anc)} {
9898 if {![info exists arcout($anc)]} {
9899 # if $anc is partway along an arc, use the start of the arc instead
9900 set a [lindex $arcnos($anc) 0]
9901 set anc $arcstart($a)
9904 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9907 set a [lindex $arcnos($desc) 0]
9913 set anclist [list $x]
9917 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9918 set x [lindex $anclist $i]
9923 foreach a $arcout($x) {
9924 if {[info exists growing($a)]} {
9925 if {![info exists growanc($x)] && $dl($x)} {
9931 if {[info exists dl($y)]} {
9935 if {![info exists done($y)]} {
9938 if {[info exists growanc($x)]} {
9942 for {set k 0} {$k < [llength $xl]} {incr k} {
9943 set z [lindex $xl $k]
9944 foreach c $arcout($z) {
9945 if {[info exists arcend($c)]} {
9947 if {[info exists dl($v)] && $dl($v)} {
9949 if {![info exists done($v)]} {
9952 if {[info exists growanc($v)]} {
9962 } elseif {$y eq $anc || !$dl($x)} {
9973 foreach x [array names growanc] {
9982 proc validate_arctags {a} {
9983 global arctags idtags
9987 foreach id $arctags($a) {
9989 if {![info exists idtags($id)]} {
9990 set na [lreplace $na $i $i]
9997 proc validate_archeads {a} {
9998 global archeads idheads
10001 set na $archeads($a)
10002 foreach id $archeads($a) {
10004 if {![info exists idheads($id)]} {
10005 set na [lreplace $na $i $i]
10009 set archeads($a) $na
10012 # Return the list of IDs that have tags that are descendents of id,
10013 # ignoring IDs that are descendents of IDs already reported.
10014 proc desctags {id} {
10015 global arcnos arcstart arcids arctags idtags allparents
10016 global growing cached_dtags
10018 if {![info exists allparents($id)]} {
10021 set t1 [clock clicks -milliseconds]
10023 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10024 # part-way along an arc; check that arc first
10025 set a [lindex $arcnos($id) 0]
10026 if {$arctags($a) ne {}} {
10027 validate_arctags $a
10028 set i [lsearch -exact $arcids($a) $id]
10030 foreach t $arctags($a) {
10031 set j [lsearch -exact $arcids($a) $t]
10032 if {$j >= $i} break
10039 set id $arcstart($a)
10040 if {[info exists idtags($id)]} {
10044 if {[info exists cached_dtags($id)]} {
10045 return $cached_dtags($id)
10049 set todo [list $id]
10052 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10053 set id [lindex $todo $i]
10055 set ta [info exists hastaggedancestor($id)]
10059 # ignore tags on starting node
10060 if {!$ta && $i > 0} {
10061 if {[info exists idtags($id)]} {
10062 set tagloc($id) $id
10064 } elseif {[info exists cached_dtags($id)]} {
10065 set tagloc($id) $cached_dtags($id)
10069 foreach a $arcnos($id) {
10070 set d $arcstart($a)
10071 if {!$ta && $arctags($a) ne {}} {
10072 validate_arctags $a
10073 if {$arctags($a) ne {}} {
10074 lappend tagloc($id) [lindex $arctags($a) end]
10077 if {$ta || $arctags($a) ne {}} {
10078 set tomark [list $d]
10079 for {set j 0} {$j < [llength $tomark]} {incr j} {
10080 set dd [lindex $tomark $j]
10081 if {![info exists hastaggedancestor($dd)]} {
10082 if {[info exists done($dd)]} {
10083 foreach b $arcnos($dd) {
10084 lappend tomark $arcstart($b)
10086 if {[info exists tagloc($dd)]} {
10089 } elseif {[info exists queued($dd)]} {
10092 set hastaggedancestor($dd) 1
10096 if {![info exists queued($d)]} {
10099 if {![info exists hastaggedancestor($d)]} {
10106 foreach id [array names tagloc] {
10107 if {![info exists hastaggedancestor($id)]} {
10108 foreach t $tagloc($id) {
10109 if {[lsearch -exact $tags $t] < 0} {
10115 set t2 [clock clicks -milliseconds]
10118 # remove tags that are descendents of other tags
10119 for {set i 0} {$i < [llength $tags]} {incr i} {
10120 set a [lindex $tags $i]
10121 for {set j 0} {$j < $i} {incr j} {
10122 set b [lindex $tags $j]
10123 set r [anc_or_desc $a $b]
10125 set tags [lreplace $tags $j $j]
10128 } elseif {$r == -1} {
10129 set tags [lreplace $tags $i $i]
10136 if {[array names growing] ne {}} {
10137 # graph isn't finished, need to check if any tag could get
10138 # eclipsed by another tag coming later. Simply ignore any
10139 # tags that could later get eclipsed.
10142 if {[is_certain $t $origid]} {
10146 if {$tags eq $ctags} {
10147 set cached_dtags($origid) $tags
10152 set cached_dtags($origid) $tags
10154 set t3 [clock clicks -milliseconds]
10155 if {0 && $t3 - $t1 >= 100} {
10156 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10157 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10162 proc anctags {id} {
10163 global arcnos arcids arcout arcend arctags idtags allparents
10164 global growing cached_atags
10166 if {![info exists allparents($id)]} {
10169 set t1 [clock clicks -milliseconds]
10171 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10172 # part-way along an arc; check that arc first
10173 set a [lindex $arcnos($id) 0]
10174 if {$arctags($a) ne {}} {
10175 validate_arctags $a
10176 set i [lsearch -exact $arcids($a) $id]
10177 foreach t $arctags($a) {
10178 set j [lsearch -exact $arcids($a) $t]
10184 if {![info exists arcend($a)]} {
10188 if {[info exists idtags($id)]} {
10192 if {[info exists cached_atags($id)]} {
10193 return $cached_atags($id)
10197 set todo [list $id]
10201 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10202 set id [lindex $todo $i]
10204 set td [info exists hastaggeddescendent($id)]
10208 # ignore tags on starting node
10209 if {!$td && $i > 0} {
10210 if {[info exists idtags($id)]} {
10211 set tagloc($id) $id
10213 } elseif {[info exists cached_atags($id)]} {
10214 set tagloc($id) $cached_atags($id)
10218 foreach a $arcout($id) {
10219 if {!$td && $arctags($a) ne {}} {
10220 validate_arctags $a
10221 if {$arctags($a) ne {}} {
10222 lappend tagloc($id) [lindex $arctags($a) 0]
10225 if {![info exists arcend($a)]} continue
10227 if {$td || $arctags($a) ne {}} {
10228 set tomark [list $d]
10229 for {set j 0} {$j < [llength $tomark]} {incr j} {
10230 set dd [lindex $tomark $j]
10231 if {![info exists hastaggeddescendent($dd)]} {
10232 if {[info exists done($dd)]} {
10233 foreach b $arcout($dd) {
10234 if {[info exists arcend($b)]} {
10235 lappend tomark $arcend($b)
10238 if {[info exists tagloc($dd)]} {
10241 } elseif {[info exists queued($dd)]} {
10244 set hastaggeddescendent($dd) 1
10248 if {![info exists queued($d)]} {
10251 if {![info exists hastaggeddescendent($d)]} {
10257 set t2 [clock clicks -milliseconds]
10260 foreach id [array names tagloc] {
10261 if {![info exists hastaggeddescendent($id)]} {
10262 foreach t $tagloc($id) {
10263 if {[lsearch -exact $tags $t] < 0} {
10270 # remove tags that are ancestors of other tags
10271 for {set i 0} {$i < [llength $tags]} {incr i} {
10272 set a [lindex $tags $i]
10273 for {set j 0} {$j < $i} {incr j} {
10274 set b [lindex $tags $j]
10275 set r [anc_or_desc $a $b]
10277 set tags [lreplace $tags $j $j]
10280 } elseif {$r == 1} {
10281 set tags [lreplace $tags $i $i]
10288 if {[array names growing] ne {}} {
10289 # graph isn't finished, need to check if any tag could get
10290 # eclipsed by another tag coming later. Simply ignore any
10291 # tags that could later get eclipsed.
10294 if {[is_certain $origid $t]} {
10298 if {$tags eq $ctags} {
10299 set cached_atags($origid) $tags
10304 set cached_atags($origid) $tags
10306 set t3 [clock clicks -milliseconds]
10307 if {0 && $t3 - $t1 >= 100} {
10308 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10309 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10314 # Return the list of IDs that have heads that are descendents of id,
10315 # including id itself if it has a head.
10316 proc descheads {id} {
10317 global arcnos arcstart arcids archeads idheads cached_dheads
10320 if {![info exists allparents($id)]} {
10324 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10325 # part-way along an arc; check it first
10326 set a [lindex $arcnos($id) 0]
10327 if {$archeads($a) ne {}} {
10328 validate_archeads $a
10329 set i [lsearch -exact $arcids($a) $id]
10330 foreach t $archeads($a) {
10331 set j [lsearch -exact $arcids($a) $t]
10336 set id $arcstart($a)
10339 set todo [list $id]
10342 for {set i 0} {$i < [llength $todo]} {incr i} {
10343 set id [lindex $todo $i]
10344 if {[info exists cached_dheads($id)]} {
10345 set ret [concat $ret $cached_dheads($id)]
10347 if {[info exists idheads($id)]} {
10350 foreach a $arcnos($id) {
10351 if {$archeads($a) ne {}} {
10352 validate_archeads $a
10353 if {$archeads($a) ne {}} {
10354 set ret [concat $ret $archeads($a)]
10357 set d $arcstart($a)
10358 if {![info exists seen($d)]} {
10365 set ret [lsort -unique $ret]
10366 set cached_dheads($origid) $ret
10367 return [concat $ret $aret]
10370 proc addedtag {id} {
10371 global arcnos arcout cached_dtags cached_atags
10373 if {![info exists arcnos($id)]} return
10374 if {![info exists arcout($id)]} {
10375 recalcarc [lindex $arcnos($id) 0]
10377 catch {unset cached_dtags}
10378 catch {unset cached_atags}
10381 proc addedhead {hid head} {
10382 global arcnos arcout cached_dheads
10384 if {![info exists arcnos($hid)]} return
10385 if {![info exists arcout($hid)]} {
10386 recalcarc [lindex $arcnos($hid) 0]
10388 catch {unset cached_dheads}
10391 proc removedhead {hid head} {
10392 global cached_dheads
10394 catch {unset cached_dheads}
10397 proc movedhead {hid head} {
10398 global arcnos arcout cached_dheads
10400 if {![info exists arcnos($hid)]} return
10401 if {![info exists arcout($hid)]} {
10402 recalcarc [lindex $arcnos($hid) 0]
10404 catch {unset cached_dheads}
10407 proc changedrefs {} {
10408 global cached_dheads cached_dtags cached_atags
10409 global arctags archeads arcnos arcout idheads idtags
10411 foreach id [concat [array names idheads] [array names idtags]] {
10412 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10413 set a [lindex $arcnos($id) 0]
10414 if {![info exists donearc($a)]} {
10420 catch {unset cached_dtags}
10421 catch {unset cached_atags}
10422 catch {unset cached_dheads}
10425 proc rereadrefs {} {
10426 global idtags idheads idotherrefs mainheadid
10428 set refids [concat [array names idtags] \
10429 [array names idheads] [array names idotherrefs]]
10430 foreach id $refids {
10431 if {![info exists ref($id)]} {
10432 set ref($id) [listrefs $id]
10435 set oldmainhead $mainheadid
10438 set refids [lsort -unique [concat $refids [array names idtags] \
10439 [array names idheads] [array names idotherrefs]]]
10440 foreach id $refids {
10441 set v [listrefs $id]
10442 if {![info exists ref($id)] || $ref($id) != $v} {
10446 if {$oldmainhead ne $mainheadid} {
10447 redrawtags $oldmainhead
10448 redrawtags $mainheadid
10453 proc listrefs {id} {
10454 global idtags idheads idotherrefs
10457 if {[info exists idtags($id)]} {
10461 if {[info exists idheads($id)]} {
10462 set y $idheads($id)
10465 if {[info exists idotherrefs($id)]} {
10466 set z $idotherrefs($id)
10468 return [list $x $y $z]
10471 proc showtag {tag isnew} {
10472 global ctext tagcontents tagids linknum tagobjid
10475 addtohistory [list showtag $tag 0] savectextpos
10477 $ctext conf -state normal
10481 if {![info exists tagcontents($tag)]} {
10483 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
10486 if {[info exists tagcontents($tag)]} {
10487 set text $tagcontents($tag)
10489 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10491 appendwithlinks $text {}
10492 maybe_scroll_ctext 1
10493 $ctext conf -state disabled
10505 if {[info exists gitktmpdir]} {
10506 catch {file delete -force $gitktmpdir}
10510 proc mkfontdisp {font top which} {
10511 global fontattr fontpref $font NS use_ttk
10513 set fontpref($font) [set $font]
10514 ${NS}::button $top.${font}but -text $which \
10515 -command [list choosefont $font $which]
10516 if {!$use_ttk} {$top.${font}but configure -font optionfont}
10517 ${NS}::label $top.$font -relief flat -font $font \
10518 -text $fontattr($font,family) -justify left
10519 grid x $top.${font}but $top.$font -sticky w
10522 proc choosefont {font which} {
10523 global fontparam fontlist fonttop fontattr
10526 set fontparam(which) $which
10527 set fontparam(font) $font
10528 set fontparam(family) [font actual $font -family]
10529 set fontparam(size) $fontattr($font,size)
10530 set fontparam(weight) $fontattr($font,weight)
10531 set fontparam(slant) $fontattr($font,slant)
10534 if {![winfo exists $top]} {
10536 eval font config sample [font actual $font]
10538 make_transient $top $prefstop
10539 wm title $top [mc "Gitk font chooser"]
10540 ${NS}::label $top.l -textvariable fontparam(which)
10541 pack $top.l -side top
10542 set fontlist [lsort [font families]]
10543 ${NS}::frame $top.f
10544 listbox $top.f.fam -listvariable fontlist \
10545 -yscrollcommand [list $top.f.sb set]
10546 bind $top.f.fam <<ListboxSelect>> selfontfam
10547 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10548 pack $top.f.sb -side right -fill y
10549 pack $top.f.fam -side left -fill both -expand 1
10550 pack $top.f -side top -fill both -expand 1
10551 ${NS}::frame $top.g
10552 spinbox $top.g.size -from 4 -to 40 -width 4 \
10553 -textvariable fontparam(size) \
10554 -validatecommand {string is integer -strict %s}
10555 checkbutton $top.g.bold -padx 5 \
10556 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10557 -variable fontparam(weight) -onvalue bold -offvalue normal
10558 checkbutton $top.g.ital -padx 5 \
10559 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10560 -variable fontparam(slant) -onvalue italic -offvalue roman
10561 pack $top.g.size $top.g.bold $top.g.ital -side left
10562 pack $top.g -side top
10563 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10565 $top.c create text 100 25 -anchor center -text $which -font sample \
10566 -fill black -tags text
10567 bind $top.c <Configure> [list centertext $top.c]
10568 pack $top.c -side top -fill x
10569 ${NS}::frame $top.buts
10570 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10571 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10572 bind $top <Key-Return> fontok
10573 bind $top <Key-Escape> fontcan
10574 grid $top.buts.ok $top.buts.can
10575 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10576 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10577 pack $top.buts -side bottom -fill x
10578 trace add variable fontparam write chg_fontparam
10581 $top.c itemconf text -text $which
10583 set i [lsearch -exact $fontlist $fontparam(family)]
10585 $top.f.fam selection set $i
10590 proc centertext {w} {
10591 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10595 global fontparam fontpref prefstop
10597 set f $fontparam(font)
10598 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10599 if {$fontparam(weight) eq "bold"} {
10600 lappend fontpref($f) "bold"
10602 if {$fontparam(slant) eq "italic"} {
10603 lappend fontpref($f) "italic"
10606 $w conf -text $fontparam(family) -font $fontpref($f)
10612 global fonttop fontparam
10614 if {[info exists fonttop]} {
10615 catch {destroy $fonttop}
10616 catch {font delete sample}
10622 if {[package vsatisfies [package provide Tk] 8.6]} {
10623 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10624 # function to make use of it.
10625 proc choosefont {font which} {
10626 tk fontchooser configure -title $which -font $font \
10627 -command [list on_choosefont $font $which]
10628 tk fontchooser show
10630 proc on_choosefont {font which newfont} {
10632 puts stderr "$font $newfont"
10633 array set f [font actual $newfont]
10634 set fontparam(which) $which
10635 set fontparam(font) $font
10636 set fontparam(family) $f(-family)
10637 set fontparam(size) $f(-size)
10638 set fontparam(weight) $f(-weight)
10639 set fontparam(slant) $f(-slant)
10644 proc selfontfam {} {
10645 global fonttop fontparam
10647 set i [$fonttop.f.fam curselection]
10649 set fontparam(family) [$fonttop.f.fam get $i]
10653 proc chg_fontparam {v sub op} {
10656 font config sample -$sub $fontparam($sub)
10660 global maxwidth maxgraphpct use_ttk NS
10661 global oldprefs prefstop showneartags showlocalchanges
10662 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10663 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10664 global hideremotes want_ttk have_ttk
10668 if {[winfo exists $top]} {
10672 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10673 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10674 set oldprefs($v) [set $v]
10677 wm title $top [mc "Gitk preferences"]
10678 make_transient $top .
10679 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10680 grid $top.ldisp - -sticky w -pady 10
10681 ${NS}::label $top.spacer -text " "
10682 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10683 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10684 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10685 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10686 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10687 grid x $top.maxpctl $top.maxpct -sticky w
10688 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10689 -variable showlocalchanges
10690 grid x $top.showlocal -sticky w
10691 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10692 -variable autoselect
10693 grid x $top.autoselect -sticky w
10694 ${NS}::checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10695 -variable hideremotes
10696 grid x $top.hideremotes -sticky w
10698 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10699 grid $top.ddisp - -sticky w -pady 10
10700 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10701 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10702 grid x $top.tabstopl $top.tabstop -sticky w
10703 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10704 -variable showneartags
10705 grid x $top.ntag -sticky w
10706 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10707 -variable limitdiffs
10708 grid x $top.ldiff -sticky w
10709 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10710 -variable perfile_attrs
10711 grid x $top.lattr -sticky w
10713 ${NS}::entry $top.extdifft -textvariable extdifftool
10714 ${NS}::frame $top.extdifff
10715 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10716 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10717 pack $top.extdifff.l $top.extdifff.b -side left
10718 pack configure $top.extdifff.l -padx 10
10719 grid x $top.extdifff $top.extdifft -sticky ew
10721 ${NS}::label $top.lgen -text [mc "General options"]
10722 grid $top.lgen - -sticky w -pady 10
10723 ${NS}::checkbutton $top.want_ttk -variable want_ttk \
10724 -text [mc "Use themed widgets"]
10726 ${NS}::label $top.ttk_note -text [mc "(change requires restart)"]
10728 ${NS}::label $top.ttk_note -text [mc "(currently unavailable)"]
10730 grid x $top.want_ttk $top.ttk_note -sticky w
10732 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10733 grid $top.cdisp - -sticky w -pady 10
10734 label $top.ui -padx 40 -relief sunk -background $uicolor
10735 ${NS}::button $top.uibut -text [mc "Interface"] \
10736 -command [list choosecolor uicolor {} $top.ui [mc "interface"] setui]
10737 grid x $top.uibut $top.ui -sticky w
10738 label $top.bg -padx 40 -relief sunk -background $bgcolor
10739 ${NS}::button $top.bgbut -text [mc "Background"] \
10740 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10741 grid x $top.bgbut $top.bg -sticky w
10742 label $top.fg -padx 40 -relief sunk -background $fgcolor
10743 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10744 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10745 grid x $top.fgbut $top.fg -sticky w
10746 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10747 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10748 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10749 [list $ctext tag conf d0 -foreground]]
10750 grid x $top.diffoldbut $top.diffold -sticky w
10751 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10752 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10753 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10754 [list $ctext tag conf dresult -foreground]]
10755 grid x $top.diffnewbut $top.diffnew -sticky w
10756 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10757 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10758 -command [list choosecolor diffcolors 2 $top.hunksep \
10759 [mc "diff hunk header"] \
10760 [list $ctext tag conf hunksep -foreground]]
10761 grid x $top.hunksepbut $top.hunksep -sticky w
10762 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10763 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10764 -command [list choosecolor markbgcolor {} $top.markbgsep \
10765 [mc "marked line background"] \
10766 [list $ctext tag conf omark -background]]
10767 grid x $top.markbgbut $top.markbgsep -sticky w
10768 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10769 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10770 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10771 grid x $top.selbgbut $top.selbgsep -sticky w
10773 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10774 grid $top.cfont - -sticky w -pady 10
10775 mkfontdisp mainfont $top [mc "Main font"]
10776 mkfontdisp textfont $top [mc "Diff display font"]
10777 mkfontdisp uifont $top [mc "User interface font"]
10780 foreach w {maxpctl maxwidthl showlocal autoselect tabstopl ntag
10781 ldiff lattr extdifff.l extdifff.b bgbut fgbut
10782 diffoldbut diffnewbut hunksepbut markbgbut selbgbut
10783 want_ttk ttk_note} {
10784 $top.$w configure -font optionfont
10788 ${NS}::frame $top.buts
10789 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10790 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10791 bind $top <Key-Return> prefsok
10792 bind $top <Key-Escape> prefscan
10793 grid $top.buts.ok $top.buts.can
10794 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10795 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10796 grid $top.buts - - -pady 10 -sticky ew
10797 grid columnconfigure $top 2 -weight 1
10798 bind $top <Visibility> "focus $top.buts.ok"
10801 proc choose_extdiff {} {
10804 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10806 set extdifftool $prog
10810 proc choosecolor {v vi w x cmd} {
10813 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10814 -title [mc "Gitk: choose color for %s" $x]]
10815 if {$c eq {}} return
10816 $w conf -background $c
10821 proc setselbg {c} {
10822 global bglist cflist
10823 foreach w $bglist {
10824 $w configure -selectbackground $c
10826 $cflist tag configure highlight \
10827 -background [$cflist cget -selectbackground]
10828 allcanvs itemconf secsel -fill $c
10831 # This sets the background color and the color scheme for the whole UI.
10832 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
10833 # if we don't specify one ourselves, which makes the checkbuttons and
10834 # radiobuttons look bad. This chooses white for selectColor if the
10835 # background color is light, or black if it is dark.
10837 set bg [winfo rgb . $c]
10839 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
10842 tk_setPalette background $c selectColor $selc
10848 foreach w $bglist {
10849 $w conf -background $c
10856 foreach w $fglist {
10857 $w conf -foreground $c
10859 allcanvs itemconf text -fill $c
10860 $canv itemconf circle -outline $c
10861 $canv itemconf markid -outline $c
10865 global oldprefs prefstop
10867 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10868 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10870 set $v $oldprefs($v)
10872 catch {destroy $prefstop}
10878 global maxwidth maxgraphpct
10879 global oldprefs prefstop showneartags showlocalchanges
10880 global fontpref mainfont textfont uifont
10881 global limitdiffs treediffs perfile_attrs
10884 catch {destroy $prefstop}
10888 if {$mainfont ne $fontpref(mainfont)} {
10889 set mainfont $fontpref(mainfont)
10890 parsefont mainfont $mainfont
10891 eval font configure mainfont [fontflags mainfont]
10892 eval font configure mainfontbold [fontflags mainfont 1]
10896 if {$textfont ne $fontpref(textfont)} {
10897 set textfont $fontpref(textfont)
10898 parsefont textfont $textfont
10899 eval font configure textfont [fontflags textfont]
10900 eval font configure textfontbold [fontflags textfont 1]
10902 if {$uifont ne $fontpref(uifont)} {
10903 set uifont $fontpref(uifont)
10904 parsefont uifont $uifont
10905 eval font configure uifont [fontflags uifont]
10908 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10909 if {$showlocalchanges} {
10915 if {$limitdiffs != $oldprefs(limitdiffs) ||
10916 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10917 # treediffs elements are limited by path;
10918 # won't have encodings cached if perfile_attrs was just turned on
10919 catch {unset treediffs}
10921 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10922 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10924 } elseif {$showneartags != $oldprefs(showneartags) ||
10925 $limitdiffs != $oldprefs(limitdiffs)} {
10928 if {$hideremotes != $oldprefs(hideremotes)} {
10933 proc formatdate {d} {
10934 global datetimeformat
10936 set d [clock format $d -format $datetimeformat]
10941 # This list of encoding names and aliases is distilled from
10942 # http://www.iana.org/assignments/character-sets.
10943 # Not all of them are supported by Tcl.
10944 set encoding_aliases {
10945 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10946 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10947 { ISO-10646-UTF-1 csISO10646UTF1 }
10948 { ISO_646.basic:1983 ref csISO646basic1983 }
10949 { INVARIANT csINVARIANT }
10950 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10951 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10952 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10953 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10954 { NATS-DANO iso-ir-9-1 csNATSDANO }
10955 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10956 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10957 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10958 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10959 { ISO-2022-KR csISO2022KR }
10961 { ISO-2022-JP csISO2022JP }
10962 { ISO-2022-JP-2 csISO2022JP2 }
10963 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10964 csISO13JISC6220jp }
10965 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10966 { IT iso-ir-15 ISO646-IT csISO15Italian }
10967 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10968 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10969 { greek7-old iso-ir-18 csISO18Greek7Old }
10970 { latin-greek iso-ir-19 csISO19LatinGreek }
10971 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10972 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10973 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10974 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10975 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10976 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10977 { INIS iso-ir-49 csISO49INIS }
10978 { INIS-8 iso-ir-50 csISO50INIS8 }
10979 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10980 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10981 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10982 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10983 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10984 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10985 csISO60Norwegian1 }
10986 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10987 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10988 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10989 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10990 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10991 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10992 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10993 { greek7 iso-ir-88 csISO88Greek7 }
10994 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10995 { iso-ir-90 csISO90 }
10996 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10997 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10998 csISO92JISC62991984b }
10999 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11000 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11001 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11002 csISO95JIS62291984handadd }
11003 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11004 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11005 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11006 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11007 CP819 csISOLatin1 }
11008 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11009 { T.61-7bit iso-ir-102 csISO102T617bit }
11010 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11011 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11012 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11013 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11014 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11015 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11016 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11017 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11018 arabic csISOLatinArabic }
11019 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11020 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11021 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11022 greek greek8 csISOLatinGreek }
11023 { T.101-G2 iso-ir-128 csISO128T101G2 }
11024 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11026 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11027 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11028 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11029 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11030 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11031 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11032 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11033 csISOLatinCyrillic }
11034 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11035 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11036 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11037 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11038 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11039 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11040 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11041 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11042 { ISO_10367-box iso-ir-155 csISO10367Box }
11043 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11044 { latin-lap lap iso-ir-158 csISO158Lap }
11045 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11046 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11049 { JIS_X0201 X0201 csHalfWidthKatakana }
11050 { KSC5636 ISO646-KR csKSC5636 }
11051 { ISO-10646-UCS-2 csUnicode }
11052 { ISO-10646-UCS-4 csUCS4 }
11053 { DEC-MCS dec csDECMCS }
11054 { hp-roman8 roman8 r8 csHPRoman8 }
11055 { macintosh mac csMacintosh }
11056 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11058 { IBM038 EBCDIC-INT cp038 csIBM038 }
11059 { IBM273 CP273 csIBM273 }
11060 { IBM274 EBCDIC-BE CP274 csIBM274 }
11061 { IBM275 EBCDIC-BR cp275 csIBM275 }
11062 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11063 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11064 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11065 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11066 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11067 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11068 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11069 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11070 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11071 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11072 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11073 { IBM437 cp437 437 csPC8CodePage437 }
11074 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11075 { IBM775 cp775 csPC775Baltic }
11076 { IBM850 cp850 850 csPC850Multilingual }
11077 { IBM851 cp851 851 csIBM851 }
11078 { IBM852 cp852 852 csPCp852 }
11079 { IBM855 cp855 855 csIBM855 }
11080 { IBM857 cp857 857 csIBM857 }
11081 { IBM860 cp860 860 csIBM860 }
11082 { IBM861 cp861 861 cp-is csIBM861 }
11083 { IBM862 cp862 862 csPC862LatinHebrew }
11084 { IBM863 cp863 863 csIBM863 }
11085 { IBM864 cp864 csIBM864 }
11086 { IBM865 cp865 865 csIBM865 }
11087 { IBM866 cp866 866 csIBM866 }
11088 { IBM868 CP868 cp-ar csIBM868 }
11089 { IBM869 cp869 869 cp-gr csIBM869 }
11090 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11091 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11092 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11093 { IBM891 cp891 csIBM891 }
11094 { IBM903 cp903 csIBM903 }
11095 { IBM904 cp904 904 csIBBM904 }
11096 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11097 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11098 { IBM1026 CP1026 csIBM1026 }
11099 { EBCDIC-AT-DE csIBMEBCDICATDE }
11100 { EBCDIC-AT-DE-A csEBCDICATDEA }
11101 { EBCDIC-CA-FR csEBCDICCAFR }
11102 { EBCDIC-DK-NO csEBCDICDKNO }
11103 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11104 { EBCDIC-FI-SE csEBCDICFISE }
11105 { EBCDIC-FI-SE-A csEBCDICFISEA }
11106 { EBCDIC-FR csEBCDICFR }
11107 { EBCDIC-IT csEBCDICIT }
11108 { EBCDIC-PT csEBCDICPT }
11109 { EBCDIC-ES csEBCDICES }
11110 { EBCDIC-ES-A csEBCDICESA }
11111 { EBCDIC-ES-S csEBCDICESS }
11112 { EBCDIC-UK csEBCDICUK }
11113 { EBCDIC-US csEBCDICUS }
11114 { UNKNOWN-8BIT csUnknown8BiT }
11115 { MNEMONIC csMnemonic }
11117 { VISCII csVISCII }
11120 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11121 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11122 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11123 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11124 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11125 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11126 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11127 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11128 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11129 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11130 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11131 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11132 { IBM1047 IBM-1047 }
11133 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11134 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11135 { UNICODE-1-1 csUnicode11 }
11136 { CESU-8 csCESU-8 }
11137 { BOCU-1 csBOCU-1 }
11138 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11139 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11141 { ISO-8859-15 ISO_8859-15 Latin-9 }
11142 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11143 { GBK CP936 MS936 windows-936 }
11144 { JIS_Encoding csJISEncoding }
11145 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11146 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11148 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11149 { ISO-10646-UCS-Basic csUnicodeASCII }
11150 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11151 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11152 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11153 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11154 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11155 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11156 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11157 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11158 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11159 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11160 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11161 { Ventura-US csVenturaUS }
11162 { Ventura-International csVenturaInternational }
11163 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11164 { PC8-Turkish csPC8Turkish }
11165 { IBM-Symbols csIBMSymbols }
11166 { IBM-Thai csIBMThai }
11167 { HP-Legal csHPLegal }
11168 { HP-Pi-font csHPPiFont }
11169 { HP-Math8 csHPMath8 }
11170 { Adobe-Symbol-Encoding csHPPSMath }
11171 { HP-DeskTop csHPDesktop }
11172 { Ventura-Math csVenturaMath }
11173 { Microsoft-Publishing csMicrosoftPublishing }
11174 { Windows-31J csWindows31J }
11175 { GB2312 csGB2312 }
11179 proc tcl_encoding {enc} {
11180 global encoding_aliases tcl_encoding_cache
11181 if {[info exists tcl_encoding_cache($enc)]} {
11182 return $tcl_encoding_cache($enc)
11184 set names [encoding names]
11185 set lcnames [string tolower $names]
11186 set enc [string tolower $enc]
11187 set i [lsearch -exact $lcnames $enc]
11189 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11190 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11191 set i [lsearch -exact $lcnames $encx]
11195 foreach l $encoding_aliases {
11196 set ll [string tolower $l]
11197 if {[lsearch -exact $ll $enc] < 0} continue
11198 # look through the aliases for one that tcl knows about
11200 set i [lsearch -exact $lcnames $e]
11202 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11203 set i [lsearch -exact $lcnames $ex]
11213 set tclenc [lindex $names $i]
11215 set tcl_encoding_cache($enc) $tclenc
11219 proc gitattr {path attr default} {
11220 global path_attr_cache
11221 if {[info exists path_attr_cache($attr,$path)]} {
11222 set r $path_attr_cache($attr,$path)
11224 set r "unspecified"
11225 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11226 regexp "(.*): $attr: (.*)" $line m f r
11228 set path_attr_cache($attr,$path) $r
11230 if {$r eq "unspecified"} {
11236 proc cache_gitattr {attr pathlist} {
11237 global path_attr_cache
11239 foreach path $pathlist {
11240 if {![info exists path_attr_cache($attr,$path)]} {
11241 lappend newlist $path
11245 if {[tk windowingsystem] == "win32"} {
11246 # windows has a 32k limit on the arguments to a command...
11249 while {$newlist ne {}} {
11250 set head [lrange $newlist 0 [expr {$lim - 1}]]
11251 set newlist [lrange $newlist $lim end]
11252 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11253 foreach row [split $rlist "\n"] {
11254 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11255 if {[string index $path 0] eq "\""} {
11256 set path [encoding convertfrom [lindex $path 0]]
11258 set path_attr_cache($attr,$path) $value
11265 proc get_path_encoding {path} {
11266 global gui_encoding perfile_attrs
11267 set tcl_enc $gui_encoding
11268 if {$path ne {} && $perfile_attrs} {
11269 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11277 # First check that Tcl/Tk is recent enough
11278 if {[catch {package require Tk 8.4} err]} {
11279 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11280 Gitk requires at least Tcl/Tk 8.4." list
11285 set wrcomcmd "git diff-tree --stdin -p --pretty"
11289 set gitencoding [exec git config --get i18n.commitencoding]
11292 set gitencoding [exec git config --get i18n.logoutputencoding]
11294 if {$gitencoding == ""} {
11295 set gitencoding "utf-8"
11297 set tclencoding [tcl_encoding $gitencoding]
11298 if {$tclencoding == {}} {
11299 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11302 set gui_encoding [encoding system]
11304 set enc [exec git config --get gui.encoding]
11306 set tclenc [tcl_encoding $enc]
11307 if {$tclenc ne {}} {
11308 set gui_encoding $tclenc
11310 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11315 if {[tk windowingsystem] eq "aqua"} {
11316 set mainfont {{Lucida Grande} 9}
11317 set textfont {Monaco 9}
11318 set uifont {{Lucida Grande} 9 bold}
11320 set mainfont {Helvetica 9}
11321 set textfont {Courier 9}
11322 set uifont {Helvetica 9 bold}
11325 set findmergefiles 0
11333 set cmitmode "patch"
11334 set wrapcomment "none"
11339 set showlocalchanges 1
11341 set datetimeformat "%Y-%m-%d %H:%M:%S"
11343 set perfile_attrs 0
11346 if {[tk windowingsystem] eq "aqua"} {
11347 set extdifftool "opendiff"
11349 set extdifftool "meld"
11352 set colors {green red blue magenta darkgrey brown orange}
11353 if {[tk windowingsystem] eq "win32"} {
11354 set uicolor SystemButtonFace
11355 set bgcolor SystemWindow
11356 set fgcolor SystemButtonText
11357 set selectbgcolor SystemHighlight
11362 set selectbgcolor gray85
11364 set diffcolors {red "#00a000" blue}
11367 set markbgcolor "#e0e0ff"
11369 set circlecolors {white blue gray blue blue}
11371 # button for popping up context menus
11372 if {[tk windowingsystem] eq "aqua"} {
11373 set ctxbut <Button-2>
11375 set ctxbut <Button-3>
11378 ## For msgcat loading, first locate the installation location.
11379 if { [info exists ::env(GITK_MSGSDIR)] } {
11380 ## Msgsdir was manually set in the environment.
11381 set gitk_msgsdir $::env(GITK_MSGSDIR)
11383 ## Let's guess the prefix from argv0.
11384 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11385 set gitk_libdir [file join $gitk_prefix share gitk lib]
11386 set gitk_msgsdir [file join $gitk_libdir msgs]
11390 ## Internationalization (i18n) through msgcat and gettext. See
11391 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11392 package require msgcat
11393 namespace import ::msgcat::mc
11394 ## And eventually load the actual message catalog
11395 ::msgcat::mcload $gitk_msgsdir
11397 catch {source ~/.gitk}
11399 font create optionfont -family sans-serif -size -12
11401 parsefont mainfont $mainfont
11402 eval font create mainfont [fontflags mainfont]
11403 eval font create mainfontbold [fontflags mainfont 1]
11405 parsefont textfont $textfont
11406 eval font create textfont [fontflags textfont]
11407 eval font create textfontbold [fontflags textfont 1]
11409 parsefont uifont $uifont
11410 eval font create uifont [fontflags uifont]
11416 # check that we can find a .git directory somewhere...
11417 if {[catch {set gitdir [gitdir]}]} {
11418 show_error {} . [mc "Cannot find a git repository here."]
11421 if {![file isdirectory $gitdir]} {
11422 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11427 set selectheadid {}
11430 set cmdline_files {}
11432 set revtreeargscmd {}
11433 foreach arg $argv {
11434 switch -glob -- $arg {
11437 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11440 "--select-commit=*" {
11441 set selecthead [string range $arg 16 end]
11444 set revtreeargscmd [string range $arg 10 end]
11447 lappend revtreeargs $arg
11453 if {$selecthead eq "HEAD"} {
11457 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11458 # no -- on command line, but some arguments (other than --argscmd)
11460 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11461 set cmdline_files [split $f "\n"]
11462 set n [llength $cmdline_files]
11463 set revtreeargs [lrange $revtreeargs 0 end-$n]
11464 # Unfortunately git rev-parse doesn't produce an error when
11465 # something is both a revision and a filename. To be consistent
11466 # with git log and git rev-list, check revtreeargs for filenames.
11467 foreach arg $revtreeargs {
11468 if {[file exists $arg]} {
11469 show_error {} . [mc "Ambiguous argument '%s': both revision\
11470 and filename" $arg]
11475 # unfortunately we get both stdout and stderr in $err,
11476 # so look for "fatal:".
11477 set i [string first "fatal:" $err]
11479 set err [string range $err [expr {$i + 6}] end]
11481 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11486 set nullid "0000000000000000000000000000000000000000"
11487 set nullid2 "0000000000000000000000000000000000000001"
11488 set nullfile "/dev/null"
11490 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11491 if {![info exists have_ttk]} {
11492 set have_ttk [llength [info commands ::ttk::style]]
11494 set use_ttk [expr {$have_ttk && $want_ttk}]
11495 set NS [expr {$use_ttk ? "ttk" : ""}]
11497 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11504 set highlight_paths {}
11506 set searchdirn -forwards
11509 set diffelide {0 0}
11510 set markingmatches 0
11511 set linkentercount 0
11512 set need_redisplay 0
11519 set selectedhlview [mc "None"]
11520 set highlight_related [mc "None"]
11521 set highlight_files {}
11522 set viewfiles(0) {}
11525 set viewargscmd(0) {}
11527 set selectedline {}
11535 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11539 image create photo gitlogo -width 16 -height 16
11541 image create photo gitlogominus -width 4 -height 2
11542 gitlogominus put #C00000 -to 0 0 4 2
11543 gitlogo copy gitlogominus -to 1 5
11544 gitlogo copy gitlogominus -to 6 5
11545 gitlogo copy gitlogominus -to 11 5
11546 image delete gitlogominus
11548 image create photo gitlogoplus -width 4 -height 4
11549 gitlogoplus put #008000 -to 1 0 3 4
11550 gitlogoplus put #008000 -to 0 1 4 3
11551 gitlogo copy gitlogoplus -to 1 9
11552 gitlogo copy gitlogoplus -to 6 9
11553 gitlogo copy gitlogoplus -to 11 9
11554 image delete gitlogoplus
11556 image create photo gitlogo32 -width 32 -height 32
11557 gitlogo32 copy gitlogo -zoom 2 2
11559 wm iconphoto . -default gitlogo gitlogo32
11561 # wait for the window to become visible
11562 tkwait visibility .
11563 wm title . "[file tail $argv0]: [file tail [pwd]]"
11567 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11568 # create a view for the files/dirs specified on the command line
11572 set viewname(1) [mc "Command line"]
11573 set viewfiles(1) $cmdline_files
11574 set viewargs(1) $revtreeargs
11575 set viewargscmd(1) $revtreeargscmd
11579 .bar.view entryconf [mca "Edit view..."] -state normal
11580 .bar.view entryconf [mca "Delete view"] -state normal
11583 if {[info exists permviews]} {
11584 foreach v $permviews {
11587 set viewname($n) [lindex $v 0]
11588 set viewfiles($n) [lindex $v 1]
11589 set viewargs($n) [lindex $v 2]
11590 set viewargscmd($n) [lindex $v 3]
11596 if {[tk windowingsystem] eq "win32"} {