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 env
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
213 "--no-replace-objects" {
214 set env
(GIT_NO_REPLACE_OBJECTS
) "1"
217 # Other flag arguments including -<n>
218 if {[string is digit
-strict [string range
$arg 1 end
]]} {
221 # a flag argument that we don't recognize;
222 # that means we can't optimize
228 # Non-flag arguments specify commits or ranges of commits
229 if {[string match
"*...*" $arg]} {
230 lappend revargs
--gitk-symmetric-diff-marker
236 set vdflags
($n) $diffargs
237 set vflags
($n) $glflags
238 set vrevs
($n) $revargs
239 set vfiltered
($n) $filtered
240 set vorigargs
($n) $origargs
244 proc parseviewrevs
{view revs
} {
245 global vposids vnegids
250 if {[catch
{set ids
[eval exec git rev-parse
$revs]} err
]} {
251 # we get stdout followed by stderr in $err
252 # for an unknown rev, git rev-parse echoes it and then errors out
253 set errlines
[split $err "\n"]
255 for {set l
0} {$l < [llength
$errlines]} {incr l
} {
256 set line
[lindex
$errlines $l]
257 if {!([string length
$line] == 40 && [string is xdigit
$line])} {
258 if {[string match
"fatal:*" $line]} {
259 if {[string match
"fatal: ambiguous argument*" $line]
261 if {[llength
$badrev] == 1} {
262 set err
"unknown revision $badrev"
264 set err
"unknown revisions: [join $badrev ", "]"
267 set err
[join [lrange
$errlines $l end
] "\n"]
274 error_popup
"[mc "Error parsing revisions
:"] $err"
281 foreach id
[split $ids "\n"] {
282 if {$id eq
"--gitk-symmetric-diff-marker"} {
284 } elseif
{[string match
"^*" $id]} {
291 lappend neg
[string range
$id 1 end
]
296 lset ret end
$id...
[lindex
$ret end
]
302 set vposids
($view) $pos
303 set vnegids
($view) $neg
307 # Start off a git log process and arrange to read its output
308 proc start_rev_list
{view
} {
309 global startmsecs commitidx viewcomplete curview
311 global viewargs viewargscmd viewfiles vfilelimit
312 global showlocalchanges
313 global viewactive viewinstances vmergeonly
314 global mainheadid viewmainheadid viewmainheadid_orig
315 global vcanopt vflags vrevs vorigargs
317 set startmsecs
[clock clicks
-milliseconds]
318 set commitidx
($view) 0
319 # these are set this way for the error exits
320 set viewcomplete
($view) 1
321 set viewactive
($view) 0
324 set args
$viewargs($view)
325 if {$viewargscmd($view) ne
{}} {
327 set str
[exec sh
-c $viewargscmd($view)]
329 error_popup
"[mc "Error executing
--argscmd command:"] $err"
332 set args
[concat
$args [split $str "\n"]]
334 set vcanopt
($view) [parseviewargs
$view $args]
336 set files
$viewfiles($view)
337 if {$vmergeonly($view)} {
338 set files
[unmerged_files
$files]
341 if {$nr_unmerged == 0} {
342 error_popup
[mc
"No files selected: --merge specified but\
343 no files are unmerged."]
345 error_popup
[mc
"No files selected: --merge specified but\
346 no unmerged files are within file limit."]
351 set vfilelimit
($view) $files
353 if {$vcanopt($view)} {
354 set revs
[parseviewrevs
$view $vrevs($view)]
358 set args
[concat
$vflags($view) $revs]
360 set args
$vorigargs($view)
364 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
365 --boundary $args "--" $files] r
]
367 error_popup
"[mc "Error executing git log
:"] $err"
370 set i
[reg_instance
$fd]
371 set viewinstances
($view) [list
$i]
372 set viewmainheadid
($view) $mainheadid
373 set viewmainheadid_orig
($view) $mainheadid
374 if {$files ne
{} && $mainheadid ne
{}} {
375 get_viewmainhead
$view
377 if {$showlocalchanges && $viewmainheadid($view) ne
{}} {
378 interestedin
$viewmainheadid($view) dodiffindex
380 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
381 if {$tclencoding != {}} {
382 fconfigure
$fd -encoding $tclencoding
384 filerun
$fd [list getcommitlines
$fd $i $view 0]
385 nowbusy
$view [mc
"Reading"]
386 set viewcomplete
($view) 0
387 set viewactive
($view) 1
391 proc stop_instance
{inst
} {
392 global commfd leftover
394 set fd
$commfd($inst)
398 if {$
::tcl_platform
(platform
) eq
{windows
}} {
407 unset leftover
($inst)
410 proc stop_backends
{} {
413 foreach inst
[array names commfd
] {
418 proc stop_rev_list
{view
} {
421 foreach inst
$viewinstances($view) {
424 set viewinstances
($view) {}
427 proc reset_pending_select
{selid
} {
428 global pending_select mainheadid selectheadid
431 set pending_select
$selid
432 } elseif
{$selectheadid ne
{}} {
433 set pending_select
$selectheadid
435 set pending_select
$mainheadid
439 proc getcommits
{selid
} {
440 global canv curview need_redisplay viewactive
443 if {[start_rev_list
$curview]} {
444 reset_pending_select
$selid
445 show_status
[mc
"Reading commits..."]
448 show_status
[mc
"No commits selected"]
452 proc updatecommits
{} {
453 global curview vcanopt vorigargs vfilelimit viewinstances
454 global viewactive viewcomplete tclencoding
455 global startmsecs showneartags showlocalchanges
456 global mainheadid viewmainheadid viewmainheadid_orig pending_select
458 global varcid vposids vnegids vflags vrevs
460 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
463 if {$mainheadid ne
$viewmainheadid_orig($view)} {
464 if {$showlocalchanges} {
467 set viewmainheadid
($view) $mainheadid
468 set viewmainheadid_orig
($view) $mainheadid
469 if {$vfilelimit($view) ne
{}} {
470 get_viewmainhead
$view
473 if {$showlocalchanges} {
476 if {$vcanopt($view)} {
477 set oldpos
$vposids($view)
478 set oldneg
$vnegids($view)
479 set revs
[parseviewrevs
$view $vrevs($view)]
483 # note: getting the delta when negative refs change is hard,
484 # and could require multiple git log invocations, so in that
485 # case we ask git log for all the commits (not just the delta)
486 if {$oldneg eq
$vnegids($view)} {
489 # take out positive refs that we asked for before or
490 # that we have already seen
492 if {[string length
$rev] == 40} {
493 if {[lsearch
-exact $oldpos $rev] < 0
494 && ![info exists varcid
($view,$rev)]} {
499 lappend
$newrevs $rev
502 if {$npos == 0} return
504 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
506 set args
[concat
$vflags($view) $revs --not $oldpos]
508 set args
$vorigargs($view)
511 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
512 --boundary $args "--" $vfilelimit($view)] r
]
514 error_popup
"[mc "Error executing git log
:"] $err"
517 if {$viewactive($view) == 0} {
518 set startmsecs
[clock clicks
-milliseconds]
520 set i
[reg_instance
$fd]
521 lappend viewinstances
($view) $i
522 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
523 if {$tclencoding != {}} {
524 fconfigure
$fd -encoding $tclencoding
526 filerun
$fd [list getcommitlines
$fd $i $view 1]
527 incr viewactive
($view)
528 set viewcomplete
($view) 0
529 reset_pending_select
{}
530 nowbusy
$view [mc
"Reading"]
536 proc reloadcommits
{} {
537 global curview viewcomplete selectedline currentid thickerline
538 global showneartags treediffs commitinterest cached_commitrow
542 if {$selectedline ne
{}} {
546 if {!$viewcomplete($curview)} {
547 stop_rev_list
$curview
551 catch
{unset currentid
}
552 catch
{unset thickerline
}
553 catch
{unset treediffs
}
560 catch
{unset commitinterest
}
561 catch
{unset cached_commitrow
}
562 catch
{unset targetid
}
568 # This makes a string representation of a positive integer which
569 # sorts as a string in numerical order
572 return [format
"%x" $n]
573 } elseif
{$n < 256} {
574 return [format
"x%.2x" $n]
575 } elseif
{$n < 65536} {
576 return [format
"y%.4x" $n]
578 return [format
"z%.8x" $n]
581 # Procedures used in reordering commits from git log (without
582 # --topo-order) into the order for display.
584 proc varcinit
{view
} {
585 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
586 global vtokmod varcmod vrowmod varcix vlastins
588 set varcstart
($view) {{}}
589 set vupptr
($view) {0}
590 set vdownptr
($view) {0}
591 set vleftptr
($view) {0}
592 set vbackptr
($view) {0}
593 set varctok
($view) {{}}
594 set varcrow
($view) {{}}
595 set vtokmod
($view) {}
598 set varcix
($view) {{}}
599 set vlastins
($view) {0}
602 proc resetvarcs
{view
} {
603 global varcid varccommits parents children vseedcount ordertok
605 foreach vid
[array names varcid
$view,*] {
610 # some commits might have children but haven't been seen yet
611 foreach vid
[array names children
$view,*] {
614 foreach va
[array names varccommits
$view,*] {
615 unset varccommits
($va)
617 foreach vd
[array names vseedcount
$view,*] {
618 unset vseedcount
($vd)
620 catch
{unset ordertok
}
623 # returns a list of the commits with no children
625 global vdownptr vleftptr varcstart
628 set a
[lindex
$vdownptr($v) 0]
630 lappend ret
[lindex
$varcstart($v) $a]
631 set a
[lindex
$vleftptr($v) $a]
636 proc newvarc
{view id
} {
637 global varcid varctok parents children vdatemode
638 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
639 global commitdata commitinfo vseedcount varccommits vlastins
641 set a
[llength
$varctok($view)]
643 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
644 if {![info exists commitinfo
($id)]} {
645 parsecommit
$id $commitdata($id) 1
647 set cdate
[lindex
$commitinfo($id) 4]
648 if {![string is integer
-strict $cdate]} {
651 if {![info exists vseedcount
($view,$cdate)]} {
652 set vseedcount
($view,$cdate) -1
654 set c
[incr vseedcount
($view,$cdate)]
655 set cdate
[expr {$cdate ^
0xffffffff}]
656 set tok
"s[strrep $cdate][strrep $c]"
661 if {[llength
$children($vid)] > 0} {
662 set kid
[lindex
$children($vid) end
]
663 set k
$varcid($view,$kid)
664 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
667 set tok
[lindex
$varctok($view) $k]
671 set i
[lsearch
-exact $parents($view,$ki) $id]
672 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
673 append tok
[strrep
$j]
675 set c
[lindex
$vlastins($view) $ka]
676 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
678 set b
[lindex
$vdownptr($view) $ka]
680 set b
[lindex
$vleftptr($view) $c]
682 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
684 set b
[lindex
$vleftptr($view) $c]
687 lset vdownptr
($view) $ka $a
688 lappend vbackptr
($view) 0
690 lset vleftptr
($view) $c $a
691 lappend vbackptr
($view) $c
693 lset vlastins
($view) $ka $a
694 lappend vupptr
($view) $ka
695 lappend vleftptr
($view) $b
697 lset vbackptr
($view) $b $a
699 lappend varctok
($view) $tok
700 lappend varcstart
($view) $id
701 lappend vdownptr
($view) 0
702 lappend varcrow
($view) {}
703 lappend varcix
($view) {}
704 set varccommits
($view,$a) {}
705 lappend vlastins
($view) 0
709 proc splitvarc
{p v
} {
710 global varcid varcstart varccommits varctok vtokmod
711 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
713 set oa
$varcid($v,$p)
714 set otok
[lindex
$varctok($v) $oa]
715 set ac
$varccommits($v,$oa)
716 set i
[lsearch
-exact $varccommits($v,$oa) $p]
718 set na
[llength
$varctok($v)]
719 # "%" sorts before "0"...
720 set tok
"$otok%[strrep $i]"
721 lappend varctok
($v) $tok
722 lappend varcrow
($v) {}
723 lappend varcix
($v) {}
724 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
725 set varccommits
($v,$na) [lrange
$ac $i end
]
726 lappend varcstart
($v) $p
727 foreach id
$varccommits($v,$na) {
728 set varcid
($v,$id) $na
730 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
731 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
732 lset vdownptr
($v) $oa $na
733 lset vlastins
($v) $oa 0
734 lappend vupptr
($v) $oa
735 lappend vleftptr
($v) 0
736 lappend vbackptr
($v) 0
737 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
738 lset vupptr
($v) $b $na
740 if {[string compare
$otok $vtokmod($v)] <= 0} {
745 proc renumbervarc
{a v
} {
746 global parents children varctok varcstart varccommits
747 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
749 set t1
[clock clicks
-milliseconds]
755 if {[info exists isrelated
($a)]} {
757 set id
[lindex
$varccommits($v,$a) end
]
758 foreach p
$parents($v,$id) {
759 if {[info exists varcid
($v,$p)]} {
760 set isrelated
($varcid($v,$p)) 1
765 set b
[lindex
$vdownptr($v) $a]
768 set b
[lindex
$vleftptr($v) $a]
770 set a
[lindex
$vupptr($v) $a]
776 if {![info exists kidchanged
($a)]} continue
777 set id
[lindex
$varcstart($v) $a]
778 if {[llength
$children($v,$id)] > 1} {
779 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
782 set oldtok
[lindex
$varctok($v) $a]
783 if {!$vdatemode($v)} {
789 set kid
[last_real_child
$v,$id]
791 set k
$varcid($v,$kid)
792 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
795 set tok
[lindex
$varctok($v) $k]
799 set i
[lsearch
-exact $parents($v,$ki) $id]
800 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
801 append tok
[strrep
$j]
803 if {$tok eq
$oldtok} {
806 set id
[lindex
$varccommits($v,$a) end
]
807 foreach p
$parents($v,$id) {
808 if {[info exists varcid
($v,$p)]} {
809 set kidchanged
($varcid($v,$p)) 1
814 lset varctok
($v) $a $tok
815 set b
[lindex
$vupptr($v) $a]
817 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
820 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
823 set c
[lindex
$vbackptr($v) $a]
824 set d
[lindex
$vleftptr($v) $a]
826 lset vdownptr
($v) $b $d
828 lset vleftptr
($v) $c $d
831 lset vbackptr
($v) $d $c
833 if {[lindex
$vlastins($v) $b] == $a} {
834 lset vlastins
($v) $b $c
836 lset vupptr
($v) $a $ka
837 set c
[lindex
$vlastins($v) $ka]
839 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
841 set b
[lindex
$vdownptr($v) $ka]
843 set b
[lindex
$vleftptr($v) $c]
846 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
848 set b
[lindex
$vleftptr($v) $c]
851 lset vdownptr
($v) $ka $a
852 lset vbackptr
($v) $a 0
854 lset vleftptr
($v) $c $a
855 lset vbackptr
($v) $a $c
857 lset vleftptr
($v) $a $b
859 lset vbackptr
($v) $b $a
861 lset vlastins
($v) $ka $a
864 foreach id
[array names sortkids
] {
865 if {[llength
$children($v,$id)] > 1} {
866 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
870 set t2
[clock clicks
-milliseconds]
871 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
874 # Fix up the graph after we have found out that in view $v,
875 # $p (a commit that we have already seen) is actually the parent
876 # of the last commit in arc $a.
877 proc fix_reversal
{p a v
} {
878 global varcid varcstart varctok vupptr
880 set pa
$varcid($v,$p)
881 if {$p ne
[lindex
$varcstart($v) $pa]} {
883 set pa
$varcid($v,$p)
885 # seeds always need to be renumbered
886 if {[lindex
$vupptr($v) $pa] == 0 ||
887 [string compare
[lindex
$varctok($v) $a] \
888 [lindex
$varctok($v) $pa]] > 0} {
893 proc insertrow
{id p v
} {
894 global cmitlisted children parents varcid varctok vtokmod
895 global varccommits ordertok commitidx numcommits curview
896 global targetid targetrow
900 set cmitlisted
($vid) 1
901 set children
($vid) {}
902 set parents
($vid) [list
$p]
903 set a
[newvarc
$v $id]
905 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
908 lappend varccommits
($v,$a) $id
910 if {[llength
[lappend children
($vp) $id]] > 1} {
911 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
912 catch
{unset ordertok
}
914 fix_reversal
$p $a $v
916 if {$v == $curview} {
917 set numcommits
$commitidx($v)
919 if {[info exists targetid
]} {
920 if {![comes_before
$targetid $p]} {
927 proc insertfakerow
{id p
} {
928 global varcid varccommits parents children cmitlisted
929 global commitidx varctok vtokmod targetid targetrow curview numcommits
933 set i
[lsearch
-exact $varccommits($v,$a) $p]
935 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
938 set children
($v,$id) {}
939 set parents
($v,$id) [list
$p]
940 set varcid
($v,$id) $a
941 lappend children
($v,$p) $id
942 set cmitlisted
($v,$id) 1
943 set numcommits
[incr commitidx
($v)]
944 # note we deliberately don't update varcstart($v) even if $i == 0
945 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
947 if {[info exists targetid
]} {
948 if {![comes_before
$targetid $p]} {
956 proc removefakerow
{id
} {
957 global varcid varccommits parents children commitidx
958 global varctok vtokmod cmitlisted currentid selectedline
959 global targetid curview numcommits
962 if {[llength
$parents($v,$id)] != 1} {
963 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
966 set p
[lindex
$parents($v,$id) 0]
967 set a
$varcid($v,$id)
968 set i
[lsearch
-exact $varccommits($v,$a) $id]
970 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
974 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
975 unset parents
($v,$id)
976 unset children
($v,$id)
977 unset cmitlisted
($v,$id)
978 set numcommits
[incr commitidx
($v) -1]
979 set j
[lsearch
-exact $children($v,$p) $id]
981 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
984 if {[info exist currentid
] && $id eq
$currentid} {
988 if {[info exists targetid
] && $targetid eq
$id} {
995 proc real_children
{vp
} {
996 global children nullid nullid2
999 foreach id
$children($vp) {
1000 if {$id ne
$nullid && $id ne
$nullid2} {
1007 proc first_real_child
{vp
} {
1008 global children nullid nullid2
1010 foreach id
$children($vp) {
1011 if {$id ne
$nullid && $id ne
$nullid2} {
1018 proc last_real_child
{vp
} {
1019 global children nullid nullid2
1021 set kids
$children($vp)
1022 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
1023 set id
[lindex
$kids $i]
1024 if {$id ne
$nullid && $id ne
$nullid2} {
1031 proc vtokcmp
{v a b
} {
1032 global varctok varcid
1034 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1035 [lindex
$varctok($v) $varcid($v,$b)]]
1038 # This assumes that if lim is not given, the caller has checked that
1039 # arc a's token is less than $vtokmod($v)
1040 proc modify_arc
{v a
{lim
{}}} {
1041 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1044 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
1047 set r
[lindex
$varcrow($v) $a]
1048 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
1051 set vtokmod
($v) [lindex
$varctok($v) $a]
1053 if {$v == $curview} {
1054 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
1055 set a
[lindex
$vupptr($v) $a]
1061 set lim
[llength
$varccommits($v,$a)]
1063 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1070 proc update_arcrows
{v
} {
1071 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1072 global varcid vrownum varcorder varcix varccommits
1073 global vupptr vdownptr vleftptr varctok
1074 global displayorder parentlist curview cached_commitrow
1076 if {$vrowmod($v) == $commitidx($v)} return
1077 if {$v == $curview} {
1078 if {[llength
$displayorder] > $vrowmod($v)} {
1079 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1080 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1082 catch
{unset cached_commitrow
}
1084 set narctot
[expr {[llength
$varctok($v)] - 1}]
1086 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1087 # go up the tree until we find something that has a row number,
1088 # or we get to a seed
1089 set a
[lindex
$vupptr($v) $a]
1092 set a
[lindex
$vdownptr($v) 0]
1095 set varcorder
($v) [list
$a]
1096 lset varcix
($v) $a 0
1097 lset varcrow
($v) $a 0
1101 set arcn
[lindex
$varcix($v) $a]
1102 if {[llength
$vrownum($v)] > $arcn + 1} {
1103 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1104 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1106 set row
[lindex
$varcrow($v) $a]
1110 incr row
[llength
$varccommits($v,$a)]
1111 # go down if possible
1112 set b
[lindex
$vdownptr($v) $a]
1114 # if not, go left, or go up until we can go left
1116 set b
[lindex
$vleftptr($v) $a]
1118 set a
[lindex
$vupptr($v) $a]
1124 lappend vrownum
($v) $row
1125 lappend varcorder
($v) $a
1126 lset varcix
($v) $a $arcn
1127 lset varcrow
($v) $a $row
1129 set vtokmod
($v) [lindex
$varctok($v) $p]
1131 set vrowmod
($v) $row
1132 if {[info exists currentid
]} {
1133 set selectedline
[rowofcommit
$currentid]
1137 # Test whether view $v contains commit $id
1138 proc commitinview
{id v
} {
1141 return [info exists varcid
($v,$id)]
1144 # Return the row number for commit $id in the current view
1145 proc rowofcommit
{id
} {
1146 global varcid varccommits varcrow curview cached_commitrow
1147 global varctok vtokmod
1150 if {![info exists varcid
($v,$id)]} {
1151 puts
"oops rowofcommit no arc for [shortids $id]"
1154 set a
$varcid($v,$id)
1155 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1158 if {[info exists cached_commitrow
($id)]} {
1159 return $cached_commitrow($id)
1161 set i
[lsearch
-exact $varccommits($v,$a) $id]
1163 puts
"oops didn't find commit [shortids $id] in arc $a"
1166 incr i
[lindex
$varcrow($v) $a]
1167 set cached_commitrow
($id) $i
1171 # Returns 1 if a is on an earlier row than b, otherwise 0
1172 proc comes_before
{a b
} {
1173 global varcid varctok curview
1176 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1177 ![info exists varcid
($v,$b)]} {
1180 if {$varcid($v,$a) != $varcid($v,$b)} {
1181 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1182 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1184 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1187 proc bsearch
{l elt
} {
1188 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1193 while {$hi - $lo > 1} {
1194 set mid
[expr {int
(($lo + $hi) / 2)}]
1195 set t
[lindex
$l $mid]
1198 } elseif
{$elt > $t} {
1207 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1208 proc make_disporder
{start end
} {
1209 global vrownum curview commitidx displayorder parentlist
1210 global varccommits varcorder parents vrowmod varcrow
1211 global d_valid_start d_valid_end
1213 if {$end > $vrowmod($curview)} {
1214 update_arcrows
$curview
1216 set ai
[bsearch
$vrownum($curview) $start]
1217 set start
[lindex
$vrownum($curview) $ai]
1218 set narc
[llength
$vrownum($curview)]
1219 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1220 set a
[lindex
$varcorder($curview) $ai]
1221 set l
[llength
$displayorder]
1222 set al
[llength
$varccommits($curview,$a)]
1223 if {$l < $r + $al} {
1225 set pad
[ntimes
[expr {$r - $l}] {}]
1226 set displayorder
[concat
$displayorder $pad]
1227 set parentlist
[concat
$parentlist $pad]
1228 } elseif
{$l > $r} {
1229 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1230 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1232 foreach id
$varccommits($curview,$a) {
1233 lappend displayorder
$id
1234 lappend parentlist
$parents($curview,$id)
1236 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1238 foreach id
$varccommits($curview,$a) {
1239 lset displayorder
$i $id
1240 lset parentlist
$i $parents($curview,$id)
1248 proc commitonrow
{row
} {
1251 set id
[lindex
$displayorder $row]
1253 make_disporder
$row [expr {$row + 1}]
1254 set id
[lindex
$displayorder $row]
1259 proc closevarcs
{v
} {
1260 global varctok varccommits varcid parents children
1261 global cmitlisted commitidx vtokmod
1263 set missing_parents
0
1265 set narcs
[llength
$varctok($v)]
1266 for {set a
1} {$a < $narcs} {incr a
} {
1267 set id
[lindex
$varccommits($v,$a) end
]
1268 foreach p
$parents($v,$id) {
1269 if {[info exists varcid
($v,$p)]} continue
1270 # add p as a new commit
1271 incr missing_parents
1272 set cmitlisted
($v,$p) 0
1273 set parents
($v,$p) {}
1274 if {[llength
$children($v,$p)] == 1 &&
1275 [llength
$parents($v,$id)] == 1} {
1278 set b
[newvarc
$v $p]
1280 set varcid
($v,$p) $b
1281 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1284 lappend varccommits
($v,$b) $p
1286 set scripts
[check_interest
$p $scripts]
1289 if {$missing_parents > 0} {
1290 foreach s
$scripts {
1296 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1297 # Assumes we already have an arc for $rwid.
1298 proc rewrite_commit
{v id rwid
} {
1299 global children parents varcid varctok vtokmod varccommits
1301 foreach ch
$children($v,$id) {
1302 # make $rwid be $ch's parent in place of $id
1303 set i
[lsearch
-exact $parents($v,$ch) $id]
1305 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1307 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1308 # add $ch to $rwid's children and sort the list if necessary
1309 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1310 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1311 $children($v,$rwid)]
1313 # fix the graph after joining $id to $rwid
1314 set a
$varcid($v,$ch)
1315 fix_reversal
$rwid $a $v
1316 # parentlist is wrong for the last element of arc $a
1317 # even if displayorder is right, hence the 3rd arg here
1318 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1322 # Mechanism for registering a command to be executed when we come
1323 # across a particular commit. To handle the case when only the
1324 # prefix of the commit is known, the commitinterest array is now
1325 # indexed by the first 4 characters of the ID. Each element is a
1326 # list of id, cmd pairs.
1327 proc interestedin
{id cmd
} {
1328 global commitinterest
1330 lappend commitinterest
([string range
$id 0 3]) $id $cmd
1333 proc check_interest
{id scripts
} {
1334 global commitinterest
1336 set prefix
[string range
$id 0 3]
1337 if {[info exists commitinterest
($prefix)]} {
1339 foreach
{i
script} $commitinterest($prefix) {
1340 if {[string match
"$i*" $id]} {
1341 lappend scripts
[string map
[list
"%I" $id "%P" $i] $script]
1343 lappend newlist
$i $script
1346 if {$newlist ne
{}} {
1347 set commitinterest
($prefix) $newlist
1349 unset commitinterest
($prefix)
1355 proc getcommitlines
{fd inst view updating
} {
1356 global cmitlisted leftover
1357 global commitidx commitdata vdatemode
1358 global parents children curview hlview
1359 global idpending ordertok
1360 global varccommits varcid varctok vtokmod vfilelimit
1362 set stuff
[read $fd 500000]
1363 # git log doesn't terminate the last commit with a null...
1364 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1371 global commfd viewcomplete viewactive viewname
1372 global viewinstances
1374 set i
[lsearch
-exact $viewinstances($view) $inst]
1376 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1378 # set it blocking so we wait for the process to terminate
1379 fconfigure
$fd -blocking 1
1380 if {[catch
{close
$fd} err
]} {
1382 if {$view != $curview} {
1383 set fv
" for the \"$viewname($view)\" view"
1385 if {[string range
$err 0 4] == "usage"} {
1386 set err
"Gitk: error reading commits$fv:\
1387 bad arguments to git log."
1388 if {$viewname($view) eq
"Command line"} {
1390 " (Note: arguments to gitk are passed to git log\
1391 to allow selection of commits to be displayed.)"
1394 set err
"Error reading commits$fv: $err"
1398 if {[incr viewactive
($view) -1] <= 0} {
1399 set viewcomplete
($view) 1
1400 # Check if we have seen any ids listed as parents that haven't
1401 # appeared in the list
1405 if {$view == $curview} {
1414 set i
[string first
"\0" $stuff $start]
1416 append leftover
($inst) [string range
$stuff $start end
]
1420 set cmit
$leftover($inst)
1421 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1422 set leftover
($inst) {}
1424 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1426 set start
[expr {$i + 1}]
1427 set j
[string first
"\n" $cmit]
1430 if {$j >= 0 && [string match
"commit *" $cmit]} {
1431 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1432 if {[string match
{[-^
<>]*} $ids]} {
1433 switch
-- [string index
$ids 0] {
1439 set ids
[string range
$ids 1 end
]
1443 if {[string length
$id] != 40} {
1451 if {[string length
$shortcmit] > 80} {
1452 set shortcmit
"[string range $shortcmit 0 80]..."
1454 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1457 set id [lindex $ids 0]
1460 if {!$listed && $updating && ![info exists varcid($vid)] &&
1461 $vfilelimit($view) ne {}} {
1462 # git log doesn't rewrite parents
for unlisted commits
1463 # when doing path limiting, so work around that here
1464 # by working out the rewritten parent with git rev-list
1465 # and if we already know about it, using the rewritten
1466 # parent as a substitute parent for $id's children.
1468 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1469 $id -- $vfilelimit($view)]
1471 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1472 # use $rwid in place of $id
1473 rewrite_commit
$view $id $rwid
1480 if {[info exists varcid
($vid)]} {
1481 if {$cmitlisted($vid) ||
!$listed} continue
1485 set olds
[lrange
$ids 1 end
]
1489 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1490 set cmitlisted
($vid) $listed
1491 set parents
($vid) $olds
1492 if {![info exists children
($vid)]} {
1493 set children
($vid) {}
1494 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1495 set k
[lindex
$children($vid) 0]
1496 if {[llength
$parents($view,$k)] == 1 &&
1497 (!$vdatemode($view) ||
1498 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1499 set a
$varcid($view,$k)
1504 set a
[newvarc
$view $id]
1506 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1509 if {![info exists varcid
($vid)]} {
1511 lappend varccommits
($view,$a) $id
1512 incr commitidx
($view)
1517 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1519 if {[llength
[lappend children
($vp) $id]] > 1 &&
1520 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1521 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1523 catch
{unset ordertok
}
1525 if {[info exists varcid
($view,$p)]} {
1526 fix_reversal
$p $a $view
1532 set scripts
[check_interest
$id $scripts]
1536 global numcommits hlview
1538 if {$view == $curview} {
1539 set numcommits
$commitidx($view)
1542 if {[info exists hlview
] && $view == $hlview} {
1543 # we never actually get here...
1546 foreach s
$scripts {
1553 proc chewcommits
{} {
1554 global curview hlview viewcomplete
1555 global pending_select
1558 if {$viewcomplete($curview)} {
1559 global commitidx varctok
1560 global numcommits startmsecs
1562 if {[info exists pending_select
]} {
1564 reset_pending_select
{}
1566 if {[commitinview
$pending_select $curview]} {
1567 selectline
[rowofcommit
$pending_select] 1
1569 set row
[first_real_row
]
1573 if {$commitidx($curview) > 0} {
1574 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1575 #puts "overall $ms ms for $numcommits commits"
1576 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1578 show_status
[mc
"No commits selected"]
1585 proc do_readcommit
{id
} {
1588 # Invoke git-log to handle automatic encoding conversion
1589 set fd
[open
[concat | git log
--no-color --pretty=raw
-1 $id] r
]
1590 # Read the results using i18n.logoutputencoding
1591 fconfigure
$fd -translation lf
-eofchar {}
1592 if {$tclencoding != {}} {
1593 fconfigure
$fd -encoding $tclencoding
1595 set contents
[read $fd]
1597 # Remove the heading line
1598 regsub
{^commit
[0-9a-f]+\n} $contents {} contents
1603 proc readcommit
{id
} {
1604 if {[catch
{set contents
[do_readcommit
$id]}]} return
1605 parsecommit
$id $contents 1
1608 proc parsecommit
{id contents listed
} {
1609 global commitinfo cdate
1618 set hdrend
[string first
"\n\n" $contents]
1620 # should never happen...
1621 set hdrend
[string length
$contents]
1623 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1624 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1625 foreach line
[split $header "\n"] {
1626 set line
[split $line " "]
1627 set tag
[lindex
$line 0]
1628 if {$tag == "author"} {
1629 set audate
[lindex
$line end-1
]
1630 set auname
[join [lrange
$line 1 end-2
] " "]
1631 } elseif
{$tag == "committer"} {
1632 set comdate
[lindex
$line end-1
]
1633 set comname
[join [lrange
$line 1 end-2
] " "]
1637 # take the first non-blank line of the comment as the headline
1638 set headline
[string trimleft
$comment]
1639 set i
[string first
"\n" $headline]
1641 set headline
[string range
$headline 0 $i]
1643 set headline
[string trimright
$headline]
1644 set i
[string first
"\r" $headline]
1646 set headline
[string trimright
[string range
$headline 0 $i]]
1649 # git log indents the comment by 4 spaces;
1650 # if we got this via git cat-file, add the indentation
1652 foreach line
[split $comment "\n"] {
1653 append newcomment
" "
1654 append newcomment
$line
1655 append newcomment
"\n"
1657 set comment
$newcomment
1659 if {$comdate != {}} {
1660 set cdate
($id) $comdate
1662 set commitinfo
($id) [list
$headline $auname $audate \
1663 $comname $comdate $comment]
1666 proc getcommit
{id
} {
1667 global commitdata commitinfo
1669 if {[info exists commitdata
($id)]} {
1670 parsecommit
$id $commitdata($id) 1
1673 if {![info exists commitinfo
($id)]} {
1674 set commitinfo
($id) [list
[mc
"No commit information available"]]
1680 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1681 # and are present in the current view.
1682 # This is fairly slow...
1683 proc longid
{prefix
} {
1684 global varcid curview
1687 foreach match
[array names varcid
"$curview,$prefix*"] {
1688 lappend ids
[lindex
[split $match ","] 1]
1694 global tagids idtags headids idheads tagobjid
1695 global otherrefids idotherrefs mainhead mainheadid
1696 global selecthead selectheadid
1699 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1702 set refd
[open
[list | git show-ref
-d] r
]
1703 while {[gets
$refd line
] >= 0} {
1704 if {[string index
$line 40] ne
" "} continue
1705 set id
[string range
$line 0 39]
1706 set ref
[string range
$line 41 end
]
1707 if {![string match
"refs/*" $ref]} continue
1708 set name
[string range
$ref 5 end
]
1709 if {[string match
"remotes/*" $name]} {
1710 if {![string match
"*/HEAD" $name] && !$hideremotes} {
1711 set headids
($name) $id
1712 lappend idheads
($id) $name
1714 } elseif
{[string match
"heads/*" $name]} {
1715 set name
[string range
$name 6 end
]
1716 set headids
($name) $id
1717 lappend idheads
($id) $name
1718 } elseif
{[string match
"tags/*" $name]} {
1719 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1720 # which is what we want since the former is the commit ID
1721 set name
[string range
$name 5 end
]
1722 if {[string match
"*^{}" $name]} {
1723 set name
[string range
$name 0 end-3
]
1725 set tagobjid
($name) $id
1727 set tagids
($name) $id
1728 lappend idtags
($id) $name
1730 set otherrefids
($name) $id
1731 lappend idotherrefs
($id) $name
1738 set mainheadid
[exec git rev-parse HEAD
]
1739 set thehead
[exec git symbolic-ref HEAD
]
1740 if {[string match
"refs/heads/*" $thehead]} {
1741 set mainhead
[string range
$thehead 11 end
]
1745 if {$selecthead ne
{}} {
1747 set selectheadid
[exec git rev-parse
--verify $selecthead]
1752 # skip over fake commits
1753 proc first_real_row
{} {
1754 global nullid nullid2 numcommits
1756 for {set row
0} {$row < $numcommits} {incr row
} {
1757 set id
[commitonrow
$row]
1758 if {$id ne
$nullid && $id ne
$nullid2} {
1765 # update things for a head moved to a child of its previous location
1766 proc movehead
{id name
} {
1767 global headids idheads
1769 removehead
$headids($name) $name
1770 set headids
($name) $id
1771 lappend idheads
($id) $name
1774 # update things when a head has been removed
1775 proc removehead
{id name
} {
1776 global headids idheads
1778 if {$idheads($id) eq
$name} {
1781 set i
[lsearch
-exact $idheads($id) $name]
1783 set idheads
($id) [lreplace
$idheads($id) $i $i]
1786 unset headids
($name)
1789 proc ttk_toplevel
{w args
} {
1791 eval [linsert
$args 0 ::toplevel
$w]
1793 place
[ttk
::frame
$w._toplevel_background
] -x 0 -y 0 -relwidth 1 -relheight 1
1798 proc make_transient
{window origin
} {
1801 # In MacOS Tk 8.4 transient appears to work by setting
1802 # overrideredirect, which is utterly useless, since the
1803 # windows get no border, and are not even kept above
1805 if {!$have_tk85 && [tk windowingsystem
] eq
{aqua
}} return
1807 wm transient
$window $origin
1809 # Windows fails to place transient windows normally, so
1810 # schedule a callback to center them on the parent.
1811 if {[tk windowingsystem
] eq
{win32
}} {
1812 after idle
[list tk
::PlaceWindow
$window widget
$origin]
1816 proc show_error
{w top msg
{mc mc
}} {
1818 if {![info exists NS
]} {set NS
""}
1819 if {[wm state
$top] eq
"withdrawn"} { wm deiconify
$top }
1820 message
$w.m
-text $msg -justify center
-aspect 400
1821 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1822 ${NS}::button
$w.ok
-default active
-text [$mc OK
] -command "destroy $top"
1823 pack
$w.ok
-side bottom
-fill x
1824 bind $top <Visibility
> "grab $top; focus $top"
1825 bind $top <Key-Return
> "destroy $top"
1826 bind $top <Key-space
> "destroy $top"
1827 bind $top <Key-Escape
> "destroy $top"
1831 proc error_popup
{msg
{owner .
}} {
1832 if {[tk windowingsystem
] eq
"win32"} {
1833 tk_messageBox
-icon error
-type ok
-title [wm title .
] \
1834 -parent $owner -message $msg
1838 make_transient
$w $owner
1839 show_error
$w $w $msg
1843 proc confirm_popup
{msg
{owner .
}} {
1844 global confirm_ok NS
1848 make_transient
$w $owner
1849 message
$w.m
-text $msg -justify center
-aspect 400
1850 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1851 ${NS}::button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1852 pack
$w.ok
-side left
-fill x
1853 ${NS}::button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1854 pack
$w.cancel
-side right
-fill x
1855 bind $w <Visibility
> "grab $w; focus $w"
1856 bind $w <Key-Return
> "set confirm_ok 1; destroy $w"
1857 bind $w <Key-space
> "set confirm_ok 1; destroy $w"
1858 bind $w <Key-Escape
> "destroy $w"
1859 tk
::PlaceWindow
$w widget
$owner
1864 proc setoptions
{} {
1865 if {[tk windowingsystem
] ne
"win32"} {
1866 option add
*Panedwindow.showHandle
1 startupFile
1867 option add
*Panedwindow.sashRelief raised startupFile
1868 if {[tk windowingsystem
] ne
"aqua"} {
1869 option add
*Menu.font uifont startupFile
1872 option add
*Menu.TearOff
0 startupFile
1874 option add
*Button.font uifont startupFile
1875 option add
*Checkbutton.font uifont startupFile
1876 option add
*Radiobutton.font uifont startupFile
1877 option add
*Menubutton.font uifont startupFile
1878 option add
*Label.font uifont startupFile
1879 option add
*Message.font uifont startupFile
1880 option add
*Entry.font uifont startupFile
1881 option add
*Labelframe.font uifont startupFile
1882 option add
*Spinbox.font textfont startupFile
1883 option add
*Listbox.font mainfont startupFile
1886 # Make a menu and submenus.
1887 # m is the window name for the menu, items is the list of menu items to add.
1888 # Each item is a list {mc label type description options...}
1889 # mc is ignored; it's so we can put mc there to alert xgettext
1890 # label is the string that appears in the menu
1891 # type is cascade, command or radiobutton (should add checkbutton)
1892 # description depends on type; it's the sublist for cascade, the
1893 # command to invoke for command, or {variable value} for radiobutton
1894 proc makemenu
{m items
} {
1896 if {[tk windowingsystem
] eq
{aqua
}} {
1902 set name
[mc
[lindex
$i 1]]
1903 set type [lindex
$i 2]
1904 set thing
[lindex
$i 3]
1905 set params
[list
$type]
1907 set u
[string first
"&" [string map
{&& x
} $name]]
1908 lappend params
-label [string map
{&& & & {}} $name]
1910 lappend params
-underline $u
1915 set submenu
[string tolower
[string map
{& ""} [lindex
$i 1]]]
1916 lappend params
-menu $m.
$submenu
1919 lappend params
-command $thing
1922 lappend params
-variable [lindex
$thing 0] \
1923 -value [lindex
$thing 1]
1926 set tail [lrange
$i 4 end
]
1927 regsub
-all {\yMeta1\y
} $tail $Meta1 tail
1928 eval $m add
$params $tail
1929 if {$type eq
"cascade"} {
1930 makemenu
$m.
$submenu $thing
1935 # translate string and remove ampersands
1937 return [string map
{&& & & {}} [mc
$str]]
1940 proc makedroplist
{w varname args
} {
1944 foreach label
$args {
1945 set cx
[string length
$label]
1946 if {$cx > $width} {set width
$cx}
1948 set gm
[ttk
::combobox
$w -width $width -state readonly\
1949 -textvariable $varname -values $args]
1951 set gm
[eval [linsert
$args 0 tk_optionMenu
$w $varname]]
1956 proc makewindow
{} {
1957 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1959 global findtype findtypemenu findloc findstring fstring geometry
1960 global entries sha1entry sha1string sha1but
1961 global diffcontextstring diffcontext
1963 global maincursor textcursor curtextcursor
1964 global rowctxmenu fakerowmenu mergemax wrapcomment
1965 global highlight_files gdttype
1966 global searchstring sstring
1967 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1968 global headctxmenu progresscanv progressitem progresscoords statusw
1969 global fprogitem fprogcoord lastprogupdate progupdatepending
1970 global rprogitem rprogcoord rownumsel numcommits
1971 global have_tk85 use_ttk NS
1973 # The "mc" arguments here are purely so that xgettext
1974 # sees the following string as needing to be translated
1977 {mc
"Update" command updatecommits
-accelerator F5
}
1978 {mc
"Reload" command reloadcommits
-accelerator Meta1-F5
}
1979 {mc
"Reread references" command rereadrefs
}
1980 {mc
"List references" command showrefs
-accelerator F2
}
1982 {mc
"Start git gui" command {exec git gui
&}}
1984 {mc
"Quit" command doquit
-accelerator Meta1-Q
}
1988 {mc
"Preferences" command doprefs
}
1992 {mc
"New view..." command {newview
0} -accelerator Shift-F4
}
1993 {mc
"Edit view..." command editview
-state disabled
-accelerator F4
}
1994 {mc
"Delete view" command delview
-state disabled
}
1996 {mc
"All files" radiobutton
{selectedview
0} -command {showview
0}}
1998 if {[tk windowingsystem
] ne
"aqua"} {
2001 {mc
"About gitk" command about
}
2002 {mc
"Key bindings" command keys
}
2004 set bar
[list
$file $edit $view $help]
2006 proc
::tk
::mac
::ShowPreferences
{} {doprefs
}
2007 proc
::tk
::mac
::Quit
{} {doquit
}
2008 lset
file end
[lreplace
[lindex
$file end
] end-1 end
]
2010 xx
"Apple" cascade
{
2011 {mc
"About gitk" command about
}
2016 {mc
"Key bindings" command keys
}
2018 set bar
[list
$apple $file $view $help]
2021 . configure
-menu .bar
2024 # cover the non-themed toplevel with a themed frame.
2025 place
[ttk
::frame ._main_background
] -x 0 -y 0 -relwidth 1 -relheight 1
2028 # the gui has upper and lower half, parts of a paned window.
2029 ${NS}::panedwindow .ctop
-orient vertical
2031 # possibly use assumed geometry
2032 if {![info exists geometry
(pwsash0
)]} {
2033 set geometry
(topheight
) [expr {15 * $linespc}]
2034 set geometry
(topwidth
) [expr {80 * $charspc}]
2035 set geometry
(botheight
) [expr {15 * $linespc}]
2036 set geometry
(botwidth
) [expr {50 * $charspc}]
2037 set geometry
(pwsash0
) [list
[expr {40 * $charspc}] 2]
2038 set geometry
(pwsash1
) [list
[expr {60 * $charspc}] 2]
2041 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2042 ${NS}::frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
2043 ${NS}::frame .tf.histframe
2044 ${NS}::panedwindow .tf.histframe.pwclist
-orient horizontal
2046 .tf.histframe.pwclist configure
-sashpad 0 -handlesize 4
2049 # create three canvases
2050 set cscroll .tf.histframe.csb
2051 set canv .tf.histframe.pwclist.canv
2053 -selectbackground $selectbgcolor \
2054 -background $bgcolor -bd 0 \
2055 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2056 .tf.histframe.pwclist add
$canv
2057 set canv2 .tf.histframe.pwclist.canv2
2059 -selectbackground $selectbgcolor \
2060 -background $bgcolor -bd 0 -yscrollincr $linespc
2061 .tf.histframe.pwclist add
$canv2
2062 set canv3 .tf.histframe.pwclist.canv3
2064 -selectbackground $selectbgcolor \
2065 -background $bgcolor -bd 0 -yscrollincr $linespc
2066 .tf.histframe.pwclist add
$canv3
2068 bind .tf.histframe.pwclist
<Map
> {
2070 .tf.histframe.pwclist sashpos
1 [lindex $
::geometry
(pwsash1
) 0]
2071 .tf.histframe.pwclist sashpos
0 [lindex $
::geometry
(pwsash0
) 0]
2074 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
2075 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
2078 # a scroll bar to rule them
2079 ${NS}::scrollbar
$cscroll -command {allcanvs yview
}
2080 if {!$use_ttk} {$cscroll configure
-highlightthickness 0}
2081 pack
$cscroll -side right
-fill y
2082 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
2083 lappend bglist
$canv $canv2 $canv3
2084 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
2086 # we have two button bars at bottom of top frame. Bar 1
2087 ${NS}::frame .tf.bar
2088 ${NS}::frame .tf.lbar
-height 15
2090 set sha1entry .tf.bar.sha1
2091 set entries
$sha1entry
2092 set sha1but .tf.bar.sha1label
2093 button
$sha1but -text "[mc "SHA1 ID
:"] " -state disabled
-relief flat \
2094 -command gotocommit
-width 8
2095 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
2096 pack .tf.bar.sha1label
-side left
2097 ${NS}::entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
2098 trace add variable sha1string
write sha1change
2099 pack
$sha1entry -side left
-pady 2
2101 image create bitmap bm-left
-data {
2102 #define left_width 16
2103 #define left_height 16
2104 static unsigned char left_bits
[] = {
2105 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2106 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2107 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2109 image create bitmap bm-right
-data {
2110 #define right_width 16
2111 #define right_height 16
2112 static unsigned char right_bits
[] = {
2113 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2114 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2115 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2117 ${NS}::button .tf.bar.leftbut
-image bm-left
-command goback \
2118 -state disabled
-width 26
2119 pack .tf.bar.leftbut
-side left
-fill y
2120 ${NS}::button .tf.bar.rightbut
-image bm-right
-command goforw \
2121 -state disabled
-width 26
2122 pack .tf.bar.rightbut
-side left
-fill y
2124 ${NS}::label .tf.bar.rowlabel
-text [mc
"Row"]
2126 ${NS}::label .tf.bar.rownum
-width 7 -textvariable rownumsel \
2127 -relief sunken
-anchor e
2128 ${NS}::label .tf.bar.rowlabel2
-text "/"
2129 ${NS}::label .tf.bar.numcommits
-width 7 -textvariable numcommits \
2130 -relief sunken
-anchor e
2131 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2134 foreach w
{rownum numcommits
} {.tf.bar.
$w configure
-font textfont
}
2137 trace add variable selectedline
write selectedline_change
2139 # Status label and progress bar
2140 set statusw .tf.bar.status
2141 ${NS}::label
$statusw -width 15 -relief sunken
2142 pack
$statusw -side left
-padx 5
2144 set progresscanv
[ttk
::progressbar .tf.bar.progress
]
2146 set h
[expr {[font metrics uifont
-linespace] + 2}]
2147 set progresscanv .tf.bar.progress
2148 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
2149 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
2150 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
2151 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
2153 pack
$progresscanv -side right
-expand 1 -fill x
-padx {0 2}
2154 set progresscoords
{0 0}
2157 bind $progresscanv <Configure
> adjustprogress
2158 set lastprogupdate
[clock clicks
-milliseconds]
2159 set progupdatepending
0
2161 # build up the bottom bar of upper window
2162 ${NS}::label .tf.lbar.flabel
-text "[mc "Find
"] "
2163 ${NS}::button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
2164 ${NS}::button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
2165 ${NS}::label .tf.lbar.flab2
-text " [mc "commit
"] "
2166 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2168 set gdttype
[mc
"containing:"]
2169 set gm
[makedroplist .tf.lbar.gdttype gdttype \
2170 [mc
"containing:"] \
2171 [mc
"touching paths:"] \
2172 [mc
"adding/removing string:"]]
2173 trace add variable gdttype
write gdttype_change
2174 pack .tf.lbar.gdttype
-side left
-fill y
2177 set fstring .tf.lbar.findstring
2178 lappend entries
$fstring
2179 ${NS}::entry
$fstring -width 30 -font textfont
-textvariable findstring
2180 trace add variable findstring
write find_change
2181 set findtype
[mc
"Exact"]
2182 set findtypemenu
[makedroplist .tf.lbar.findtype \
2183 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
2184 trace add variable findtype
write findcom_change
2185 set findloc
[mc
"All fields"]
2186 makedroplist .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
2187 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
2188 trace add variable findloc
write find_change
2189 pack .tf.lbar.findloc
-side right
2190 pack .tf.lbar.findtype
-side right
2191 pack
$fstring -side left
-expand 1 -fill x
2193 # Finish putting the upper half of the viewer together
2194 pack .tf.lbar
-in .tf
-side bottom
-fill x
2195 pack .tf.bar
-in .tf
-side bottom
-fill x
2196 pack .tf.histframe
-fill both
-side top
-expand 1
2199 .ctop paneconfigure .tf
-height $geometry(topheight
)
2200 .ctop paneconfigure .tf
-width $geometry(topwidth
)
2203 # now build up the bottom
2204 ${NS}::panedwindow .pwbottom
-orient horizontal
2206 # lower left, a text box over search bar, scroll bar to the right
2207 # if we know window height, then that will set the lower text height, otherwise
2208 # we set lower text height which will drive window height
2209 if {[info exists geometry
(main
)]} {
2210 ${NS}::frame .bleft
-width $geometry(botwidth
)
2212 ${NS}::frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
2214 ${NS}::frame .bleft.top
2215 ${NS}::frame .bleft.mid
2216 ${NS}::frame .bleft.bottom
2218 ${NS}::button .bleft.top.search
-text [mc
"Search"] -command dosearch
2219 pack .bleft.top.search
-side left
-padx 5
2220 set sstring .bleft.top.sstring
2222 ${NS}::entry
$sstring -width 20 -font textfont
-textvariable searchstring
2223 lappend entries
$sstring
2224 trace add variable searchstring
write incrsearch
2225 pack
$sstring -side left
-expand 1 -fill x
2226 ${NS}::radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
2227 -command changediffdisp
-variable diffelide
-value {0 0}
2228 ${NS}::radiobutton .bleft.mid.old
-text [mc
"Old version"] \
2229 -command changediffdisp
-variable diffelide
-value {0 1}
2230 ${NS}::radiobutton .bleft.mid.new
-text [mc
"New version"] \
2231 -command changediffdisp
-variable diffelide
-value {1 0}
2232 ${NS}::label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
2233 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
2234 spinbox .bleft.mid.diffcontext
-width 5 \
2235 -from 0 -increment 1 -to 10000000 \
2236 -validate all
-validatecommand "diffcontextvalidate %P" \
2237 -textvariable diffcontextstring
2238 .bleft.mid.diffcontext
set $diffcontext
2239 trace add variable diffcontextstring
write diffcontextchange
2240 lappend entries .bleft.mid.diffcontext
2241 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
2242 ${NS}::checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
2243 -command changeignorespace
-variable ignorespace
2244 pack .bleft.mid.ignspace
-side left
-padx 5
2245 set ctext .bleft.bottom.ctext
2246 text
$ctext -background $bgcolor -foreground $fgcolor \
2247 -state disabled
-font textfont \
2248 -yscrollcommand scrolltext
-wrap none \
2249 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2251 $ctext conf
-tabstyle wordprocessor
2253 ${NS}::scrollbar .bleft.bottom.sb
-command "$ctext yview"
2254 ${NS}::scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h
2255 pack .bleft.top
-side top
-fill x
2256 pack .bleft.mid
-side top
-fill x
2257 grid
$ctext .bleft.bottom.sb
-sticky nsew
2258 grid .bleft.bottom.sbhorizontal
-sticky ew
2259 grid columnconfigure .bleft.bottom
0 -weight 1
2260 grid rowconfigure .bleft.bottom
0 -weight 1
2261 grid rowconfigure .bleft.bottom
1 -weight 0
2262 pack .bleft.bottom
-side top
-fill both
-expand 1
2263 lappend bglist
$ctext
2264 lappend fglist
$ctext
2266 $ctext tag conf comment
-wrap $wrapcomment
2267 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
2268 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
2269 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
2270 $ctext tag conf dresult
-fore [lindex
$diffcolors 1]
2271 $ctext tag conf m0
-fore red
2272 $ctext tag conf m1
-fore blue
2273 $ctext tag conf m2
-fore green
2274 $ctext tag conf m3
-fore purple
2275 $ctext tag conf
m4 -fore brown
2276 $ctext tag conf m5
-fore "#009090"
2277 $ctext tag conf m6
-fore magenta
2278 $ctext tag conf m7
-fore "#808000"
2279 $ctext tag conf m8
-fore "#009000"
2280 $ctext tag conf m9
-fore "#ff0080"
2281 $ctext tag conf m10
-fore cyan
2282 $ctext tag conf m11
-fore "#b07070"
2283 $ctext tag conf m12
-fore "#70b0f0"
2284 $ctext tag conf m13
-fore "#70f0b0"
2285 $ctext tag conf m14
-fore "#f0b070"
2286 $ctext tag conf m15
-fore "#ff70b0"
2287 $ctext tag conf mmax
-fore darkgrey
2289 $ctext tag conf mresult
-font textfontbold
2290 $ctext tag conf msep
-font textfontbold
2291 $ctext tag conf found
-back yellow
2293 .pwbottom add .bleft
2295 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2299 ${NS}::frame .bright
2300 ${NS}::frame .bright.mode
2301 ${NS}::radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2302 -command reselectline
-variable cmitmode
-value "patch"
2303 ${NS}::radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2304 -command reselectline
-variable cmitmode
-value "tree"
2305 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2306 pack .bright.mode
-side top
-fill x
2307 set cflist .bright.cfiles
2308 set indent
[font measure mainfont
"nn"]
2310 -selectbackground $selectbgcolor \
2311 -background $bgcolor -foreground $fgcolor \
2313 -tabs [list
$indent [expr {2 * $indent}]] \
2314 -yscrollcommand ".bright.sb set" \
2315 -cursor [. cget
-cursor] \
2316 -spacing1 1 -spacing3 1
2317 lappend bglist
$cflist
2318 lappend fglist
$cflist
2319 ${NS}::scrollbar .bright.sb
-command "$cflist yview"
2320 pack .bright.sb
-side right
-fill y
2321 pack
$cflist -side left
-fill both
-expand 1
2322 $cflist tag configure highlight \
2323 -background [$cflist cget
-selectbackground]
2324 $cflist tag configure bold
-font mainfontbold
2326 .pwbottom add .bright
2329 # restore window width & height if known
2330 if {[info exists geometry
(main
)]} {
2331 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2332 if {$w > [winfo screenwidth .
]} {
2333 set w
[winfo screenwidth .
]
2335 if {$h > [winfo screenheight .
]} {
2336 set h
[winfo screenheight .
]
2338 wm geometry .
"${w}x$h"
2342 if {[info exists geometry
(state
)] && $geometry(state
) eq
"zoomed"} {
2343 wm state .
$geometry(state
)
2346 if {[tk windowingsystem
] eq
{aqua
}} {
2357 %W sashpos
0 $
::geometry
(topheight
)
2359 bind .pwbottom
<Map
> {
2361 %W sashpos
0 $
::geometry
(botwidth
)
2365 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2366 pack .ctop
-fill both
-expand 1
2367 bindall
<1> {selcanvline
%W
%x
%y
}
2368 #bindall <B1-Motion> {selcanvline %W %x %y}
2369 if {[tk windowingsystem
] == "win32"} {
2370 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2371 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2373 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2374 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2375 if {[tk windowingsystem
] eq
"aqua"} {
2376 bindall
<MouseWheel
> {
2377 set delta
[expr {- (%D
)}]
2378 allcanvs yview scroll
$delta units
2380 bindall
<Shift-MouseWheel
> {
2381 set delta
[expr {- (%D
)}]
2382 $canv xview scroll
$delta units
2386 bindall
<$
::BM
> "canvscan mark %W %x %y"
2387 bindall
<B$
::BM-Motion
> "canvscan dragto %W %x %y"
2388 bind all
<$M1B-Key-w> {destroy
[winfo toplevel
%W
]}
2389 bind .
<$M1B-Key-w> doquit
2390 bindkey
<Home
> selfirstline
2391 bindkey
<End
> sellastline
2392 bind .
<Key-Up
> "selnextline -1"
2393 bind .
<Key-Down
> "selnextline 1"
2394 bind .
<Shift-Key-Up
> "dofind -1 0"
2395 bind .
<Shift-Key-Down
> "dofind 1 0"
2396 bindkey
<Key-Right
> "goforw"
2397 bindkey
<Key-Left
> "goback"
2398 bind .
<Key-Prior
> "selnextpage -1"
2399 bind .
<Key-Next
> "selnextpage 1"
2400 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2401 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2402 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2403 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2404 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2405 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2406 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2407 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2408 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2409 bindkey p
"selnextline -1"
2410 bindkey n
"selnextline 1"
2413 bindkey i
"selnextline -1"
2414 bindkey k
"selnextline 1"
2418 bindkey d
"$ctext yview scroll 18 units"
2419 bindkey u
"$ctext yview scroll -18 units"
2420 bindkey
/ {focus
$fstring}
2421 bindkey
<Key-KP_Divide
> {focus
$fstring}
2422 bindkey
<Key-Return
> {dofind
1 1}
2423 bindkey ?
{dofind
-1 1}
2425 bind .
<F5
> updatecommits
2426 bind .
<$M1B-F5> reloadcommits
2427 bind .
<F2
> showrefs
2428 bind .
<Shift-F4
> {newview
0}
2429 catch
{ bind .
<Shift-Key-XF86_Switch_VT_4
> {newview
0} }
2430 bind .
<F4
> edit_or_newview
2431 bind .
<$M1B-q> doquit
2432 bind .
<$M1B-f> {dofind
1 1}
2433 bind .
<$M1B-g> {dofind
1 0}
2434 bind .
<$M1B-r> dosearchback
2435 bind .
<$M1B-s> dosearch
2436 bind .
<$M1B-equal> {incrfont
1}
2437 bind .
<$M1B-plus> {incrfont
1}
2438 bind .
<$M1B-KP_Add> {incrfont
1}
2439 bind .
<$M1B-minus> {incrfont
-1}
2440 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2441 wm protocol . WM_DELETE_WINDOW doquit
2442 bind .
<Destroy
> {stop_backends
}
2443 bind .
<Button-1
> "click %W"
2444 bind $fstring <Key-Return
> {dofind
1 1}
2445 bind $sha1entry <Key-Return
> {gotocommit
; break}
2446 bind $sha1entry <<PasteSelection>> clearsha1
2447 bind $cflist <1> {sel_flist %W %x %y; break}
2448 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2449 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2451 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2452 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2454 set maincursor [. cget -cursor]
2455 set textcursor [$ctext cget -cursor]
2456 set curtextcursor $textcursor
2458 set rowctxmenu .rowctxmenu
2459 makemenu $rowctxmenu {
2460 {mc "Diff this -> selected" command {diffvssel 0}}
2461 {mc "Diff selected -> this" command {diffvssel 1}}
2462 {mc "Make patch" command mkpatch}
2463 {mc "Create tag" command mktag}
2464 {mc "Write commit to file" command writecommit}
2465 {mc "Create new branch" command mkbranch}
2466 {mc "Cherry-pick this commit" command cherrypick}
2467 {mc "Reset HEAD branch to here" command resethead}
2468 {mc "Mark this commit" command markhere}
2469 {mc "Return to mark" command gotomark}
2470 {mc "Find descendant of this and mark" command find_common_desc}
2471 {mc "Compare with marked commit" command compare_commits}
2473 $rowctxmenu configure -tearoff 0
2475 set fakerowmenu .fakerowmenu
2476 makemenu $fakerowmenu {
2477 {mc "Diff this -> selected" command {diffvssel 0}}
2478 {mc "Diff selected -> this" command {diffvssel 1}}
2479 {mc "Make patch" command mkpatch}
2481 $fakerowmenu configure -tearoff 0
2483 set headctxmenu .headctxmenu
2484 makemenu $headctxmenu {
2485 {mc "Check out this branch" command cobranch}
2486 {mc "Remove this branch" command rmbranch}
2488 $headctxmenu configure -tearoff 0
2491 set flist_menu .flistctxmenu
2492 makemenu $flist_menu {
2493 {mc "Highlight this too" command {flist_hl 0}}
2494 {mc "Highlight this only" command {flist_hl 1}}
2495 {mc "External diff" command {external_diff}}
2496 {mc "Blame parent commit" command {external_blame 1}}
2498 $flist_menu configure -tearoff 0
2501 set diff_menu .diffctxmenu
2502 makemenu $diff_menu {
2503 {mc "Show origin of this line" command show_line_source}
2504 {mc "Run git gui blame on this line" command {external_blame_diff}}
2506 $diff_menu configure -tearoff 0
2509 # Windows sends all mouse wheel events to the current focused window, not
2510 # the one where the mouse hovers, so bind those events here and redirect
2511 # to the correct window
2512 proc windows_mousewheel_redirector {W X Y D} {
2513 global canv canv2 canv3
2514 set w [winfo containing -displayof $W $X $Y]
2516 set u [expr {$D < 0 ? 5 : -5}]
2517 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2518 allcanvs yview scroll $u units
2521 $w yview scroll $u units
2527 # Update row number label when selectedline changes
2528 proc selectedline_change {n1 n2 op} {
2529 global selectedline rownumsel
2531 if {$selectedline eq {}} {
2534 set rownumsel [expr {$selectedline + 1}]
2538 # mouse-2 makes all windows scan vertically, but only the one
2539 # the cursor is in scans horizontally
2540 proc canvscan {op w x y} {
2541 global canv canv2 canv3
2542 foreach c [list $canv $canv2 $canv3] {
2551 proc scrollcanv {cscroll f0 f1} {
2552 $cscroll set $f0 $f1
2557 # when we make a key binding for the toplevel, make sure
2558 # it doesn't get triggered when that key is pressed in the
2559 # find string entry widget.
2560 proc bindkey {ev script} {
2563 set escript [bind Entry $ev]
2564 if {$escript == {}} {
2565 set escript [bind Entry <Key>]
2567 foreach e $entries {
2568 bind $e $ev "$escript; break"
2572 # set the focus back to the toplevel for any click outside
2575 global ctext entries
2576 foreach e [concat $entries $ctext] {
2577 if {$w == $e} return
2582 # Adjust the progress bar for a change in requested extent or canvas size
2583 proc adjustprogress {} {
2584 global progresscanv progressitem progresscoords
2585 global fprogitem fprogcoord lastprogupdate progupdatepending
2586 global rprogitem rprogcoord use_ttk
2589 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2593 set w [expr {[winfo width $progresscanv] - 4}]
2594 set x0 [expr {$w * [lindex $progresscoords 0]}]
2595 set x1 [expr {$w * [lindex $progresscoords 1]}]
2596 set h [winfo height $progresscanv]
2597 $progresscanv coords $progressitem $x0 0 $x1 $h
2598 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2599 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2600 set now [clock clicks -milliseconds]
2601 if {$now >= $lastprogupdate + 100} {
2602 set progupdatepending 0
2604 } elseif {!$progupdatepending} {
2605 set progupdatepending 1
2606 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2610 proc doprogupdate {} {
2611 global lastprogupdate progupdatepending
2613 if {$progupdatepending} {
2614 set progupdatepending 0
2615 set lastprogupdate [clock clicks -milliseconds]
2620 proc savestuff {w} {
2621 global canv canv2 canv3 mainfont textfont uifont tabstop
2622 global stuffsaved findmergefiles maxgraphpct
2623 global maxwidth showneartags showlocalchanges
2624 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2625 global cmitmode wrapcomment datetimeformat limitdiffs
2626 global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2627 global autoselect extdifftool perfile_attrs markbgcolor use_ttk
2628 global hideremotes want_ttk
2630 if {$stuffsaved} return
2631 if {![winfo viewable .]} return
2633 if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2634 set f [open "~/.gitk-new" w]
2635 if {$::tcl_platform(platform) eq {windows}} {
2636 file attributes "~/.gitk-new" -hidden true
2638 puts $f [list set mainfont $mainfont]
2639 puts $f [list set textfont $textfont]
2640 puts $f [list set uifont $uifont]
2641 puts $f [list set tabstop $tabstop]
2642 puts $f [list set findmergefiles $findmergefiles]
2643 puts $f [list set maxgraphpct $maxgraphpct]
2644 puts $f [list set maxwidth $maxwidth]
2645 puts $f [list set cmitmode $cmitmode]
2646 puts $f [list set wrapcomment $wrapcomment]
2647 puts $f [list set autoselect $autoselect]
2648 puts $f [list set showneartags $showneartags]
2649 puts $f [list set hideremotes $hideremotes]
2650 puts $f [list set showlocalchanges $showlocalchanges]
2651 puts $f [list set datetimeformat $datetimeformat]
2652 puts $f [list set limitdiffs $limitdiffs]
2653 puts $f [list set uicolor $uicolor]
2654 puts $f [list set want_ttk $want_ttk]
2655 puts $f [list set bgcolor $bgcolor]
2656 puts $f [list set fgcolor $fgcolor]
2657 puts $f [list set colors $colors]
2658 puts $f [list set diffcolors $diffcolors]
2659 puts $f [list set markbgcolor $markbgcolor]
2660 puts $f [list set diffcontext $diffcontext]
2661 puts $f [list set selectbgcolor $selectbgcolor]
2662 puts $f [list set extdifftool $extdifftool]
2663 puts $f [list set perfile_attrs $perfile_attrs]
2665 puts $f "set geometry(main) [wm geometry .]"
2666 puts $f "set geometry(state) [wm state .]"
2667 puts $f "set geometry(topwidth) [winfo width .tf]"
2668 puts $f "set geometry(topheight) [winfo height .tf]"
2670 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2671 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2673 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2674 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2676 puts $f "set geometry(botwidth) [winfo width .bleft]"
2677 puts $f "set geometry(botheight) [winfo height .bleft]"
2679 puts -nonewline $f "set permviews {"
2680 for {set v 0} {$v < $nextviewnum} {incr v} {
2681 if {$viewperm($v)} {
2682 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2687 file rename -force "~/.gitk-new" "~/.gitk"
2692 proc resizeclistpanes {win w} {
2693 global oldwidth use_ttk
2694 if {[info exists oldwidth($win)]} {
2696 set s0 [$win sashpos 0]
2697 set s1 [$win sashpos 1]
2699 set s0 [$win sash coord 0]
2700 set s1 [$win sash coord 1]
2703 set sash0 [expr {int($w/2 - 2)}]
2704 set sash1 [expr {int($w*5/6 - 2)}]
2706 set factor [expr {1.0 * $w / $oldwidth($win)}]
2707 set sash0 [expr {int($factor * [lindex $s0 0])}]
2708 set sash1 [expr {int($factor * [lindex $s1 0])}]
2712 if {$sash1 < $sash0 + 20} {
2713 set sash1 [expr {$sash0 + 20}]
2715 if {$sash1 > $w - 10} {
2716 set sash1 [expr {$w - 10}]
2717 if {$sash0 > $sash1 - 20} {
2718 set sash0 [expr {$sash1 - 20}]
2723 $win sashpos 0 $sash0
2724 $win sashpos 1 $sash1
2726 $win sash place 0 $sash0 [lindex $s0 1]
2727 $win sash place 1 $sash1 [lindex $s1 1]
2730 set oldwidth($win) $w
2733 proc resizecdetpanes {win w} {
2734 global oldwidth use_ttk
2735 if {[info exists oldwidth($win)]} {
2737 set s0 [$win sashpos 0]
2739 set s0 [$win sash coord 0]
2742 set sash0 [expr {int($w*3/4 - 2)}]
2744 set factor [expr {1.0 * $w / $oldwidth($win)}]
2745 set sash0 [expr {int($factor * [lindex $s0 0])}]
2749 if {$sash0 > $w - 15} {
2750 set sash0 [expr {$w - 15}]
2754 $win sashpos 0 $sash0
2756 $win sash place 0 $sash0 [lindex $s0 1]
2759 set oldwidth($win) $w
2762 proc allcanvs args {
2763 global canv canv2 canv3
2769 proc bindall {event action} {
2770 global canv canv2 canv3
2771 bind $canv $event $action
2772 bind $canv2 $event $action
2773 bind $canv3 $event $action
2779 if {[winfo exists $w]} {
2784 wm title $w [mc "About gitk"]
2786 message $w.m -text [mc "
2787 Gitk - a commit viewer for git
2789 Copyright © 2005-2009 Paul Mackerras
2791 Use and redistribute under the terms of the GNU General Public License"] \
2792 -justify center -aspect 400 -border 2 -bg white -relief groove
2793 pack $w.m -side top -fill x -padx 2 -pady 2
2794 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2795 pack $w.ok -side bottom
2796 bind $w <Visibility> "focus $w.ok"
2797 bind $w <Key-Escape> "destroy $w"
2798 bind $w <Key-Return> "destroy $w"
2799 tk::PlaceWindow $w widget .
2805 if {[winfo exists $w]} {
2809 if {[tk windowingsystem] eq {aqua}} {
2815 wm title $w [mc "Gitk key bindings"]
2817 message $w.m -text "
2818 [mc "Gitk key bindings:"]
2820 [mc "<%s-Q> Quit" $M1T]
2821 [mc "<%s-W> Close window" $M1T]
2822 [mc "<Home> Move to first commit"]
2823 [mc "<End> Move to last commit"]
2824 [mc "<Up>, p, i Move up one commit"]
2825 [mc "<Down>, n, k Move down one commit"]
2826 [mc "<Left>, z, j Go back in history list"]
2827 [mc "<Right>, x, l Go forward in history list"]
2828 [mc "<PageUp> Move up one page in commit list"]
2829 [mc "<PageDown> Move down one page in commit list"]
2830 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2831 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2832 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2833 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2834 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2835 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2836 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2837 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2838 [mc "<Delete>, b Scroll diff view up one page"]
2839 [mc "<Backspace> Scroll diff view up one page"]
2840 [mc "<Space> Scroll diff view down one page"]
2841 [mc "u Scroll diff view up 18 lines"]
2842 [mc "d Scroll diff view down 18 lines"]
2843 [mc "<%s-F> Find" $M1T]
2844 [mc "<%s-G> Move to next find hit" $M1T]
2845 [mc "<Return> Move to next find hit"]
2846 [mc "/ Focus the search box"]
2847 [mc "? Move to previous find hit"]
2848 [mc "f Scroll diff view to next file"]
2849 [mc "<%s-S> Search for next hit in diff view" $M1T]
2850 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2851 [mc "<%s-KP+> Increase font size" $M1T]
2852 [mc "<%s-plus> Increase font size" $M1T]
2853 [mc "<%s-KP-> Decrease font size" $M1T]
2854 [mc "<%s-minus> Decrease font size" $M1T]
2857 -justify left -bg white -border 2 -relief groove
2858 pack $w.m -side top -fill both -padx 2 -pady 2
2859 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2860 bind $w <Key-Escape> [list destroy $w]
2861 pack $w.ok -side bottom
2862 bind $w <Visibility> "focus $w.ok"
2863 bind $w <Key-Escape> "destroy $w"
2864 bind $w <Key-Return> "destroy $w"
2867 # Procedures for manipulating the file list window at the
2868 # bottom right of the overall window.
2870 proc treeview {w l openlevs} {
2871 global treecontents treediropen treeheight treeparent treeindex
2881 set treecontents() {}
2882 $w conf -state normal
2884 while {[string range $f 0 $prefixend] ne $prefix} {
2885 if {$lev <= $openlevs} {
2886 $w mark set e:$treeindex($prefix) "end -1c"
2887 $w mark gravity e:$treeindex($prefix) left
2889 set treeheight($prefix) $ht
2890 incr ht [lindex $htstack end]
2891 set htstack [lreplace $htstack end end]
2892 set prefixend [lindex $prefendstack end]
2893 set prefendstack [lreplace $prefendstack end end]
2894 set prefix [string range $prefix 0 $prefixend]
2897 set tail [string range $f [expr {$prefixend+1}] end]
2898 while {[set slash [string first "/" $tail]] >= 0} {
2901 lappend prefendstack $prefixend
2902 incr prefixend [expr {$slash + 1}]
2903 set d [string range $tail 0 $slash]
2904 lappend treecontents($prefix) $d
2905 set oldprefix $prefix
2907 set treecontents($prefix) {}
2908 set treeindex($prefix) [incr ix]
2909 set treeparent($prefix) $oldprefix
2910 set tail [string range $tail [expr {$slash+1}] end]
2911 if {$lev <= $openlevs} {
2913 set treediropen($prefix) [expr {$lev < $openlevs}]
2914 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2915 $w mark set d:$ix "end -1c"
2916 $w mark gravity d:$ix left
2918 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2920 $w image create end -align center -image $bm -padx 1 \
2922 $w insert end $d [highlight_tag $prefix]
2923 $w mark set s:$ix "end -1c"
2924 $w mark gravity s:$ix left
2929 if {$lev <= $openlevs} {
2932 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2934 $w insert end $tail [highlight_tag $f]
2936 lappend treecontents($prefix) $tail
2939 while {$htstack ne {}} {
2940 set treeheight($prefix) $ht
2941 incr ht [lindex $htstack end]
2942 set htstack [lreplace $htstack end end]
2943 set prefixend [lindex $prefendstack end]
2944 set prefendstack [lreplace $prefendstack end end]
2945 set prefix [string range $prefix 0 $prefixend]
2947 $w conf -state disabled
2950 proc linetoelt {l} {
2951 global treeheight treecontents
2956 foreach e $treecontents($prefix) {
2961 if {[string index $e end] eq "/"} {
2962 set n $treeheight($prefix$e)
2974 proc highlight_tree {y prefix} {
2975 global treeheight treecontents cflist
2977 foreach e $treecontents($prefix) {
2979 if {[highlight_tag $path] ne {}} {
2980 $cflist tag add bold $y.0 "$y.0 lineend"
2983 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2984 set y [highlight_tree $y $path]
2990 proc treeclosedir {w dir} {
2991 global treediropen treeheight treeparent treeindex
2993 set ix $treeindex($dir)
2994 $w conf -state normal
2995 $w delete s:$ix e:$ix
2996 set treediropen($dir) 0
2997 $w image configure a:$ix -image tri-rt
2998 $w conf -state disabled
2999 set n [expr {1 - $treeheight($dir)}]
3000 while {$dir ne {}} {
3001 incr treeheight($dir) $n
3002 set dir $treeparent($dir)
3006 proc treeopendir {w dir} {
3007 global treediropen treeheight treeparent treecontents treeindex
3009 set ix $treeindex($dir)
3010 $w conf -state normal
3011 $w image configure a:$ix -image tri-dn
3012 $w mark set e:$ix s:$ix
3013 $w mark gravity e:$ix right
3016 set n [llength $treecontents($dir)]
3017 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3020 incr treeheight($x) $n
3022 foreach e $treecontents($dir) {
3024 if {[string index $e end] eq "/"} {
3025 set iy $treeindex($de)
3026 $w mark set d:$iy e:$ix
3027 $w mark gravity d:$iy left
3028 $w insert e:$ix $str
3029 set treediropen($de) 0
3030 $w image create e:$ix -align center -image tri-rt -padx 1 \
3032 $w insert e:$ix $e [highlight_tag $de]
3033 $w mark set s:$iy e:$ix
3034 $w mark gravity s:$iy left
3035 set treeheight($de) 1
3037 $w insert e:$ix $str
3038 $w insert e:$ix $e [highlight_tag $de]
3041 $w mark gravity e:$ix right
3042 $w conf -state disabled
3043 set treediropen($dir) 1
3044 set top [lindex [split [$w index @0,0] .] 0]
3045 set ht [$w cget -height]
3046 set l [lindex [split [$w index s:$ix] .] 0]
3049 } elseif {$l + $n + 1 > $top + $ht} {
3050 set top [expr {$l + $n + 2 - $ht}]
3058 proc treeclick {w x y} {
3059 global treediropen cmitmode ctext cflist cflist_top
3061 if {$cmitmode ne "tree"} return
3062 if {![info exists cflist_top]} return
3063 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3064 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3065 $cflist tag add highlight $l.0 "$l.0 lineend"
3071 set e [linetoelt $l]
3072 if {[string index $e end] ne "/"} {
3074 } elseif {$treediropen($e)} {
3081 proc setfilelist {id} {
3082 global treefilelist cflist jump_to_here
3084 treeview $cflist $treefilelist($id) 0
3085 if {$jump_to_here ne {}} {
3086 set f [lindex $jump_to_here 0]
3087 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3093 image create bitmap tri-rt -background black -foreground blue -data {
3094 #define tri-rt_width 13
3095 #define tri-rt_height 13
3096 static unsigned char tri-rt_bits[] = {
3097 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3098 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3101 #define tri-rt-mask_width 13
3102 #define tri-rt-mask_height 13
3103 static unsigned char tri-rt-mask_bits[] = {
3104 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3105 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3108 image create bitmap tri-dn -background black -foreground blue -data {
3109 #define tri-dn_width 13
3110 #define tri-dn_height 13
3111 static unsigned char tri-dn_bits[] = {
3112 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3113 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3116 #define tri-dn-mask_width 13
3117 #define tri-dn-mask_height 13
3118 static unsigned char tri-dn-mask_bits[] = {
3119 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3120 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3124 image create bitmap reficon-T -background black -foreground yellow -data {
3125 #define tagicon_width 13
3126 #define tagicon_height 9
3127 static unsigned char tagicon_bits[] = {
3128 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3129 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3131 #define tagicon-mask_width 13
3132 #define tagicon-mask_height 9
3133 static unsigned char tagicon-mask_bits[] = {
3134 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3135 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3138 #define headicon_width 13
3139 #define headicon_height 9
3140 static unsigned char headicon_bits[] = {
3141 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3142 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3145 #define headicon-mask_width 13
3146 #define headicon-mask_height 9
3147 static unsigned char headicon-mask_bits[] = {
3148 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3149 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3151 image create bitmap reficon-H -background black -foreground green \
3152 -data $rectdata -maskdata $rectmask
3153 image create bitmap reficon-o -background black -foreground "#ddddff" \
3154 -data $rectdata -maskdata $rectmask
3156 proc init_flist {first} {
3157 global cflist cflist_top difffilestart
3159 $cflist conf -state normal
3160 $cflist delete 0.0 end
3162 $cflist insert end $first
3164 $cflist tag add highlight 1.0 "1.0 lineend"
3166 catch {unset cflist_top}
3168 $cflist conf -state disabled
3169 set difffilestart {}
3172 proc highlight_tag {f} {
3173 global highlight_paths
3175 foreach p $highlight_paths {
3176 if {[string match $p $f]} {
3183 proc highlight_filelist {} {
3184 global cmitmode cflist
3186 $cflist conf -state normal
3187 if {$cmitmode ne "tree"} {
3188 set end [lindex [split [$cflist index end] .] 0]
3189 for {set l 2} {$l < $end} {incr l} {
3190 set line [$cflist get $l.0 "$l.0 lineend"]
3191 if {[highlight_tag $line] ne {}} {
3192 $cflist tag add bold $l.0 "$l.0 lineend"
3198 $cflist conf -state disabled
3201 proc unhighlight_filelist {} {
3204 $cflist conf -state normal
3205 $cflist tag remove bold 1.0 end
3206 $cflist conf -state disabled
3209 proc add_flist {fl} {
3212 $cflist conf -state normal
3214 $cflist insert end "\n"
3215 $cflist insert end $f [highlight_tag $f]
3217 $cflist conf -state disabled
3220 proc sel_flist {w x y} {
3221 global ctext difffilestart cflist cflist_top cmitmode
3223 if {$cmitmode eq "tree"} return
3224 if {![info exists cflist_top]} return
3225 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3226 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3227 $cflist tag add highlight $l.0 "$l.0 lineend"
3232 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3236 proc pop_flist_menu {w X Y x y} {
3237 global ctext cflist cmitmode flist_menu flist_menu_file
3238 global treediffs diffids
3241 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3243 if {$cmitmode eq "tree"} {
3244 set e [linetoelt $l]
3245 if {[string index $e end] eq "/"} return
3247 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3249 set flist_menu_file $e
3250 set xdiffstate "normal"
3251 if {$cmitmode eq "tree"} {
3252 set xdiffstate "disabled"
3254 # Disable "External diff" item in tree mode
3255 $flist_menu entryconf 2 -state $xdiffstate
3256 tk_popup $flist_menu $X $Y
3259 proc find_ctext_fileinfo {line} {
3260 global ctext_file_names ctext_file_lines
3262 set ok [bsearch $ctext_file_lines $line]
3263 set tline [lindex $ctext_file_lines $ok]
3265 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3268 return [list [lindex $ctext_file_names $ok] $tline]
3272 proc pop_diff_menu {w X Y x y} {
3273 global ctext diff_menu flist_menu_file
3274 global diff_menu_txtpos diff_menu_line
3275 global diff_menu_filebase
3277 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3278 set diff_menu_line [lindex $diff_menu_txtpos 0]
3279 # don't pop up the menu on hunk-separator or file-separator lines
3280 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3284 set f [find_ctext_fileinfo $diff_menu_line]
3285 if {$f eq {}} return
3286 set flist_menu_file [lindex $f 0]
3287 set diff_menu_filebase [lindex $f 1]
3288 tk_popup $diff_menu $X $Y
3291 proc flist_hl {only} {
3292 global flist_menu_file findstring gdttype
3294 set x [shellquote $flist_menu_file]
3295 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3298 append findstring " " $x
3300 set gdttype [mc "touching paths:"]
3303 proc gitknewtmpdir {} {
3304 global diffnum gitktmpdir gitdir
3306 if {![info exists gitktmpdir]} {
3307 set gitktmpdir [file join [file dirname $gitdir] \
3308 [format ".gitk-tmp.%s" [pid]]]
3309 if {[catch {file mkdir $gitktmpdir} err]} {
3310 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3317 set diffdir [file join $gitktmpdir $diffnum]
3318 if {[catch {file mkdir $diffdir} err]} {
3319 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3325 proc save_file_from_commit {filename output what} {
3328 if {[catch {exec git show $filename -- > $output} err]} {
3329 if {[string match "fatal: bad revision *" $err]} {
3332 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3338 proc external_diff_get_one_file {diffid filename diffdir} {
3339 global nullid nullid2 nullfile
3342 if {$diffid == $nullid} {
3343 set difffile [file join [file dirname $gitdir] $filename]
3344 if {[file exists $difffile]} {
3349 if {$diffid == $nullid2} {
3350 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3351 return [save_file_from_commit :$filename $difffile index]
3353 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3354 return [save_file_from_commit $diffid:$filename $difffile \
3358 proc external_diff {} {
3359 global nullid nullid2
3360 global flist_menu_file
3364 if {[llength $diffids] == 1} {
3365 # no reference commit given
3366 set diffidto [lindex $diffids 0]
3367 if {$diffidto eq $nullid} {
3368 # diffing working copy with index
3369 set diffidfrom $nullid2
3370 } elseif {$diffidto eq $nullid2} {
3371 # diffing index with HEAD
3372 set diffidfrom "HEAD"
3374 # use first parent commit
3375 global parentlist selectedline
3376 set diffidfrom [lindex $parentlist $selectedline 0]
3379 set diffidfrom [lindex $diffids 0]
3380 set diffidto [lindex $diffids 1]
3383 # make sure that several diffs wont collide
3384 set diffdir [gitknewtmpdir]
3385 if {$diffdir eq {}} return
3387 # gather files to diff
3388 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3389 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3391 if {$difffromfile ne {} && $difftofile ne {}} {
3392 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3393 if {[catch {set fl [open |$cmd r]} err]} {
3394 file delete -force $diffdir
3395 error_popup "$extdifftool: [mc "command failed:"] $err"
3397 fconfigure $fl -blocking 0
3398 filerun $fl [list delete_at_eof $fl $diffdir]
3403 proc find_hunk_blamespec {base line} {
3406 # Find and parse the hunk header
3407 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3408 if {$s_lix eq {}} return
3410 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3411 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3412 s_line old_specs osz osz1 new_line nsz]} {
3416 # base lines for the parents
3417 set base_lines [list $new_line]
3418 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3419 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3420 old_spec old_line osz]} {
3423 lappend base_lines $old_line
3426 # Now scan the lines to determine offset within the hunk
3427 set max_parent [expr {[llength $base_lines]-2}]
3429 set s_lno [lindex [split $s_lix "."] 0]
3431 # Determine if the line is removed
3432 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3433 if {[string match {[-+ ]*} $chunk]} {
3434 set removed_idx [string first "-" $chunk]
3435 # Choose a parent index
3436 if {$removed_idx >= 0} {
3437 set parent $removed_idx
3439 set unchanged_idx [string first " " $chunk]
3440 if {$unchanged_idx >= 0} {
3441 set parent $unchanged_idx
3443 # blame the current commit
3447 # then count other lines that belong to it
3448 for {set i $line} {[incr i -1] > $s_lno} {} {
3449 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3450 # Determine if the line is removed
3451 set removed_idx [string first "-" $chunk]
3453 set code [string index $chunk $parent]
3454 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3458 if {$removed_idx < 0} {
3468 incr dline [lindex $base_lines $parent]
3469 return [list $parent $dline]
3472 proc external_blame_diff {} {
3473 global currentid cmitmode
3474 global diff_menu_txtpos diff_menu_line
3475 global diff_menu_filebase flist_menu_file
3477 if {$cmitmode eq "tree"} {
3479 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3481 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3483 set parent_idx [lindex $hinfo 0]
3484 set line [lindex $hinfo 1]
3491 external_blame $parent_idx $line
3494 # Find the SHA1 ID of the blob for file $fname in the index
3496 proc index_sha1 {fname} {
3497 set f [open [list | git ls-files -s $fname] r]
3498 while {[gets $f line] >= 0} {
3499 set info [lindex [split $line "\t"] 0]
3500 set stage [lindex $info 2]
3501 if {$stage eq "0" || $stage eq "2"} {
3503 return [lindex $info 1]
3510 # Turn an absolute path into one relative to the current directory
3511 proc make_relative {f} {
3512 if {[file pathtype $f] eq "relative"} {
3515 set elts [file split $f]
3516 set here [file split [pwd]]
3521 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3528 set elts [concat $res [lrange $elts $ei end]]
3529 return [eval file join $elts]
3532 proc external_blame {parent_idx {line {}}} {
3533 global flist_menu_file gitdir
3534 global nullid nullid2
3535 global parentlist selectedline currentid
3537 if {$parent_idx > 0} {
3538 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3540 set base_commit $currentid
3543 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3544 error_popup [mc "No such commit"]
3548 set cmdline [list git gui blame]
3549 if {$line ne {} && $line > 1} {
3550 lappend cmdline "--line=$line"
3552 set f [file join [file dirname $gitdir] $flist_menu_file]
3553 # Unfortunately it seems git gui blame doesn't like
3554 # being given an absolute path...
3555 set f [make_relative $f]
3556 lappend cmdline $base_commit $f
3557 if {[catch {eval exec $cmdline &} err]} {
3558 error_popup "[mc "git gui blame: command failed:"] $err"
3562 proc show_line_source {} {
3563 global cmitmode currentid parents curview blamestuff blameinst
3564 global diff_menu_line diff_menu_filebase flist_menu_file
3565 global nullid nullid2 gitdir
3568 if {$cmitmode eq "tree"} {
3570 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3572 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3573 if {$h eq {}} return
3574 set pi [lindex $h 0]
3576 mark_ctext_line $diff_menu_line
3580 if {$currentid eq $nullid} {
3582 # must be a merge in progress...
3584 # get the last line from .git/MERGE_HEAD
3585 set f [open [file join $gitdir MERGE_HEAD] r]
3586 set id [lindex [split [read $f] "\n"] end-1]
3589 error_popup [mc "Couldn't read merge head: %s" $err]
3592 } elseif {$parents($curview,$currentid) eq $nullid2} {
3593 # need to do the blame from the index
3595 set from_index [index_sha1 $flist_menu_file]
3597 error_popup [mc "Error reading index: %s" $err]
3601 set id $parents($curview,$currentid)
3604 set id [lindex $parents($curview,$currentid) $pi]
3606 set line [lindex $h 1]
3609 if {$from_index ne {}} {
3610 lappend blameargs | git cat-file blob $from_index
3612 lappend blameargs | git blame -p -L$line,+1
3613 if {$from_index ne {}} {
3614 lappend blameargs --contents -
3616 lappend blameargs $id
3618 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3620 set f [open $blameargs r]
3622 error_popup [mc "Couldn't start git blame: %s" $err]
3625 nowbusy blaming [mc "Searching"]
3626 fconfigure $f -blocking 0
3627 set i [reg_instance $f]
3628 set blamestuff($i) {}
3630 filerun $f [list read_line_source $f $i]
3633 proc stopblaming {} {
3636 if {[info exists blameinst]} {
3637 stop_instance $blameinst
3643 proc read_line_source {fd inst} {
3644 global blamestuff curview commfd blameinst nullid nullid2
3646 while {[gets $fd line] >= 0} {
3647 lappend blamestuff($inst) $line
3655 fconfigure $fd -blocking 1
3656 if {[catch {close $fd} err]} {
3657 error_popup [mc "Error running git blame: %s" $err]
3662 set line [split [lindex $blamestuff($inst) 0] " "]
3663 set id [lindex $line 0]
3664 set lnum [lindex $line 1]
3665 if {[string length $id] == 40 && [string is xdigit $id] &&
3666 [string is digit -strict $lnum]} {
3667 # look for "filename" line
3668 foreach l $blamestuff($inst) {
3669 if {[string match "filename *" $l]} {
3670 set fname [string range $l 9 end]
3676 # all looks good, select it
3677 if {$id eq $nullid} {
3678 # blame uses all-zeroes to mean not committed,
3679 # which would mean a change in the index
3682 if {[commitinview $id $curview]} {
3683 selectline [rowofcommit $id] 1 [list $fname $lnum]
3685 error_popup [mc "That line comes from commit %s, \
3686 which is not in this view" [shortids $id]]
3689 puts "oops couldn't parse git blame output"
3694 # delete $dir when we see eof on $f (presumably because the child has exited)
3695 proc delete_at_eof {f dir} {
3696 while {[gets $f line] >= 0} {}
3698 if {[catch {close $f} err]} {
3699 error_popup "[mc "External diff viewer failed:"] $err"
3701 file delete -force $dir
3707 # Functions for adding and removing shell-type quoting
3709 proc shellquote {str} {
3710 if {![string match "*\['\"\\ \t]*" $str]} {
3713 if {![string match "*\['\"\\]*" $str]} {
3716 if {![string match "*'*" $str]} {
3719 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3722 proc shellarglist {l} {
3728 append str [shellquote $a]
3733 proc shelldequote {str} {
3738 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3739 append ret [string range $str $used end]
3740 set used [string length $str]
3743 set first [lindex $first 0]
3744 set ch [string index $str $first]
3745 if {$first > $used} {
3746 append ret [string range $str $used [expr {$first - 1}]]
3749 if {$ch eq " " || $ch eq "\t"} break
3752 set first [string first "'" $str $used]
3754 error "unmatched single-quote"
3756 append ret [string range $str $used [expr {$first - 1}]]
3761 if {$used >= [string length $str]} {
3762 error "trailing backslash"
3764 append ret [string index $str $used]
3769 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3770 error "unmatched double-quote"
3772 set first [lindex $first 0]
3773 set ch [string index $str $first]
3774 if {$first > $used} {
3775 append ret [string range $str $used [expr {$first - 1}]]
3778 if {$ch eq "\""} break
3780 append ret [string index $str $used]
3784 return [list $used $ret]
3787 proc shellsplit {str} {
3790 set str [string trimleft $str]
3791 if {$str eq {}} break
3792 set dq [shelldequote $str]
3793 set n [lindex $dq 0]
3794 set word [lindex $dq 1]
3795 set str [string range $str $n end]
3801 # Code to implement multiple views
3803 proc newview {ishighlight} {
3804 global nextviewnum newviewname newishighlight
3805 global revtreeargs viewargscmd newviewopts curview
3807 set newishighlight $ishighlight
3809 if {[winfo exists $top]} {
3813 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3814 set newviewopts($nextviewnum,perm) 0
3815 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3816 decode_view_opts $nextviewnum $revtreeargs
3817 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3820 set known_view_options {
3821 {perm b . {} {mc "Remember this view"}}
3822 {reflabel l + {} {mc "References (space separated list):"}}
3823 {refs t15 .. {} {mc "Branches & tags:"}}
3824 {allrefs b *. "--all" {mc "All refs"}}
3825 {branches b . "--branches" {mc "All (local) branches"}}
3826 {tags b . "--tags" {mc "All tags"}}
3827 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3828 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3829 {author t15 .. "--author=*" {mc "Author:"}}
3830 {committer t15 . "--committer=*" {mc "Committer:"}}
3831 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3832 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3833 {changes_l l + {} {mc "Changes to Files:"}}
3834 {pickaxe_s r0 . {} {mc "Fixed String"}}
3835 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3836 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3837 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3838 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3839 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3840 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3841 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3842 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3843 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3844 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3845 {lright b . "--left-right" {mc "Mark branch sides"}}
3846 {first b . "--first-parent" {mc "Limit to first parent"}}
3847 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3848 {args t50 *. {} {mc "Additional arguments to git log:"}}
3849 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3850 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3853 proc encode_view_opts {n} {
3854 global known_view_options newviewopts
3857 foreach opt $known_view_options {
3858 set patterns [lindex $opt 3]
3859 if {$patterns eq {}} continue
3860 set pattern [lindex $patterns 0]
3862 if {[lindex $opt 1] eq "b"} {
3863 set val $newviewopts($n,[lindex $opt 0])
3865 lappend rargs $pattern
3867 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3868 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3869 set val $newviewopts($n,$button_id)
3870 if {$val eq $value} {
3871 lappend rargs $pattern
3874 set val $newviewopts($n,[lindex $opt 0])
3875 set val [string trim $val]
3877 set pfix [string range $pattern 0 end-1]
3878 lappend rargs $pfix$val
3882 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3883 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3886 proc decode_view_opts {n view_args} {
3887 global known_view_options newviewopts
3889 foreach opt $known_view_options {
3890 set id [lindex $opt 0]
3891 if {[lindex $opt 1] eq "b"} {
3894 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3896 regexp {^(.*_)} $id uselessvar id
3902 set newviewopts($n,$id) $val
3906 foreach arg $view_args {
3907 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3908 && ![info exists found(limit)]} {
3909 set newviewopts($n,limit) $cnt
3914 foreach opt $known_view_options {
3915 set id [lindex $opt 0]
3916 if {[info exists found($id)]} continue
3917 foreach pattern [lindex $opt 3] {
3918 if {![string match $pattern $arg]} continue
3919 if {[lindex $opt 1] eq "b"} {
3922 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3924 regexp {^(.*_)} $id uselessvar id
3928 set size [string length $pattern]
3929 set val [string range $arg [expr {$size-1}] end]
3931 set newviewopts($n,$id) $val
3935 if {[info exists val]} break
3937 if {[info exists val]} continue
3938 if {[regexp {^-} $arg]} {
3941 lappend refargs $arg
3944 set newviewopts($n,refs) [shellarglist $refargs]
3945 set newviewopts($n,args) [shellarglist $oargs]
3948 proc edit_or_newview {} {
3960 global viewname viewperm newviewname newviewopts
3961 global viewargs viewargscmd
3963 set top .gitkvedit-$curview
3964 if {[winfo exists $top]} {
3968 set newviewname($curview) $viewname($curview)
3969 set newviewopts($curview,perm) $viewperm($curview)
3970 set newviewopts($curview,cmd) $viewargscmd($curview)
3971 decode_view_opts $curview $viewargs($curview)
3972 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3975 proc vieweditor {top n title} {
3976 global newviewname newviewopts viewfiles bgcolor
3977 global known_view_options NS
3980 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3981 make_transient $top .
3984 ${NS}::frame $top.nfr
3985 ${NS}::label $top.nl -text [mc "View Name"]
3986 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
3987 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3988 pack $top.nl -in $top.nfr -side left -padx {0 5}
3989 pack $top.name -in $top.nfr -side left -padx {0 25}
3995 foreach opt $known_view_options {
3996 set id [lindex $opt 0]
3997 set type [lindex $opt 1]
3998 set flags [lindex $opt 2]
3999 set title [eval [lindex $opt 4]]
4002 if {$flags eq "+" || $flags eq "*"} {
4003 set cframe $top.fr$cnt
4005 ${NS}::frame $cframe
4006 pack $cframe -in $top -fill x -pady 3 -padx 3
4007 set cexpand [expr {$flags eq "*"}]
4008 } elseif {$flags eq ".." || $flags eq "*."} {
4009 set cframe $top.fr$cnt
4011 ${NS}::frame $cframe
4012 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4013 set cexpand [expr {$flags eq "*."}]
4019 ${NS}::label $cframe.l_$id -text $title
4020 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4021 } elseif {$type eq "b"} {
4022 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4023 pack $cframe.c_$id -in $cframe -side left \
4024 -padx [list $lxpad 0] -expand $cexpand -anchor w
4025 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4026 regexp {^(.*_)} $id uselessvar button_id
4027 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4028 pack $cframe.c_$id -in $cframe -side left \
4029 -padx [list $lxpad 0] -expand $cexpand -anchor w
4030 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4031 ${NS}::label $cframe.l_$id -text $title
4032 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4033 -textvariable newviewopts($n,$id)
4034 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4035 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4036 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4037 ${NS}::label $cframe.l_$id -text $title
4038 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4039 -textvariable newviewopts($n,$id)
4040 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4041 pack $cframe.e_$id -in $cframe -side top -fill x
4042 } elseif {$type eq "path"} {
4043 ${NS}::label $top.l -text $title
4044 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4045 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
4046 if {[info exists viewfiles($n)]} {
4047 foreach f $viewfiles($n) {
4048 $top.t insert end $f
4049 $top.t insert end "\n"
4051 $top.t delete {end - 1c} end
4052 $top.t mark set insert 0.0
4054 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4058 ${NS}::frame $top.buts
4059 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4060 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4061 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4062 bind $top <Control-Return> [list newviewok $top $n]
4063 bind $top <F5> [list newviewok $top $n 1]
4064 bind $top <Escape> [list destroy $top]
4065 grid $top.buts.ok $top.buts.apply $top.buts.can
4066 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4067 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4068 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4069 pack $top.buts -in $top -side top -fill x
4073 proc doviewmenu {m first cmd op argv} {
4074 set nmenu [$m index end]
4075 for {set i $first} {$i <= $nmenu} {incr i} {
4076 if {[$m entrycget $i -command] eq $cmd} {
4077 eval $m $op $i $argv
4083 proc allviewmenus {n op args} {
4086 doviewmenu .bar.view 5 [list showview $n] $op $args
4087 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4090 proc newviewok {top n {apply 0}} {
4091 global nextviewnum newviewperm newviewname newishighlight
4092 global viewname viewfiles viewperm selectedview curview
4093 global viewargs viewargscmd newviewopts viewhlmenu
4096 set newargs [encode_view_opts $n]
4098 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4102 foreach f [split [$top.t get 0.0 end] "\n"] {
4103 set ft [string trim $f]
4108 if {![info exists viewfiles($n)]} {
4109 # creating a new view
4111 set viewname($n) $newviewname($n)
4112 set viewperm($n) $newviewopts($n,perm)
4113 set viewfiles($n) $files
4114 set viewargs($n) $newargs
4115 set viewargscmd($n) $newviewopts($n,cmd)
4117 if {!$newishighlight} {
4120 run addvhighlight $n
4123 # editing an existing view
4124 set viewperm($n) $newviewopts($n,perm)
4125 if {$newviewname($n) ne $viewname($n)} {
4126 set viewname($n) $newviewname($n)
4127 doviewmenu .bar.view 5 [list showview $n] \
4128 entryconf [list -label $viewname($n)]
4129 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4130 # entryconf [list -label $viewname($n) -value $viewname($n)]
4132 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4133 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4134 set viewfiles($n) $files
4135 set viewargs($n) $newargs
4136 set viewargscmd($n) $newviewopts($n,cmd)
4137 if {$curview == $n} {
4143 catch {destroy $top}
4147 global curview viewperm hlview selectedhlview
4149 if {$curview == 0} return
4150 if {[info exists hlview] && $hlview == $curview} {
4151 set selectedhlview [mc "None"]
4154 allviewmenus $curview delete
4155 set viewperm($curview) 0
4159 proc addviewmenu {n} {
4160 global viewname viewhlmenu
4162 .bar.view add radiobutton -label $viewname($n) \
4163 -command [list showview $n] -variable selectedview -value $n
4164 #$viewhlmenu add radiobutton -label $viewname($n) \
4165 # -command [list addvhighlight $n] -variable selectedhlview
4169 global curview cached_commitrow ordertok
4170 global displayorder parentlist rowidlist rowisopt rowfinal
4171 global colormap rowtextx nextcolor canvxmax
4172 global numcommits viewcomplete
4173 global selectedline currentid canv canvy0
4175 global pending_select mainheadid
4178 global hlview selectedhlview commitinterest
4180 if {$n == $curview} return
4182 set ymax [lindex [$canv cget -scrollregion] 3]
4183 set span [$canv yview]
4184 set ytop [expr {[lindex $span 0] * $ymax}]
4185 set ybot [expr {[lindex $span 1] * $ymax}]
4186 set yscreen [expr {($ybot - $ytop) / 2}]
4187 if {$selectedline ne {}} {
4188 set selid $currentid
4189 set y [yc $selectedline]
4190 if {$ytop < $y && $y < $ybot} {
4191 set yscreen [expr {$y - $ytop}]
4193 } elseif {[info exists pending_select]} {
4194 set selid $pending_select
4195 unset pending_select
4199 catch {unset treediffs}
4201 if {[info exists hlview] && $hlview == $n} {
4203 set selectedhlview [mc "None"]
4205 catch {unset commitinterest}
4206 catch {unset cached_commitrow}
4207 catch {unset ordertok}
4211 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4212 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4215 if {![info exists viewcomplete($n)]} {
4225 set numcommits $commitidx($n)
4227 catch {unset colormap}
4228 catch {unset rowtextx}
4230 set canvxmax [$canv cget -width]
4236 if {$selid ne {} && [commitinview $selid $n]} {
4237 set row [rowofcommit $selid]
4238 # try to get the selected row in the same position on the screen
4239 set ymax [lindex [$canv cget -scrollregion] 3]
4240 set ytop [expr {[yc $row] - $yscreen}]
4244 set yf [expr {$ytop * 1.0 / $ymax}]
4246 allcanvs yview moveto $yf
4250 } elseif {!$viewcomplete($n)} {
4251 reset_pending_select $selid
4253 reset_pending_select {}
4255 if {[commitinview $pending_select $curview]} {
4256 selectline [rowofcommit $pending_select] 1
4258 set row [first_real_row]
4259 if {$row < $numcommits} {
4264 if {!$viewcomplete($n)} {
4265 if {$numcommits == 0} {
4266 show_status [mc "Reading commits..."]
4268 } elseif {$numcommits == 0} {
4269 show_status [mc "No commits selected"]
4273 # Stuff relating to the highlighting facility
4275 proc ishighlighted {id} {
4276 global vhighlights fhighlights nhighlights rhighlights
4278 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4279 return $nhighlights($id)
4281 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4282 return $vhighlights($id)
4284 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4285 return $fhighlights($id)
4287 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4288 return $rhighlights($id)
4293 proc bolden {id font} {
4294 global canv linehtag currentid boldids need_redisplay markedid
4296 # need_redisplay = 1 means the display is stale and about to be redrawn
4297 if {$need_redisplay} return
4299 $canv itemconf $linehtag($id) -font $font
4300 if {[info exists currentid] && $id eq $currentid} {
4302 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4303 -outline {{}} -tags secsel \
4304 -fill [$canv cget -selectbackground]]
4307 if {[info exists markedid] && $id eq $markedid} {
4312 proc bolden_name {id font} {
4313 global canv2 linentag currentid boldnameids need_redisplay
4315 if {$need_redisplay} return
4316 lappend boldnameids $id
4317 $canv2 itemconf $linentag($id) -font $font
4318 if {[info exists currentid] && $id eq $currentid} {
4319 $canv2 delete secsel
4320 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4321 -outline {{}} -tags secsel \
4322 -fill [$canv2 cget -selectbackground]]
4331 foreach id $boldids {
4332 if {![ishighlighted $id]} {
4335 lappend stillbold $id
4338 set boldids $stillbold
4341 proc addvhighlight {n} {
4342 global hlview viewcomplete curview vhl_done commitidx
4344 if {[info exists hlview]} {
4348 if {$n != $curview && ![info exists viewcomplete($n)]} {
4351 set vhl_done $commitidx($hlview)
4352 if {$vhl_done > 0} {
4357 proc delvhighlight {} {
4358 global hlview vhighlights
4360 if {![info exists hlview]} return
4362 catch {unset vhighlights}
4366 proc vhighlightmore {} {
4367 global hlview vhl_done commitidx vhighlights curview
4369 set max $commitidx($hlview)
4370 set vr [visiblerows]
4371 set r0 [lindex $vr 0]
4372 set r1 [lindex $vr 1]
4373 for {set i $vhl_done} {$i < $max} {incr i} {
4374 set id [commitonrow $i $hlview]
4375 if {[commitinview $id $curview]} {
4376 set row [rowofcommit $id]
4377 if {$r0 <= $row && $row <= $r1} {
4378 if {![highlighted $row]} {
4379 bolden $id mainfontbold
4381 set vhighlights($id) 1
4389 proc askvhighlight {row id} {
4390 global hlview vhighlights iddrawn
4392 if {[commitinview $id $hlview]} {
4393 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4394 bolden $id mainfontbold
4396 set vhighlights($id) 1
4398 set vhighlights($id) 0
4402 proc hfiles_change {} {
4403 global highlight_files filehighlight fhighlights fh_serial
4404 global highlight_paths
4406 if {[info exists filehighlight]} {
4407 # delete previous highlights
4408 catch {close $filehighlight}
4410 catch {unset fhighlights}
4412 unhighlight_filelist
4414 set highlight_paths {}
4415 after cancel do_file_hl $fh_serial
4417 if {$highlight_files ne {}} {
4418 after 300 do_file_hl $fh_serial
4422 proc gdttype_change {name ix op} {
4423 global gdttype highlight_files findstring findpattern
4426 if {$findstring ne {}} {
4427 if {$gdttype eq [mc "containing:"]} {
4428 if {$highlight_files ne {}} {
4429 set highlight_files {}
4434 if {$findpattern ne {}} {
4438 set highlight_files $findstring
4443 # enable/disable findtype/findloc menus too
4446 proc find_change {name ix op} {
4447 global gdttype findstring highlight_files
4450 if {$gdttype eq [mc "containing:"]} {
4453 if {$highlight_files ne $findstring} {
4454 set highlight_files $findstring
4461 proc findcom_change args {
4462 global nhighlights boldnameids
4463 global findpattern findtype findstring gdttype
4466 # delete previous highlights, if any
4467 foreach id $boldnameids {
4468 bolden_name $id mainfont
4471 catch {unset nhighlights}
4474 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4476 } elseif {$findtype eq [mc "Regexp"]} {
4477 set findpattern $findstring
4479 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4481 set findpattern "*$e*"
4485 proc makepatterns {l} {
4488 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4489 if {[string index $ee end] eq "/"} {
4499 proc do_file_hl {serial} {
4500 global highlight_files filehighlight highlight_paths gdttype fhl_list
4502 if {$gdttype eq [mc "touching paths:"]} {
4503 if {[catch {set paths [shellsplit $highlight_files]}]} return
4504 set highlight_paths [makepatterns $paths]
4506 set gdtargs [concat -- $paths]
4507 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4508 set gdtargs [list "-S$highlight_files"]
4510 # must be "containing:", i.e. we're searching commit info
4513 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4514 set filehighlight [open $cmd r+]
4515 fconfigure $filehighlight -blocking 0
4516 filerun $filehighlight readfhighlight
4522 proc flushhighlights {} {
4523 global filehighlight fhl_list
4525 if {[info exists filehighlight]} {
4527 puts $filehighlight ""
4528 flush $filehighlight
4532 proc askfilehighlight {row id} {
4533 global filehighlight fhighlights fhl_list
4535 lappend fhl_list $id
4536 set fhighlights($id) -1
4537 puts $filehighlight $id
4540 proc readfhighlight {} {
4541 global filehighlight fhighlights curview iddrawn
4542 global fhl_list find_dirn
4544 if {![info exists filehighlight]} {
4548 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4549 set line [string trim $line]
4550 set i [lsearch -exact $fhl_list $line]
4551 if {$i < 0} continue
4552 for {set j 0} {$j < $i} {incr j} {
4553 set id [lindex $fhl_list $j]
4554 set fhighlights($id) 0
4556 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4557 if {$line eq {}} continue
4558 if {![commitinview $line $curview]} continue
4559 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4560 bolden $line mainfontbold
4562 set fhighlights($line) 1
4564 if {[eof $filehighlight]} {
4566 puts "oops, git diff-tree died"
4567 catch {close $filehighlight}
4571 if {[info exists find_dirn]} {
4577 proc doesmatch {f} {
4578 global findtype findpattern
4580 if {$findtype eq [mc "Regexp"]} {
4581 return [regexp $findpattern $f]
4582 } elseif {$findtype eq [mc "IgnCase"]} {
4583 return [string match -nocase $findpattern $f]
4585 return [string match $findpattern $f]
4589 proc askfindhighlight {row id} {
4590 global nhighlights commitinfo iddrawn
4592 global markingmatches
4594 if {![info exists commitinfo($id)]} {
4597 set info $commitinfo($id)
4599 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4600 foreach f $info ty $fldtypes {
4601 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4603 if {$ty eq [mc "Author"]} {
4610 if {$isbold && [info exists iddrawn($id)]} {
4611 if {![ishighlighted $id]} {
4612 bolden $id mainfontbold
4614 bolden_name $id mainfontbold
4617 if {$markingmatches} {
4618 markrowmatches $row $id
4621 set nhighlights($id) $isbold
4624 proc markrowmatches {row id} {
4625 global canv canv2 linehtag linentag commitinfo findloc
4627 set headline [lindex $commitinfo($id) 0]
4628 set author [lindex $commitinfo($id) 1]
4629 $canv delete match$row
4630 $canv2 delete match$row
4631 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4632 set m [findmatches $headline]
4634 markmatches $canv $row $headline $linehtag($id) $m \
4635 [$canv itemcget $linehtag($id) -font] $row
4638 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4639 set m [findmatches $author]
4641 markmatches $canv2 $row $author $linentag($id) $m \
4642 [$canv2 itemcget $linentag($id) -font] $row
4647 proc vrel_change {name ix op} {
4648 global highlight_related
4651 if {$highlight_related ne [mc "None"]} {
4656 # prepare for testing whether commits are descendents or ancestors of a
4657 proc rhighlight_sel {a} {
4658 global descendent desc_todo ancestor anc_todo
4659 global highlight_related
4661 catch {unset descendent}
4662 set desc_todo [list $a]
4663 catch {unset ancestor}
4664 set anc_todo [list $a]
4665 if {$highlight_related ne [mc "None"]} {
4671 proc rhighlight_none {} {
4674 catch {unset rhighlights}
4678 proc is_descendent {a} {
4679 global curview children descendent desc_todo
4682 set la [rowofcommit $a]
4686 for {set i 0} {$i < [llength $todo]} {incr i} {
4687 set do [lindex $todo $i]
4688 if {[rowofcommit $do] < $la} {
4689 lappend leftover $do
4692 foreach nk $children($v,$do) {
4693 if {![info exists descendent($nk)]} {
4694 set descendent($nk) 1
4702 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4706 set descendent($a) 0
4707 set desc_todo $leftover
4710 proc is_ancestor {a} {
4711 global curview parents ancestor anc_todo
4714 set la [rowofcommit $a]
4718 for {set i 0} {$i < [llength $todo]} {incr i} {
4719 set do [lindex $todo $i]
4720 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4721 lappend leftover $do
4724 foreach np $parents($v,$do) {
4725 if {![info exists ancestor($np)]} {
4734 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4739 set anc_todo $leftover
4742 proc askrelhighlight {row id} {
4743 global descendent highlight_related iddrawn rhighlights
4744 global selectedline ancestor
4746 if {$selectedline eq {}} return
4748 if {$highlight_related eq [mc "Descendant"] ||
4749 $highlight_related eq [mc "Not descendant"]} {
4750 if {![info exists descendent($id)]} {
4753 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4756 } elseif {$highlight_related eq [mc "Ancestor"] ||
4757 $highlight_related eq [mc "Not ancestor"]} {
4758 if {![info exists ancestor($id)]} {
4761 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4765 if {[info exists iddrawn($id)]} {
4766 if {$isbold && ![ishighlighted $id]} {
4767 bolden $id mainfontbold
4770 set rhighlights($id) $isbold
4773 # Graph layout functions
4775 proc shortids {ids} {
4778 if {[llength $id] > 1} {
4779 lappend res [shortids $id]
4780 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4781 lappend res [string range $id 0 7]
4792 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4793 if {($n & $mask) != 0} {
4794 set ret [concat $ret $o]
4796 set o [concat $o $o]
4801 proc ordertoken {id} {
4802 global ordertok curview varcid varcstart varctok curview parents children
4803 global nullid nullid2
4805 if {[info exists ordertok($id)]} {
4806 return $ordertok($id)
4811 if {[info exists varcid($curview,$id)]} {
4812 set a $varcid($curview,$id)
4813 set p [lindex $varcstart($curview) $a]
4815 set p [lindex $children($curview,$id) 0]
4817 if {[info exists ordertok($p)]} {
4818 set tok $ordertok($p)
4821 set id [first_real_child $curview,$p]
4824 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4827 if {[llength $parents($curview,$id)] == 1} {
4828 lappend todo [list $p {}]
4830 set j [lsearch -exact $parents($curview,$id) $p]
4832 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4834 lappend todo [list $p [strrep $j]]
4837 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4838 set p [lindex $todo $i 0]
4839 append tok [lindex $todo $i 1]
4840 set ordertok($p) $tok
4842 set ordertok($origid) $tok
4846 # Work out where id should go in idlist so that order-token
4847 # values increase from left to right
4848 proc idcol {idlist id {i 0}} {
4849 set t [ordertoken $id]
4853 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4854 if {$i > [llength $idlist]} {
4855 set i [llength $idlist]
4857 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4860 if {$t > [ordertoken [lindex $idlist $i]]} {
4861 while {[incr i] < [llength $idlist] &&
4862 $t >= [ordertoken [lindex $idlist $i]]} {}
4868 proc initlayout {} {
4869 global rowidlist rowisopt rowfinal displayorder parentlist
4870 global numcommits canvxmax canv
4872 global colormap rowtextx
4881 set canvxmax [$canv cget -width]
4882 catch {unset colormap}
4883 catch {unset rowtextx}
4887 proc setcanvscroll {} {
4888 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4889 global lastscrollset lastscrollrows
4891 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4892 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4893 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4894 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4895 set lastscrollset [clock clicks -milliseconds]
4896 set lastscrollrows $numcommits
4899 proc visiblerows {} {
4900 global canv numcommits linespc
4902 set ymax [lindex [$canv cget -scrollregion] 3]
4903 if {$ymax eq {} || $ymax == 0} return
4905 set y0 [expr {int([lindex $f 0] * $ymax)}]
4906 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4910 set y1 [expr {int([lindex $f 1] * $ymax)}]
4911 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4912 if {$r1 >= $numcommits} {
4913 set r1 [expr {$numcommits - 1}]
4915 return [list $r0 $r1]
4918 proc layoutmore {} {
4919 global commitidx viewcomplete curview
4920 global numcommits pending_select curview
4921 global lastscrollset lastscrollrows
4923 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4924 [clock clicks -milliseconds] - $lastscrollset > 500} {
4927 if {[info exists pending_select] &&
4928 [commitinview $pending_select $curview]} {
4930 selectline [rowofcommit $pending_select] 1
4935 # With path limiting, we mightn't get the actual HEAD commit,
4936 # so ask git rev-list what is the first ancestor of HEAD that
4937 # touches a file in the path limit.
4938 proc get_viewmainhead {view} {
4939 global viewmainheadid vfilelimit viewinstances mainheadid
4942 set rfd [open [concat | git rev-list -1 $mainheadid \
4943 -- $vfilelimit($view)] r]
4944 set j [reg_instance $rfd]
4945 lappend viewinstances($view) $j
4946 fconfigure $rfd -blocking 0
4947 filerun $rfd [list getviewhead $rfd $j $view]
4948 set viewmainheadid($curview) {}
4952 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4953 proc getviewhead {fd inst view} {
4954 global viewmainheadid commfd curview viewinstances showlocalchanges
4957 if {[gets $fd line] < 0} {
4961 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4964 set viewmainheadid($view) $id
4967 set i [lsearch -exact $viewinstances($view) $inst]
4969 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4971 if {$showlocalchanges && $id ne {} && $view == $curview} {
4977 proc doshowlocalchanges {} {
4978 global curview viewmainheadid
4980 if {$viewmainheadid($curview) eq {}} return
4981 if {[commitinview $viewmainheadid($curview) $curview]} {
4984 interestedin $viewmainheadid($curview) dodiffindex
4988 proc dohidelocalchanges {} {
4989 global nullid nullid2 lserial curview
4991 if {[commitinview $nullid $curview]} {
4992 removefakerow $nullid
4994 if {[commitinview $nullid2 $curview]} {
4995 removefakerow $nullid2
5000 # spawn off a process to do git diff-index --cached HEAD
5001 proc dodiffindex {} {
5002 global lserial showlocalchanges vfilelimit curview
5005 if {!$showlocalchanges || !$isworktree} return
5007 set cmd "|git diff-index --cached HEAD"
5008 if {$vfilelimit($curview) ne {}} {
5009 set cmd [concat $cmd -- $vfilelimit($curview)]
5011 set fd [open $cmd r]
5012 fconfigure $fd -blocking 0
5013 set i [reg_instance $fd]
5014 filerun $fd [list readdiffindex $fd $lserial $i]
5017 proc readdiffindex {fd serial inst} {
5018 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5022 if {[gets $fd line] < 0} {
5028 # we only need to see one line and we don't really care what it says...
5031 if {$serial != $lserial} {
5035 # now see if there are any local changes not checked in to the index
5036 set cmd "|git diff-files"
5037 if {$vfilelimit($curview) ne {}} {
5038 set cmd [concat $cmd -- $vfilelimit($curview)]
5040 set fd [open $cmd r]
5041 fconfigure $fd -blocking 0
5042 set i [reg_instance $fd]
5043 filerun $fd [list readdifffiles $fd $serial $i]
5045 if {$isdiff && ![commitinview $nullid2 $curview]} {
5046 # add the line for the changes in the index to the graph
5047 set hl [mc "Local changes checked in to index but not committed"]
5048 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5049 set commitdata($nullid2) "\n $hl\n"
5050 if {[commitinview $nullid $curview]} {
5051 removefakerow $nullid
5053 insertfakerow $nullid2 $viewmainheadid($curview)
5054 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5055 if {[commitinview $nullid $curview]} {
5056 removefakerow $nullid
5058 removefakerow $nullid2
5063 proc readdifffiles {fd serial inst} {
5064 global viewmainheadid nullid nullid2 curview
5065 global commitinfo commitdata lserial
5068 if {[gets $fd line] < 0} {
5074 # we only need to see one line and we don't really care what it says...
5077 if {$serial != $lserial} {
5081 if {$isdiff && ![commitinview $nullid $curview]} {
5082 # add the line for the local diff to the graph
5083 set hl [mc "Local uncommitted changes, not checked in to index"]
5084 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5085 set commitdata($nullid) "\n $hl\n"
5086 if {[commitinview $nullid2 $curview]} {
5089 set p $viewmainheadid($curview)
5091 insertfakerow $nullid $p
5092 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5093 removefakerow $nullid
5098 proc nextuse {id row} {
5099 global curview children
5101 if {[info exists children($curview,$id)]} {
5102 foreach kid $children($curview,$id) {
5103 if {![commitinview $kid $curview]} {
5106 if {[rowofcommit $kid] > $row} {
5107 return [rowofcommit $kid]
5111 if {[commitinview $id $curview]} {
5112 return [rowofcommit $id]
5117 proc prevuse {id row} {
5118 global curview children
5121 if {[info exists children($curview,$id)]} {
5122 foreach kid $children($curview,$id) {
5123 if {![commitinview $kid $curview]} break
5124 if {[rowofcommit $kid] < $row} {
5125 set ret [rowofcommit $kid]
5132 proc make_idlist {row} {
5133 global displayorder parentlist uparrowlen downarrowlen mingaplen
5134 global commitidx curview children
5136 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5140 set ra [expr {$row - $downarrowlen}]
5144 set rb [expr {$row + $uparrowlen}]
5145 if {$rb > $commitidx($curview)} {
5146 set rb $commitidx($curview)
5148 make_disporder $r [expr {$rb + 1}]
5150 for {} {$r < $ra} {incr r} {
5151 set nextid [lindex $displayorder [expr {$r + 1}]]
5152 foreach p [lindex $parentlist $r] {
5153 if {$p eq $nextid} continue
5154 set rn [nextuse $p $r]
5156 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5157 lappend ids [list [ordertoken $p] $p]
5161 for {} {$r < $row} {incr r} {
5162 set nextid [lindex $displayorder [expr {$r + 1}]]
5163 foreach p [lindex $parentlist $r] {
5164 if {$p eq $nextid} continue
5165 set rn [nextuse $p $r]
5166 if {$rn < 0 || $rn >= $row} {
5167 lappend ids [list [ordertoken $p] $p]
5171 set id [lindex $displayorder $row]
5172 lappend ids [list [ordertoken $id] $id]
5174 foreach p [lindex $parentlist $r] {
5175 set firstkid [lindex $children($curview,$p) 0]
5176 if {[rowofcommit $firstkid] < $row} {
5177 lappend ids [list [ordertoken $p] $p]
5181 set id [lindex $displayorder $r]
5183 set firstkid [lindex $children($curview,$id) 0]
5184 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5185 lappend ids [list [ordertoken $id] $id]
5190 foreach idx [lsort -unique $ids] {
5191 lappend idlist [lindex $idx 1]
5196 proc rowsequal {a b} {
5197 while {[set i [lsearch -exact $a {}]] >= 0} {
5198 set a [lreplace $a $i $i]
5200 while {[set i [lsearch -exact $b {}]] >= 0} {
5201 set b [lreplace $b $i $i]
5203 return [expr {$a eq $b}]
5206 proc makeupline {id row rend col} {
5207 global rowidlist uparrowlen downarrowlen mingaplen
5209 for {set r $rend} {1} {set r $rstart} {
5210 set rstart [prevuse $id $r]
5211 if {$rstart < 0} return
5212 if {$rstart < $row} break
5214 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5215 set rstart [expr {$rend - $uparrowlen - 1}]
5217 for {set r $rstart} {[incr r] <= $row} {} {
5218 set idlist [lindex $rowidlist $r]
5219 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5220 set col [idcol $idlist $id $col]
5221 lset rowidlist $r [linsert $idlist $col $id]
5227 proc layoutrows {row endrow} {
5228 global rowidlist rowisopt rowfinal displayorder
5229 global uparrowlen downarrowlen maxwidth mingaplen
5230 global children parentlist
5231 global commitidx viewcomplete curview
5233 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5236 set rm1 [expr {$row - 1}]
5237 foreach id [lindex $rowidlist $rm1] {
5242 set final [lindex $rowfinal $rm1]
5244 for {} {$row < $endrow} {incr row} {
5245 set rm1 [expr {$row - 1}]
5246 if {$rm1 < 0 || $idlist eq {}} {
5247 set idlist [make_idlist $row]
5250 set id [lindex $displayorder $rm1]
5251 set col [lsearch -exact $idlist $id]
5252 set idlist [lreplace $idlist $col $col]
5253 foreach p [lindex $parentlist $rm1] {
5254 if {[lsearch -exact $idlist $p] < 0} {
5255 set col [idcol $idlist $p $col]
5256 set idlist [linsert $idlist $col $p]
5257 # if not the first child, we have to insert a line going up
5258 if {$id ne [lindex $children($curview,$p) 0]} {
5259 makeupline $p $rm1 $row $col
5263 set id [lindex $displayorder $row]
5264 if {$row > $downarrowlen} {
5265 set termrow [expr {$row - $downarrowlen - 1}]
5266 foreach p [lindex $parentlist $termrow] {
5267 set i [lsearch -exact $idlist $p]
5268 if {$i < 0} continue
5269 set nr [nextuse $p $termrow]
5270 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5271 set idlist [lreplace $idlist $i $i]
5275 set col [lsearch -exact $idlist $id]
5277 set col [idcol $idlist $id]
5278 set idlist [linsert $idlist $col $id]
5279 if {$children($curview,$id) ne {}} {
5280 makeupline $id $rm1 $row $col
5283 set r [expr {$row + $uparrowlen - 1}]
5284 if {$r < $commitidx($curview)} {
5286 foreach p [lindex $parentlist $r] {
5287 if {[lsearch -exact $idlist $p] >= 0} continue
5288 set fk [lindex $children($curview,$p) 0]
5289 if {[rowofcommit $fk] < $row} {
5290 set x [idcol $idlist $p $x]
5291 set idlist [linsert $idlist $x $p]
5294 if {[incr r] < $commitidx($curview)} {
5295 set p [lindex $displayorder $r]
5296 if {[lsearch -exact $idlist $p] < 0} {
5297 set fk [lindex $children($curview,$p) 0]
5298 if {$fk ne {} && [rowofcommit $fk] < $row} {
5299 set x [idcol $idlist $p $x]
5300 set idlist [linsert $idlist $x $p]
5306 if {$final && !$viewcomplete($curview) &&
5307 $row + $uparrowlen + $mingaplen + $downarrowlen
5308 >= $commitidx($curview)} {
5311 set l [llength $rowidlist]
5313 lappend rowidlist $idlist
5315 lappend rowfinal $final
5316 } elseif {$row < $l} {
5317 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5318 lset rowidlist $row $idlist
5321 lset rowfinal $row $final
5323 set pad [ntimes [expr {$row - $l}] {}]
5324 set rowidlist [concat $rowidlist $pad]
5325 lappend rowidlist $idlist
5326 set rowfinal [concat $rowfinal $pad]
5327 lappend rowfinal $final
5328 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5334 proc changedrow {row} {
5335 global displayorder iddrawn rowisopt need_redisplay
5337 set l [llength $rowisopt]
5339 lset rowisopt $row 0
5340 if {$row + 1 < $l} {
5341 lset rowisopt [expr {$row + 1}] 0
5342 if {$row + 2 < $l} {
5343 lset rowisopt [expr {$row + 2}] 0
5347 set id [lindex $displayorder $row]
5348 if {[info exists iddrawn($id)]} {
5349 set need_redisplay 1
5353 proc insert_pad {row col npad} {
5356 set pad [ntimes $npad {}]
5357 set idlist [lindex $rowidlist $row]
5358 set bef [lrange $idlist 0 [expr {$col - 1}]]
5359 set aft [lrange $idlist $col end]
5360 set i [lsearch -exact $aft {}]
5362 set aft [lreplace $aft $i $i]
5364 lset rowidlist $row [concat $bef $pad $aft]
5368 proc optimize_rows {row col endrow} {
5369 global rowidlist rowisopt displayorder curview children
5374 for {} {$row < $endrow} {incr row; set col 0} {
5375 if {[lindex $rowisopt $row]} continue
5377 set y0 [expr {$row - 1}]
5378 set ym [expr {$row - 2}]
5379 set idlist [lindex $rowidlist $row]
5380 set previdlist [lindex $rowidlist $y0]
5381 if {$idlist eq {} || $previdlist eq {}} continue
5383 set pprevidlist [lindex $rowidlist $ym]
5384 if {$pprevidlist eq {}} continue
5390 for {} {$col < [llength $idlist]} {incr col} {
5391 set id [lindex $idlist $col]
5392 if {[lindex $previdlist $col] eq $id} continue
5397 set x0 [lsearch -exact $previdlist $id]
5398 if {$x0 < 0} continue
5399 set z [expr {$x0 - $col}]
5403 set xm [lsearch -exact $pprevidlist $id]
5405 set z0 [expr {$xm - $x0}]
5409 # if row y0 is the first child of $id then it's not an arrow
5410 if {[lindex $children($curview,$id) 0] ne
5411 [lindex $displayorder $y0]} {
5415 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5416 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5419 # Looking at lines from this row to the previous row,
5420 # make them go straight up if they end in an arrow on
5421 # the previous row; otherwise make them go straight up
5423 if {$z < -1 || ($z < 0 && $isarrow)} {
5424 # Line currently goes left too much;
5425 # insert pads in the previous row, then optimize it
5426 set npad [expr {-1 - $z + $isarrow}]
5427 insert_pad $y0 $x0 $npad
5429 optimize_rows $y0 $x0 $row
5431 set previdlist [lindex $rowidlist $y0]
5432 set x0 [lsearch -exact $previdlist $id]
5433 set z [expr {$x0 - $col}]
5435 set pprevidlist [lindex $rowidlist $ym]
5436 set xm [lsearch -exact $pprevidlist $id]
5437 set z0 [expr {$xm - $x0}]
5439 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5440 # Line currently goes right too much;
5441 # insert pads in this line
5442 set npad [expr {$z - 1 + $isarrow}]
5443 insert_pad $row $col $npad
5444 set idlist [lindex $rowidlist $row]
5446 set z [expr {$x0 - $col}]
5449 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5450 # this line links to its first child on row $row-2
5451 set id [lindex $displayorder $ym]
5452 set xc [lsearch -exact $pprevidlist $id]
5454 set z0 [expr {$xc - $x0}]
5457 # avoid lines jigging left then immediately right
5458 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5459 insert_pad $y0 $x0 1
5461 optimize_rows $y0 $x0 $row
5462 set previdlist [lindex $rowidlist $y0]
5466 # Find the first column that doesn't have a line going right
5467 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5468 set id [lindex $idlist $col]
5469 if {$id eq {}} break
5470 set x0 [lsearch -exact $previdlist $id]
5472 # check if this is the link to the first child
5473 set kid [lindex $displayorder $y0]
5474 if {[lindex $children($curview,$id) 0] eq $kid} {
5475 # it is, work out offset to child
5476 set x0 [lsearch -exact $previdlist $kid]
5479 if {$x0 <= $col} break
5481 # Insert a pad at that column as long as it has a line and
5482 # isn't the last column
5483 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5484 set idlist [linsert $idlist $col {}]
5485 lset rowidlist $row $idlist
5493 global canvx0 linespc
5494 return [expr {$canvx0 + $col * $linespc}]
5498 global canvy0 linespc
5499 return [expr {$canvy0 + $row * $linespc}]
5502 proc linewidth {id} {
5503 global thickerline lthickness
5506 if {[info exists thickerline] && $id eq $thickerline} {
5507 set wid [expr {2 * $lthickness}]
5512 proc rowranges {id} {
5513 global curview children uparrowlen downarrowlen
5516 set kids $children($curview,$id)
5522 foreach child $kids {
5523 if {![commitinview $child $curview]} break
5524 set row [rowofcommit $child]
5525 if {![info exists prev]} {
5526 lappend ret [expr {$row + 1}]
5528 if {$row <= $prevrow} {
5529 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5531 # see if the line extends the whole way from prevrow to row
5532 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5533 [lsearch -exact [lindex $rowidlist \
5534 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5535 # it doesn't, see where it ends
5536 set r [expr {$prevrow + $downarrowlen}]
5537 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5538 while {[incr r -1] > $prevrow &&
5539 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5541 while {[incr r] <= $row &&
5542 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5546 # see where it starts up again
5547 set r [expr {$row - $uparrowlen}]
5548 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5549 while {[incr r] < $row &&
5550 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5552 while {[incr r -1] >= $prevrow &&
5553 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5559 if {$child eq $id} {
5568 proc drawlineseg {id row endrow arrowlow} {
5569 global rowidlist displayorder iddrawn linesegs
5570 global canv colormap linespc curview maxlinelen parentlist
5572 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5573 set le [expr {$row + 1}]
5576 set c [lsearch -exact [lindex $rowidlist $le] $id]
5582 set x [lindex $displayorder $le]
5587 if {[info exists iddrawn($x)] || $le == $endrow} {
5588 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5604 if {[info exists linesegs($id)]} {
5605 set lines $linesegs($id)
5607 set r0 [lindex $li 0]
5609 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5619 set li [lindex $lines [expr {$i-1}]]
5620 set r1 [lindex $li 1]
5621 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5626 set x [lindex $cols [expr {$le - $row}]]
5627 set xp [lindex $cols [expr {$le - 1 - $row}]]
5628 set dir [expr {$xp - $x}]
5630 set ith [lindex $lines $i 2]
5631 set coords [$canv coords $ith]
5632 set ah [$canv itemcget $ith -arrow]
5633 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5634 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5635 if {$x2 ne {} && $x - $x2 == $dir} {
5636 set coords [lrange $coords 0 end-2]
5639 set coords [list [xc $le $x] [yc $le]]
5642 set itl [lindex $lines [expr {$i-1}] 2]
5643 set al [$canv itemcget $itl -arrow]
5644 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5645 } elseif {$arrowlow} {
5646 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5647 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5651 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5652 for {set y $le} {[incr y -1] > $row} {} {
5654 set xp [lindex $cols [expr {$y - 1 - $row}]]
5655 set ndir [expr {$xp - $x}]
5656 if {$dir != $ndir || $xp < 0} {
5657 lappend coords [xc $y $x] [yc $y]
5663 # join parent line to first child
5664 set ch [lindex $displayorder $row]
5665 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5667 puts "oops: drawlineseg: child $ch not on row $row"
5668 } elseif {$xc != $x} {
5669 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5670 set d [expr {int(0.5 * $linespc)}]
5673 set x2 [expr {$x1 - $d}]
5675 set x2 [expr {$x1 + $d}]
5678 set y1 [expr {$y2 + $d}]
5679 lappend coords $x1 $y1 $x2 $y2
5680 } elseif {$xc < $x - 1} {
5681 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5682 } elseif {$xc > $x + 1} {
5683 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5687 lappend coords [xc $row $x] [yc $row]
5689 set xn [xc $row $xp]
5691 lappend coords $xn $yn
5695 set t [$canv create line $coords -width [linewidth $id] \
5696 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5699 set lines [linsert $lines $i [list $row $le $t]]
5701 $canv coords $ith $coords
5702 if {$arrow ne $ah} {
5703 $canv itemconf $ith -arrow $arrow
5705 lset lines $i 0 $row
5708 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5709 set ndir [expr {$xo - $xp}]
5710 set clow [$canv coords $itl]
5711 if {$dir == $ndir} {
5712 set clow [lrange $clow 2 end]
5714 set coords [concat $coords $clow]
5716 lset lines [expr {$i-1}] 1 $le
5718 # coalesce two pieces
5720 set b [lindex $lines [expr {$i-1}] 0]
5721 set e [lindex $lines $i 1]
5722 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5724 $canv coords $itl $coords
5725 if {$arrow ne $al} {
5726 $canv itemconf $itl -arrow $arrow
5730 set linesegs($id) $lines
5734 proc drawparentlinks {id row} {
5735 global rowidlist canv colormap curview parentlist
5736 global idpos linespc
5738 set rowids [lindex $rowidlist $row]
5739 set col [lsearch -exact $rowids $id]
5740 if {$col < 0} return
5741 set olds [lindex $parentlist $row]
5742 set row2 [expr {$row + 1}]
5743 set x [xc $row $col]
5746 set d [expr {int(0.5 * $linespc)}]
5747 set ymid [expr {$y + $d}]
5748 set ids [lindex $rowidlist $row2]
5749 # rmx = right-most X coord used
5752 set i [lsearch -exact $ids $p]
5754 puts "oops, parent $p of $id not in list"
5757 set x2 [xc $row2 $i]
5761 set j [lsearch -exact $rowids $p]
5763 # drawlineseg will do this one for us
5767 # should handle duplicated parents here...
5768 set coords [list $x $y]
5770 # if attaching to a vertical segment, draw a smaller
5771 # slant for visual distinctness
5774 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5776 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5778 } elseif {$i < $col && $i < $j} {
5779 # segment slants towards us already
5780 lappend coords [xc $row $j] $y
5782 if {$i < $col - 1} {
5783 lappend coords [expr {$x2 + $linespc}] $y
5784 } elseif {$i > $col + 1} {
5785 lappend coords [expr {$x2 - $linespc}] $y
5787 lappend coords $x2 $y2
5790 lappend coords $x2 $y2
5792 set t [$canv create line $coords -width [linewidth $p] \
5793 -fill $colormap($p) -tags lines.$p]
5797 if {$rmx > [lindex $idpos($id) 1]} {
5798 lset idpos($id) 1 $rmx
5803 proc drawlines {id} {
5806 $canv itemconf lines.$id -width [linewidth $id]
5809 proc drawcmittext {id row col} {
5810 global linespc canv canv2 canv3 fgcolor curview
5811 global cmitlisted commitinfo rowidlist parentlist
5812 global rowtextx idpos idtags idheads idotherrefs
5813 global linehtag linentag linedtag selectedline
5814 global canvxmax boldids boldnameids fgcolor markedid
5815 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5817 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5818 set listed $cmitlisted($curview,$id)
5819 if {$id eq $nullid} {
5821 } elseif {$id eq $nullid2} {
5823 } elseif {$id eq $mainheadid} {
5826 set ofill [lindex $circlecolors $listed]
5828 set x [xc $row $col]
5830 set orad [expr {$linespc / 3}]
5832 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5833 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5834 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5835 } elseif {$listed == 3} {
5836 # triangle pointing left for left-side commits
5837 set t [$canv create polygon \
5838 [expr {$x - $orad}] $y \
5839 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5840 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5841 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5843 # triangle pointing right for right-side commits
5844 set t [$canv create polygon \
5845 [expr {$x + $orad - 1}] $y \
5846 [expr {$x - $orad}] [expr {$y - $orad}] \
5847 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5848 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5850 set circleitem($row) $t
5852 $canv bind $t <1> {selcanvline {} %x %y}
5853 set rmx [llength [lindex $rowidlist $row]]
5854 set olds [lindex $parentlist $row]
5856 set nextids [lindex $rowidlist [expr {$row + 1}]]
5858 set i [lsearch -exact $nextids $p]
5864 set xt [xc $row $rmx]
5865 set rowtextx($row) $xt
5866 set idpos($id) [list $x $xt $y]
5867 if {[info exists idtags($id)] || [info exists idheads($id)]
5868 || [info exists idotherrefs($id)]} {
5869 set xt [drawtags $id $x $xt $y]
5871 set headline [lindex $commitinfo($id) 0]
5872 set name [lindex $commitinfo($id) 1]
5873 set date [lindex $commitinfo($id) 2]
5874 set date [formatdate $date]
5877 set isbold [ishighlighted $id]
5880 set font mainfontbold
5882 lappend boldnameids $id
5883 set nfont mainfontbold
5886 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5887 -text $headline -font $font -tags text]
5888 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5889 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5890 -text $name -font $nfont -tags text]
5891 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5892 -text $date -font mainfont -tags text]
5893 if {$selectedline == $row} {
5896 if {[info exists markedid] && $markedid eq $id} {
5899 set xr [expr {$xt + [font measure $font $headline]}]
5900 if {$xr > $canvxmax} {
5906 proc drawcmitrow {row} {
5907 global displayorder rowidlist nrows_drawn
5908 global iddrawn markingmatches
5909 global commitinfo numcommits
5910 global filehighlight fhighlights findpattern nhighlights
5911 global hlview vhighlights
5912 global highlight_related rhighlights
5914 if {$row >= $numcommits} return
5916 set id [lindex $displayorder $row]
5917 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5918 askvhighlight $row $id
5920 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5921 askfilehighlight $row $id
5923 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5924 askfindhighlight $row $id
5926 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5927 askrelhighlight $row $id
5929 if {![info exists iddrawn($id)]} {
5930 set col [lsearch -exact [lindex $rowidlist $row] $id]
5932 puts "oops, row $row id $id not in list"
5935 if {![info exists commitinfo($id)]} {
5939 drawcmittext $id $row $col
5943 if {$markingmatches} {
5944 markrowmatches $row $id
5948 proc drawcommits {row {endrow {}}} {
5949 global numcommits iddrawn displayorder curview need_redisplay
5950 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5955 if {$endrow eq {}} {
5958 if {$endrow >= $numcommits} {
5959 set endrow [expr {$numcommits - 1}]
5962 set rl1 [expr {$row - $downarrowlen - 3}]
5966 set ro1 [expr {$row - 3}]
5970 set r2 [expr {$endrow + $uparrowlen + 3}]
5971 if {$r2 > $numcommits} {
5974 for {set r $rl1} {$r < $r2} {incr r} {
5975 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5979 set rl1 [expr {$r + 1}]
5985 optimize_rows $ro1 0 $r2
5986 if {$need_redisplay || $nrows_drawn > 2000} {
5990 # make the lines join to already-drawn rows either side
5991 set r [expr {$row - 1}]
5992 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5995 set er [expr {$endrow + 1}]
5996 if {$er >= $numcommits ||
5997 ![info exists iddrawn([lindex $displayorder $er])]} {
6000 for {} {$r <= $er} {incr r} {
6001 set id [lindex $displayorder $r]
6002 set wasdrawn [info exists iddrawn($id)]
6004 if {$r == $er} break
6005 set nextid [lindex $displayorder [expr {$r + 1}]]
6006 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6007 drawparentlinks $id $r
6009 set rowids [lindex $rowidlist $r]
6010 foreach lid $rowids {
6011 if {$lid eq {}} continue
6012 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6014 # see if this is the first child of any of its parents
6015 foreach p [lindex $parentlist $r] {
6016 if {[lsearch -exact $rowids $p] < 0} {
6017 # make this line extend up to the child
6018 set lineend($p) [drawlineseg $p $r $er 0]
6022 set lineend($lid) [drawlineseg $lid $r $er 1]
6028 proc undolayout {row} {
6029 global uparrowlen mingaplen downarrowlen
6030 global rowidlist rowisopt rowfinal need_redisplay
6032 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6036 if {[llength $rowidlist] > $r} {
6038 set rowidlist [lrange $rowidlist 0 $r]
6039 set rowfinal [lrange $rowfinal 0 $r]
6040 set rowisopt [lrange $rowisopt 0 $r]
6041 set need_redisplay 1
6046 proc drawvisible {} {
6047 global canv linespc curview vrowmod selectedline targetrow targetid
6048 global need_redisplay cscroll numcommits
6050 set fs [$canv yview]
6051 set ymax [lindex [$canv cget -scrollregion] 3]
6052 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6053 set f0 [lindex $fs 0]
6054 set f1 [lindex $fs 1]
6055 set y0 [expr {int($f0 * $ymax)}]
6056 set y1 [expr {int($f1 * $ymax)}]
6058 if {[info exists targetid]} {
6059 if {[commitinview $targetid $curview]} {
6060 set r [rowofcommit $targetid]
6061 if {$r != $targetrow} {
6062 # Fix up the scrollregion and change the scrolling position
6063 # now that our target row has moved.
6064 set diff [expr {($r - $targetrow) * $linespc}]
6067 set ymax [lindex [$canv cget -scrollregion] 3]
6070 set f0 [expr {$y0 / $ymax}]
6071 set f1 [expr {$y1 / $ymax}]
6072 allcanvs yview moveto $f0
6073 $cscroll set $f0 $f1
6074 set need_redisplay 1
6081 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6082 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6083 if {$endrow >= $vrowmod($curview)} {
6084 update_arcrows $curview
6086 if {$selectedline ne {} &&
6087 $row <= $selectedline && $selectedline <= $endrow} {
6088 set targetrow $selectedline
6089 } elseif {[info exists targetid]} {
6090 set targetrow [expr {int(($row + $endrow) / 2)}]
6092 if {[info exists targetrow]} {
6093 if {$targetrow >= $numcommits} {
6094 set targetrow [expr {$numcommits - 1}]
6096 set targetid [commitonrow $targetrow]
6098 drawcommits $row $endrow
6101 proc clear_display {} {
6102 global iddrawn linesegs need_redisplay nrows_drawn
6103 global vhighlights fhighlights nhighlights rhighlights
6104 global linehtag linentag linedtag boldids boldnameids
6107 catch {unset iddrawn}
6108 catch {unset linesegs}
6109 catch {unset linehtag}
6110 catch {unset linentag}
6111 catch {unset linedtag}
6114 catch {unset vhighlights}
6115 catch {unset fhighlights}
6116 catch {unset nhighlights}
6117 catch {unset rhighlights}
6118 set need_redisplay 0
6122 proc findcrossings {id} {
6123 global rowidlist parentlist numcommits displayorder
6127 foreach {s e} [rowranges $id] {
6128 if {$e >= $numcommits} {
6129 set e [expr {$numcommits - 1}]
6131 if {$e <= $s} continue
6132 for {set row $e} {[incr row -1] >= $s} {} {
6133 set x [lsearch -exact [lindex $rowidlist $row] $id]
6135 set olds [lindex $parentlist $row]
6136 set kid [lindex $displayorder $row]
6137 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6138 if {$kidx < 0} continue
6139 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6141 set px [lsearch -exact $nextrow $p]
6142 if {$px < 0} continue
6143 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6144 if {[lsearch -exact $ccross $p] >= 0} continue
6145 if {$x == $px + ($kidx < $px? -1: 1)} {
6147 } elseif {[lsearch -exact $cross $p] < 0} {
6154 return [concat $ccross {{}} $cross]
6157 proc assigncolor {id} {
6158 global colormap colors nextcolor
6159 global parents children children curview
6161 if {[info exists colormap($id)]} return
6162 set ncolors [llength $colors]
6163 if {[info exists children($curview,$id)]} {
6164 set kids $children($curview,$id)
6168 if {[llength $kids] == 1} {
6169 set child [lindex $kids 0]
6170 if {[info exists colormap($child)]
6171 && [llength $parents($curview,$child)] == 1} {
6172 set colormap($id) $colormap($child)
6178 foreach x [findcrossings $id] {
6180 # delimiter between corner crossings and other crossings
6181 if {[llength $badcolors] >= $ncolors - 1} break
6182 set origbad $badcolors
6184 if {[info exists colormap($x)]
6185 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6186 lappend badcolors $colormap($x)
6189 if {[llength $badcolors] >= $ncolors} {
6190 set badcolors $origbad
6192 set origbad $badcolors
6193 if {[llength $badcolors] < $ncolors - 1} {
6194 foreach child $kids {
6195 if {[info exists colormap($child)]
6196 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6197 lappend badcolors $colormap($child)
6199 foreach p $parents($curview,$child) {
6200 if {[info exists colormap($p)]
6201 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6202 lappend badcolors $colormap($p)
6206 if {[llength $badcolors] >= $ncolors} {
6207 set badcolors $origbad
6210 for {set i 0} {$i <= $ncolors} {incr i} {
6211 set c [lindex $colors $nextcolor]
6212 if {[incr nextcolor] >= $ncolors} {
6215 if {[lsearch -exact $badcolors $c]} break
6217 set colormap($id) $c
6220 proc bindline {t id} {
6223 $canv bind $t <Enter> "lineenter %x %y $id"
6224 $canv bind $t <Motion> "linemotion %x %y $id"
6225 $canv bind $t <Leave> "lineleave $id"
6226 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6229 proc drawtags {id x xt y1} {
6230 global idtags idheads idotherrefs mainhead
6231 global linespc lthickness
6232 global canv rowtextx curview fgcolor bgcolor ctxbut
6237 if {[info exists idtags($id)]} {
6238 set marks $idtags($id)
6239 set ntags [llength $marks]
6241 if {[info exists idheads($id)]} {
6242 set marks [concat $marks $idheads($id)]
6243 set nheads [llength $idheads($id)]
6245 if {[info exists idotherrefs($id)]} {
6246 set marks [concat $marks $idotherrefs($id)]
6252 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6253 set yt [expr {$y1 - 0.5 * $linespc}]
6254 set yb [expr {$yt + $linespc - 1}]
6258 foreach tag $marks {
6260 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6261 set wid [font measure mainfontbold $tag]
6263 set wid [font measure mainfont $tag]
6267 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6269 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6270 -width $lthickness -fill black -tags tag.$id]
6272 foreach tag $marks x $xvals wid $wvals {
6273 set xl [expr {$x + $delta}]
6274 set xr [expr {$x + $delta + $wid + $lthickness}]
6276 if {[incr ntags -1] >= 0} {
6278 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6279 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6280 -width 1 -outline black -fill yellow -tags tag.$id]
6281 $canv bind $t <1> [list showtag $tag 1]
6282 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6284 # draw a head or other ref
6285 if {[incr nheads -1] >= 0} {
6287 if {$tag eq $mainhead} {
6288 set font mainfontbold
6293 set xl [expr {$xl - $delta/2}]
6294 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6295 -width 1 -outline black -fill $col -tags tag.$id
6296 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6297 set rwid [font measure mainfont $remoteprefix]
6298 set xi [expr {$x + 1}]
6299 set yti [expr {$yt + 1}]
6300 set xri [expr {$x + $rwid}]
6301 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6302 -width 0 -fill "#ffddaa" -tags tag.$id
6305 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6306 -font $font -tags [list tag.$id text]]
6308 $canv bind $t <1> [list showtag $tag 1]
6309 } elseif {$nheads >= 0} {
6310 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6316 proc xcoord {i level ln} {
6317 global canvx0 xspc1 xspc2
6319 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6320 if {$i > 0 && $i == $level} {
6321 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6322 } elseif {$i > $level} {
6323 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6328 proc show_status {msg} {
6332 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6333 -tags text -fill $fgcolor
6336 # Don't change the text pane cursor if it is currently the hand cursor,
6337 # showing that we are over a sha1 ID link.
6338 proc settextcursor {c} {
6339 global ctext curtextcursor
6341 if {[$ctext cget -cursor] == $curtextcursor} {
6342 $ctext config -cursor $c
6344 set curtextcursor $c
6347 proc nowbusy {what {name {}}} {
6348 global isbusy busyname statusw
6350 if {[array names isbusy] eq {}} {
6351 . config -cursor watch
6355 set busyname($what) $name
6357 $statusw conf -text $name
6361 proc notbusy {what} {
6362 global isbusy maincursor textcursor busyname statusw
6366 if {$busyname($what) ne {} &&
6367 [$statusw cget -text] eq $busyname($what)} {
6368 $statusw conf -text {}
6371 if {[array names isbusy] eq {}} {
6372 . config -cursor $maincursor
6373 settextcursor $textcursor
6377 proc findmatches {f} {
6378 global findtype findstring
6379 if {$findtype == [mc "Regexp"]} {
6380 set matches [regexp -indices -all -inline $findstring $f]
6383 if {$findtype == [mc "IgnCase"]} {
6384 set f [string tolower $f]
6385 set fs [string tolower $fs]
6389 set l [string length $fs]
6390 while {[set j [string first $fs $f $i]] >= 0} {
6391 lappend matches [list $j [expr {$j+$l-1}]]
6392 set i [expr {$j + $l}]
6398 proc dofind {{dirn 1} {wrap 1}} {
6399 global findstring findstartline findcurline selectedline numcommits
6400 global gdttype filehighlight fh_serial find_dirn findallowwrap
6402 if {[info exists find_dirn]} {
6403 if {$find_dirn == $dirn} return
6407 if {$findstring eq {} || $numcommits == 0} return
6408 if {$selectedline eq {}} {
6409 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6411 set findstartline $selectedline
6413 set findcurline $findstartline
6414 nowbusy finding [mc "Searching"]
6415 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6416 after cancel do_file_hl $fh_serial
6417 do_file_hl $fh_serial
6420 set findallowwrap $wrap
6424 proc stopfinding {} {
6425 global find_dirn findcurline fprogcoord
6427 if {[info exists find_dirn]} {
6438 global commitdata commitinfo numcommits findpattern findloc
6439 global findstartline findcurline findallowwrap
6440 global find_dirn gdttype fhighlights fprogcoord
6441 global curview varcorder vrownum varccommits vrowmod
6443 if {![info exists find_dirn]} {
6446 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6449 if {$find_dirn > 0} {
6451 if {$l >= $numcommits} {
6454 if {$l <= $findstartline} {
6455 set lim [expr {$findstartline + 1}]
6458 set moretodo $findallowwrap
6465 if {$l >= $findstartline} {
6466 set lim [expr {$findstartline - 1}]
6469 set moretodo $findallowwrap
6472 set n [expr {($lim - $l) * $find_dirn}]
6477 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6478 update_arcrows $curview
6482 set ai [bsearch $vrownum($curview) $l]
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]}]
6487 if {$gdttype eq [mc "containing:"]} {
6488 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6489 if {$l < $arow || $l >= $arowend} {
6491 set a [lindex $varcorder($curview) $ai]
6492 set arow [lindex $vrownum($curview) $ai]
6493 set ids [lindex $varccommits($curview,$a)]
6494 set arowend [expr {$arow + [llength $ids]}]
6496 set id [lindex $ids [expr {$l - $arow}]]
6497 # shouldn't happen unless git log doesn't give all the commits...
6498 if {![info exists commitdata($id)] ||
6499 ![doesmatch $commitdata($id)]} {
6502 if {![info exists commitinfo($id)]} {
6505 set info $commitinfo($id)
6506 foreach f $info ty $fldtypes {
6507 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6516 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6517 if {$l < $arow || $l >= $arowend} {
6519 set a [lindex $varcorder($curview) $ai]
6520 set arow [lindex $vrownum($curview) $ai]
6521 set ids [lindex $varccommits($curview,$a)]
6522 set arowend [expr {$arow + [llength $ids]}]
6524 set id [lindex $ids [expr {$l - $arow}]]
6525 if {![info exists fhighlights($id)]} {
6526 # this sets fhighlights($id) to -1
6527 askfilehighlight $l $id
6529 if {$fhighlights($id) > 0} {
6533 if {$fhighlights($id) < 0} {
6536 set findcurline [expr {$l - $find_dirn}]
6541 if {$found || ($domore && !$moretodo)} {
6557 set findcurline [expr {$l - $find_dirn}]
6559 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6563 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6568 proc findselectline {l} {
6569 global findloc commentend ctext findcurline markingmatches gdttype
6571 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6574 if {$markingmatches &&
6575 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6576 # highlight the matches in the comments
6577 set f [$ctext get 1.0 $commentend]
6578 set matches [findmatches $f]
6579 foreach match $matches {
6580 set start [lindex $match 0]
6581 set end [expr {[lindex $match 1] + 1}]
6582 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6588 # mark the bits of a headline or author that match a find string
6589 proc markmatches {canv l str tag matches font row} {
6592 set bbox [$canv bbox $tag]
6593 set x0 [lindex $bbox 0]
6594 set y0 [lindex $bbox 1]
6595 set y1 [lindex $bbox 3]
6596 foreach match $matches {
6597 set start [lindex $match 0]
6598 set end [lindex $match 1]
6599 if {$start > $end} continue
6600 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6601 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6602 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6603 [expr {$x0+$xlen+2}] $y1 \
6604 -outline {} -tags [list match$l matches] -fill yellow]
6606 if {$row == $selectedline} {
6607 $canv raise $t secsel
6612 proc unmarkmatches {} {
6613 global markingmatches
6615 allcanvs delete matches
6616 set markingmatches 0
6620 proc selcanvline {w x y} {
6621 global canv canvy0 ctext linespc
6623 set ymax [lindex [$canv cget -scrollregion] 3]
6624 if {$ymax == {}} return
6625 set yfrac [lindex [$canv yview] 0]
6626 set y [expr {$y + $yfrac * $ymax}]
6627 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6632 set xmax [lindex [$canv cget -scrollregion] 2]
6633 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6634 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6640 proc commit_descriptor {p} {
6642 if {![info exists commitinfo($p)]} {
6646 if {[llength $commitinfo($p)] > 1} {
6647 set l [lindex $commitinfo($p) 0]
6652 # append some text to the ctext widget, and make any SHA1 ID
6653 # that we know about be a clickable link.
6654 proc appendwithlinks {text tags} {
6655 global ctext linknum curview
6657 set start [$ctext index "end - 1c"]
6658 $ctext insert end $text $tags
6659 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6663 set linkid [string range $text $s $e]
6665 $ctext tag delete link$linknum
6666 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6667 setlink $linkid link$linknum
6672 proc setlink {id lk} {
6673 global curview ctext pendinglinks
6676 if {[string length $id] < 40} {
6677 set matches [longid $id]
6678 if {[llength $matches] > 0} {
6679 if {[llength $matches] > 1} return
6681 set id [lindex $matches 0]
6684 set known [commitinview $id $curview]
6687 $ctext tag conf $lk -foreground blue -underline 1
6688 $ctext tag bind $lk <1> [list selbyid $id]
6689 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6690 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6692 lappend pendinglinks($id) $lk
6693 interestedin $id {makelink %P}
6697 proc appendshortlink {id {pre {}} {post {}}} {
6698 global ctext linknum
6700 $ctext insert end $pre
6701 $ctext tag delete link$linknum
6702 $ctext insert end [string range $id 0 7] link$linknum
6703 $ctext insert end $post
6704 setlink $id link$linknum
6708 proc makelink {id} {
6711 if {![info exists pendinglinks($id)]} return
6712 foreach lk $pendinglinks($id) {
6715 unset pendinglinks($id)
6718 proc linkcursor {w inc} {
6719 global linkentercount curtextcursor
6721 if {[incr linkentercount $inc] > 0} {
6722 $w configure -cursor hand2
6724 $w configure -cursor $curtextcursor
6725 if {$linkentercount < 0} {
6726 set linkentercount 0
6731 proc viewnextline {dir} {
6735 set ymax [lindex [$canv cget -scrollregion] 3]
6736 set wnow [$canv yview]
6737 set wtop [expr {[lindex $wnow 0] * $ymax}]
6738 set newtop [expr {$wtop + $dir * $linespc}]
6741 } elseif {$newtop > $ymax} {
6744 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6747 # add a list of tag or branch names at position pos
6748 # returns the number of names inserted
6749 proc appendrefs {pos ids var} {
6750 global ctext linknum curview $var maxrefs
6752 if {[catch {$ctext index $pos}]} {
6755 $ctext conf -state normal
6756 $ctext delete $pos "$pos lineend"
6759 foreach tag [set $var\($id\)] {
6760 lappend tags [list $tag $id]
6763 if {[llength $tags] > $maxrefs} {
6764 $ctext insert $pos "[mc "many"] ([llength $tags])"
6766 set tags [lsort -index 0 -decreasing $tags]
6769 set id [lindex $ti 1]
6772 $ctext tag delete $lk
6773 $ctext insert $pos $sep
6774 $ctext insert $pos [lindex $ti 0] $lk
6779 $ctext conf -state disabled
6780 return [llength $tags]
6783 # called when we have finished computing the nearby tags
6784 proc dispneartags {delay} {
6785 global selectedline currentid showneartags tagphase
6787 if {$selectedline eq {} || !$showneartags} return
6788 after cancel dispnexttag
6790 after 200 dispnexttag
6793 after idle dispnexttag
6798 proc dispnexttag {} {
6799 global selectedline currentid showneartags tagphase ctext
6801 if {$selectedline eq {} || !$showneartags} return
6802 switch -- $tagphase {
6804 set dtags [desctags $currentid]
6806 appendrefs precedes $dtags idtags
6810 set atags [anctags $currentid]
6812 appendrefs follows $atags idtags
6816 set dheads [descheads $currentid]
6817 if {$dheads ne {}} {
6818 if {[appendrefs branch $dheads idheads] > 1
6819 && [$ctext get "branch -3c"] eq "h"} {
6820 # turn "Branch" into "Branches"
6821 $ctext conf -state normal
6822 $ctext insert "branch -2c" "es"
6823 $ctext conf -state disabled
6828 if {[incr tagphase] <= 2} {
6829 after idle dispnexttag
6833 proc make_secsel {id} {
6834 global linehtag linentag linedtag canv canv2 canv3
6836 if {![info exists linehtag($id)]} return
6838 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6839 -tags secsel -fill [$canv cget -selectbackground]]
6841 $canv2 delete secsel
6842 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6843 -tags secsel -fill [$canv2 cget -selectbackground]]
6845 $canv3 delete secsel
6846 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6847 -tags secsel -fill [$canv3 cget -selectbackground]]
6851 proc make_idmark {id} {
6852 global linehtag canv fgcolor
6854 if {![info exists linehtag($id)]} return
6856 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6857 -tags markid -outline $fgcolor]
6861 proc selectline {l isnew {desired_loc {}}} {
6862 global canv ctext commitinfo selectedline
6863 global canvy0 linespc parents children curview
6864 global currentid sha1entry
6865 global commentend idtags linknum
6866 global mergemax numcommits pending_select
6867 global cmitmode showneartags allcommits
6868 global targetrow targetid lastscrollrows
6869 global autoselect jump_to_here
6871 catch {unset pending_select}
6876 if {$l < 0 || $l >= $numcommits} return
6877 set id [commitonrow $l]
6882 if {$lastscrollrows < $numcommits} {
6886 set y [expr {$canvy0 + $l * $linespc}]
6887 set ymax [lindex [$canv cget -scrollregion] 3]
6888 set ytop [expr {$y - $linespc - 1}]
6889 set ybot [expr {$y + $linespc + 1}]
6890 set wnow [$canv yview]
6891 set wtop [expr {[lindex $wnow 0] * $ymax}]
6892 set wbot [expr {[lindex $wnow 1] * $ymax}]
6893 set wh [expr {$wbot - $wtop}]
6895 if {$ytop < $wtop} {
6896 if {$ybot < $wtop} {
6897 set newtop [expr {$y - $wh / 2.0}]
6900 if {$newtop > $wtop - $linespc} {
6901 set newtop [expr {$wtop - $linespc}]
6904 } elseif {$ybot > $wbot} {
6905 if {$ytop > $wbot} {
6906 set newtop [expr {$y - $wh / 2.0}]
6908 set newtop [expr {$ybot - $wh}]
6909 if {$newtop < $wtop + $linespc} {
6910 set newtop [expr {$wtop + $linespc}]
6914 if {$newtop != $wtop} {
6918 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6925 addtohistory [list selbyid $id 0] savecmitpos
6928 $sha1entry delete 0 end
6929 $sha1entry insert 0 $id
6931 $sha1entry selection range 0 end
6935 $ctext conf -state normal
6938 if {![info exists commitinfo($id)]} {
6941 set info $commitinfo($id)
6942 set date [formatdate [lindex $info 2]]
6943 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6944 set date [formatdate [lindex $info 4]]
6945 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6946 if {[info exists idtags($id)]} {
6947 $ctext insert end [mc "Tags:"]
6948 foreach tag $idtags($id) {
6949 $ctext insert end " $tag"
6951 $ctext insert end "\n"
6955 set olds $parents($curview,$id)
6956 if {[llength $olds] > 1} {
6959 if {$np >= $mergemax} {
6964 $ctext insert end "[mc "Parent"]: " $tag
6965 appendwithlinks [commit_descriptor $p] {}
6970 append headers "[mc "Parent"]: [commit_descriptor $p]"
6974 foreach c $children($curview,$id) {
6975 append headers "[mc "Child"]: [commit_descriptor $c]"
6978 # make anything that looks like a SHA1 ID be a clickable link
6979 appendwithlinks $headers {}
6980 if {$showneartags} {
6981 if {![info exists allcommits]} {
6984 $ctext insert end "[mc "Branch"]: "
6985 $ctext mark set branch "end -1c"
6986 $ctext mark gravity branch left
6987 $ctext insert end "\n[mc "Follows"]: "
6988 $ctext mark set follows "end -1c"
6989 $ctext mark gravity follows left
6990 $ctext insert end "\n[mc "Precedes"]: "
6991 $ctext mark set precedes "end -1c"
6992 $ctext mark gravity precedes left
6993 $ctext insert end "\n"
6996 $ctext insert end "\n"
6997 set comment [lindex $info 5]
6998 if {[string first "\r" $comment] >= 0} {
6999 set comment [string map {"\r" "\n "} $comment]
7001 appendwithlinks $comment {comment}
7003 $ctext tag remove found 1.0 end
7004 $ctext conf -state disabled
7005 set commentend [$ctext index "end - 1c"]
7007 set jump_to_here $desired_loc
7008 init_flist [mc "Comments"]
7009 if {$cmitmode eq "tree"} {
7011 } elseif {[llength $olds] <= 1} {
7018 proc selfirstline {} {
7023 proc sellastline {} {
7026 set l [expr {$numcommits - 1}]
7030 proc selnextline {dir} {
7033 if {$selectedline eq {}} return
7034 set l [expr {$selectedline + $dir}]
7039 proc selnextpage {dir} {
7040 global canv linespc selectedline numcommits
7042 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7046 allcanvs yview scroll [expr {$dir * $lpp}] units
7048 if {$selectedline eq {}} return
7049 set l [expr {$selectedline + $dir * $lpp}]
7052 } elseif {$l >= $numcommits} {
7053 set l [expr $numcommits - 1]
7059 proc unselectline {} {
7060 global selectedline currentid
7063 catch {unset currentid}
7064 allcanvs delete secsel
7068 proc reselectline {} {
7071 if {$selectedline ne {}} {
7072 selectline $selectedline 0
7076 proc addtohistory {cmd {saveproc {}}} {
7077 global history historyindex curview
7081 set elt [list $curview $cmd $saveproc {}]
7082 if {$historyindex > 0
7083 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7087 if {$historyindex < [llength $history]} {
7088 set history [lreplace $history $historyindex end $elt]
7090 lappend history $elt
7093 if {$historyindex > 1} {
7094 .tf.bar.leftbut conf -state normal
7096 .tf.bar.leftbut conf -state disabled
7098 .tf.bar.rightbut conf -state disabled
7101 # save the scrolling position of the diff display pane
7102 proc save_position {} {
7103 global historyindex history
7105 if {$historyindex < 1} return
7106 set hi [expr {$historyindex - 1}]
7107 set fn [lindex $history $hi 2]
7109 lset history $hi 3 [eval $fn]
7113 proc unset_posvars {} {
7116 if {[info exists last_posvars]} {
7117 foreach {var val} $last_posvars {
7126 global curview last_posvars
7128 set view [lindex $elt 0]
7129 set cmd [lindex $elt 1]
7130 set pv [lindex $elt 3]
7131 if {$curview != $view} {
7135 foreach {var val} $pv {
7139 set last_posvars $pv
7144 global history historyindex
7147 if {$historyindex > 1} {
7149 incr historyindex -1
7150 godo [lindex $history [expr {$historyindex - 1}]]
7151 .tf.bar.rightbut conf -state normal
7153 if {$historyindex <= 1} {
7154 .tf.bar.leftbut conf -state disabled
7159 global history historyindex
7162 if {$historyindex < [llength $history]} {
7164 set cmd [lindex $history $historyindex]
7167 .tf.bar.leftbut conf -state normal
7169 if {$historyindex >= [llength $history]} {
7170 .tf.bar.rightbut conf -state disabled
7175 global treefilelist treeidlist diffids diffmergeid treepending
7176 global nullid nullid2
7179 catch {unset diffmergeid}
7180 if {![info exists treefilelist($id)]} {
7181 if {![info exists treepending]} {
7182 if {$id eq $nullid} {
7183 set cmd [list | git ls-files]
7184 } elseif {$id eq $nullid2} {
7185 set cmd [list | git ls-files --stage -t]
7187 set cmd [list | git ls-tree -r $id]
7189 if {[catch {set gtf [open $cmd r]}]} {
7193 set treefilelist($id) {}
7194 set treeidlist($id) {}
7195 fconfigure $gtf -blocking 0 -encoding binary
7196 filerun $gtf [list gettreeline $gtf $id]
7203 proc gettreeline {gtf id} {
7204 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7207 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7208 if {$diffids eq $nullid} {
7211 set i [string first "\t" $line]
7212 if {$i < 0} continue
7213 set fname [string range $line [expr {$i+1}] end]
7214 set line [string range $line 0 [expr {$i-1}]]
7215 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7216 set sha1 [lindex $line 2]
7217 lappend treeidlist($id) $sha1
7219 if {[string index $fname 0] eq "\""} {
7220 set fname [lindex $fname 0]
7222 set fname [encoding convertfrom $fname]
7223 lappend treefilelist($id) $fname
7226 return [expr {$nl >= 1000? 2: 1}]
7230 if {$cmitmode ne "tree"} {
7231 if {![info exists diffmergeid]} {
7232 gettreediffs $diffids
7234 } elseif {$id ne $diffids} {
7243 global treefilelist treeidlist diffids nullid nullid2
7244 global ctext_file_names ctext_file_lines
7245 global ctext commentend
7247 set i [lsearch -exact $treefilelist($diffids) $f]
7249 puts "oops, $f not in list for id $diffids"
7252 if {$diffids eq $nullid} {
7253 if {[catch {set bf [open $f r]} err]} {
7254 puts "oops, can't read $f: $err"
7258 set blob [lindex $treeidlist($diffids) $i]
7259 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7260 puts "oops, error reading blob $blob: $err"
7264 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7265 filerun $bf [list getblobline $bf $diffids]
7266 $ctext config -state normal
7267 clear_ctext $commentend
7268 lappend ctext_file_names $f
7269 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7270 $ctext insert end "\n"
7271 $ctext insert end "$f\n" filesep
7272 $ctext config -state disabled
7273 $ctext yview $commentend
7277 proc getblobline {bf id} {
7278 global diffids cmitmode ctext
7280 if {$id ne $diffids || $cmitmode ne "tree"} {
7284 $ctext config -state normal
7286 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7287 $ctext insert end "$line\n"
7290 global jump_to_here ctext_file_names commentend
7292 # delete last newline
7293 $ctext delete "end - 2c" "end - 1c"
7295 if {$jump_to_here ne {} &&
7296 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7297 set lnum [expr {[lindex $jump_to_here 1] +
7298 [lindex [split $commentend .] 0]}]
7299 mark_ctext_line $lnum
7303 $ctext config -state disabled
7304 return [expr {$nl >= 1000? 2: 1}]
7307 proc mark_ctext_line {lnum} {
7308 global ctext markbgcolor
7310 $ctext tag delete omark
7311 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7312 $ctext tag conf omark -background $markbgcolor
7316 proc mergediff {id} {
7318 global diffids treediffs
7319 global parents curview
7323 set treediffs($id) {}
7324 set np [llength $parents($curview,$id)]
7329 proc startdiff {ids} {
7330 global treediffs diffids treepending diffmergeid nullid nullid2
7334 catch {unset diffmergeid}
7335 if {![info exists treediffs($ids)] ||
7336 [lsearch -exact $ids $nullid] >= 0 ||
7337 [lsearch -exact $ids $nullid2] >= 0} {
7338 if {![info exists treepending]} {
7346 proc path_filter {filter name} {
7348 set l [string length $p]
7349 if {[string index $p end] eq "/"} {
7350 if {[string compare -length $l $p $name] == 0} {
7354 if {[string compare -length $l $p $name] == 0 &&
7355 ([string length $name] == $l ||
7356 [string index $name $l] eq "/")} {
7364 proc addtocflist {ids} {
7367 add_flist $treediffs($ids)
7371 proc diffcmd {ids flags} {
7372 global nullid nullid2
7374 set i [lsearch -exact $ids $nullid]
7375 set j [lsearch -exact $ids $nullid2]
7377 if {[llength $ids] > 1 && $j < 0} {
7378 # comparing working directory with some specific revision
7379 set cmd [concat | git diff-index $flags]
7381 lappend cmd -R [lindex $ids 1]
7383 lappend cmd [lindex $ids 0]
7386 # comparing working directory with index
7387 set cmd [concat | git diff-files $flags]
7392 } elseif {$j >= 0} {
7393 set cmd [concat | git diff-index --cached $flags]
7394 if {[llength $ids] > 1} {
7395 # comparing index with specific revision
7397 lappend cmd -R [lindex $ids 1]
7399 lappend cmd [lindex $ids 0]
7402 # comparing index with HEAD
7406 set cmd [concat | git diff-tree -r $flags $ids]
7411 proc gettreediffs {ids} {
7412 global treediff treepending
7414 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7416 set treepending $ids
7418 fconfigure $gdtf -blocking 0 -encoding binary
7419 filerun $gdtf [list gettreediffline $gdtf $ids]
7422 proc gettreediffline {gdtf ids} {
7423 global treediff treediffs treepending diffids diffmergeid
7424 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7429 if {$perfile_attrs} {
7430 # cache_gitattr is slow, and even slower on win32 where we
7431 # have to invoke it for only about 30 paths at a time
7433 if {[tk windowingsystem] == "win32"} {
7437 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7438 set i [string first "\t" $line]
7440 set file [string range $line [expr {$i+1}] end]
7441 if {[string index $file 0] eq "\""} {
7442 set file [lindex $file 0]
7444 set file [encoding convertfrom $file]
7445 if {$file ne [lindex $treediff end]} {
7446 lappend treediff $file
7447 lappend sublist $file
7451 if {$perfile_attrs} {
7452 cache_gitattr encoding $sublist
7455 return [expr {$nr >= $max? 2: 1}]
7458 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7460 foreach f $treediff {
7461 if {[path_filter $vfilelimit($curview) $f]} {
7465 set treediffs($ids) $flist
7467 set treediffs($ids) $treediff
7470 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7472 } elseif {$ids != $diffids} {
7473 if {![info exists diffmergeid]} {
7474 gettreediffs $diffids
7482 # empty string or positive integer
7483 proc diffcontextvalidate {v} {
7484 return [regexp {^(|[1-9][0-9]*)$} $v]
7487 proc diffcontextchange {n1 n2 op} {
7488 global diffcontextstring diffcontext
7490 if {[string is integer -strict $diffcontextstring]} {
7491 if {$diffcontextstring >= 0} {
7492 set diffcontext $diffcontextstring
7498 proc changeignorespace {} {
7502 proc getblobdiffs {ids} {
7503 global blobdifffd diffids env
7504 global diffinhdr treediffs
7507 global limitdiffs vfilelimit curview
7508 global diffencoding targetline diffnparents
7512 if {[package vcompare $git_version "1.6.1"] >= 0} {
7513 set textconv "--textconv"
7516 if {[package vcompare $git_version "1.6.6"] >= 0} {
7517 set submodule "--submodule"
7519 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
7523 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7524 set cmd [concat $cmd -- $vfilelimit($curview)]
7526 if {[catch {set bdf [open $cmd r]} err]} {
7527 error_popup [mc "Error getting diffs: %s" $err]
7533 set diffencoding [get_path_encoding {}]
7534 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7535 set blobdifffd($ids) $bdf
7536 filerun $bdf [list getblobdiffline $bdf $diffids]
7539 proc savecmitpos {} {
7540 global ctext cmitmode
7542 if {$cmitmode eq "tree"} {
7545 return [list target_scrollpos [$ctext index @0,0]]
7548 proc savectextpos {} {
7551 return [list target_scrollpos [$ctext index @0,0]]
7554 proc maybe_scroll_ctext {ateof} {
7555 global ctext target_scrollpos
7557 if {![info exists target_scrollpos]} return
7559 set nlines [expr {[winfo height $ctext]
7560 / [font metrics textfont -linespace]}]
7561 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7563 $ctext yview $target_scrollpos
7564 unset target_scrollpos
7567 proc setinlist {var i val} {
7570 while {[llength [set $var]] < $i} {
7573 if {[llength [set $var]] == $i} {
7580 proc makediffhdr {fname ids} {
7581 global ctext curdiffstart treediffs diffencoding
7582 global ctext_file_names jump_to_here targetline diffline
7584 set fname [encoding convertfrom $fname]
7585 set diffencoding [get_path_encoding $fname]
7586 set i [lsearch -exact $treediffs($ids) $fname]
7588 setinlist difffilestart $i $curdiffstart
7590 lset ctext_file_names end $fname
7591 set l [expr {(78 - [string length $fname]) / 2}]
7592 set pad [string range "----------------------------------------" 1 $l]
7593 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7595 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7596 set targetline [lindex $jump_to_here 1]
7601 proc getblobdiffline {bdf ids} {
7602 global diffids blobdifffd ctext curdiffstart
7603 global diffnexthead diffnextnote difffilestart
7604 global ctext_file_names ctext_file_lines
7605 global diffinhdr treediffs mergemax diffnparents
7606 global diffencoding jump_to_here targetline diffline
7609 $ctext conf -state normal
7610 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7611 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7615 if {![string compare -length 5 "diff " $line]} {
7616 if {![regexp {^diff (--cc|--git) } $line m type]} {
7617 set line [encoding convertfrom $line]
7618 $ctext insert end "$line\n" hunksep
7621 # start of a new file
7623 $ctext insert end "\n"
7624 set curdiffstart [$ctext index "end - 1c"]
7625 lappend ctext_file_names ""
7626 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7627 $ctext insert end "\n" filesep
7629 if {$type eq "--cc"} {
7630 # start of a new file in a merge diff
7631 set fname [string range $line 10 end]
7632 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7633 lappend treediffs($ids) $fname
7634 add_flist [list $fname]
7638 set line [string range $line 11 end]
7639 # If the name hasn't changed the length will be odd,
7640 # the middle char will be a space, and the two bits either
7641 # side will be a/name and b/name, or "a/name" and "b/name".
7642 # If the name has changed we'll get "rename from" and
7643 # "rename to" or "copy from" and "copy to" lines following
7644 # this, and we'll use them to get the filenames.
7645 # This complexity is necessary because spaces in the
7646 # filename(s) don't get escaped.
7647 set l [string length $line]
7648 set i [expr {$l / 2}]
7649 if {!(($l & 1) && [string index $line $i] eq " " &&
7650 [string range $line 2 [expr {$i - 1}]] eq \
7651 [string range $line [expr {$i + 3}] end])} {
7654 # unescape if quoted and chop off the a/ from the front
7655 if {[string index $line 0] eq "\""} {
7656 set fname [string range [lindex $line 0] 2 end]
7658 set fname [string range $line 2 [expr {$i - 1}]]
7661 makediffhdr $fname $ids
7663 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7664 set fname [encoding convertfrom [string range $line 16 end]]
7665 $ctext insert end "\n"
7666 set curdiffstart [$ctext index "end - 1c"]
7667 lappend ctext_file_names $fname
7668 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7669 $ctext insert end "$line\n" filesep
7670 set i [lsearch -exact $treediffs($ids) $fname]
7672 setinlist difffilestart $i $curdiffstart
7675 } elseif {![string compare -length 2 "@@" $line]} {
7676 regexp {^@@+} $line ats
7677 set line [encoding convertfrom $diffencoding $line]
7678 $ctext insert end "$line\n" hunksep
7679 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7682 set diffnparents [expr {[string length $ats] - 1}]
7685 } elseif {![string compare -length 10 "Submodule " $line]} {
7686 # start of a new submodule
7687 if {[string compare [$ctext get "end - 4c" end] "\n \n\n"]} {
7688 $ctext insert end "\n"; # Add newline after commit message
7690 set curdiffstart [$ctext index "end - 1c"]
7691 lappend ctext_file_names ""
7692 set fname [string range $line 10 [expr [string last " " $line] - 1]]
7693 lappend ctext_file_lines $fname
7694 makediffhdr $fname $ids
7695 $ctext insert end "\n$line\n" filesep
7696 } elseif {![string compare -length 3 " >" $line]} {
7697 set line [encoding convertfrom $diffencoding $line]
7698 $ctext insert end "$line\n" dresult
7699 } elseif {![string compare -length 3 " <" $line]} {
7700 set line [encoding convertfrom $diffencoding $line]
7701 $ctext insert end "$line\n" d0
7702 } elseif {$diffinhdr} {
7703 if {![string compare -length 12 "rename from " $line]} {
7704 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7705 if {[string index $fname 0] eq "\""} {
7706 set fname [lindex $fname 0]
7708 set fname [encoding convertfrom $fname]
7709 set i [lsearch -exact $treediffs($ids) $fname]
7711 setinlist difffilestart $i $curdiffstart
7713 } elseif {![string compare -length 10 $line "rename to "] ||
7714 ![string compare -length 8 $line "copy to "]} {
7715 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7716 if {[string index $fname 0] eq "\""} {
7717 set fname [lindex $fname 0]
7719 makediffhdr $fname $ids
7720 } elseif {[string compare -length 3 $line "---"] == 0} {
7723 } elseif {[string compare -length 3 $line "+++"] == 0} {
7727 $ctext insert end "$line\n" filesep
7730 set line [string map {\x1A ^Z} \
7731 [encoding convertfrom $diffencoding $line]]
7732 # parse the prefix - one ' ', '-' or '+' for each parent
7733 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7734 set tag [expr {$diffnparents > 1? "m": "d"}]
7735 if {[string trim $prefix " -+"] eq {}} {
7736 # prefix only has " ", "-" and "+" in it: normal diff line
7737 set num [string first "-" $prefix]
7739 # removed line, first parent with line is $num
7740 if {$num >= $mergemax} {
7743 $ctext insert end "$line\n" $tag$num
7746 if {[string first "+" $prefix] >= 0} {
7748 lappend tags ${tag}result
7749 if {$diffnparents > 1} {
7750 set num [string first " " $prefix]
7752 if {$num >= $mergemax} {
7759 if {$targetline ne {}} {
7760 if {$diffline == $targetline} {
7761 set seehere [$ctext index "end - 1 chars"]
7767 $ctext insert end "$line\n" $tags
7770 # "\ No newline at end of file",
7771 # or something else we don't recognize
7772 $ctext insert end "$line\n" hunksep
7776 if {[info exists seehere]} {
7777 mark_ctext_line [lindex [split $seehere .] 0]
7779 maybe_scroll_ctext [eof $bdf]
7780 $ctext conf -state disabled
7785 return [expr {$nr >= 1000? 2: 1}]
7788 proc changediffdisp {} {
7789 global ctext diffelide
7791 $ctext tag conf d0 -elide [lindex $diffelide 0]
7792 $ctext tag conf dresult -elide [lindex $diffelide 1]
7795 proc highlightfile {loc cline} {
7796 global ctext cflist cflist_top
7799 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7800 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7801 $cflist see $cline.0
7802 set cflist_top $cline
7806 global difffilestart ctext cmitmode
7808 if {$cmitmode eq "tree"} return
7811 set here [$ctext index @0,0]
7812 foreach loc $difffilestart {
7813 if {[$ctext compare $loc >= $here]} {
7814 highlightfile $prev $prevline
7820 highlightfile $prev $prevline
7824 global difffilestart ctext cmitmode
7826 if {$cmitmode eq "tree"} return
7827 set here [$ctext index @0,0]
7829 foreach loc $difffilestart {
7831 if {[$ctext compare $loc > $here]} {
7832 highlightfile $loc $line
7838 proc clear_ctext {{first 1.0}} {
7839 global ctext smarktop smarkbot
7840 global ctext_file_names ctext_file_lines
7843 set l [lindex [split $first .] 0]
7844 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7847 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7850 $ctext delete $first end
7851 if {$first eq "1.0"} {
7852 catch {unset pendinglinks}
7854 set ctext_file_names {}
7855 set ctext_file_lines {}
7858 proc settabs {{firstab {}}} {
7859 global firsttabstop tabstop ctext have_tk85
7861 if {$firstab ne {} && $have_tk85} {
7862 set firsttabstop $firstab
7864 set w [font measure textfont "0"]
7865 if {$firsttabstop != 0} {
7866 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7867 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7868 } elseif {$have_tk85 || $tabstop != 8} {
7869 $ctext conf -tabs [expr {$tabstop * $w}]
7871 $ctext conf -tabs {}
7875 proc incrsearch {name ix op} {
7876 global ctext searchstring searchdirn
7878 $ctext tag remove found 1.0 end
7879 if {[catch {$ctext index anchor}]} {
7880 # no anchor set, use start of selection, or of visible area
7881 set sel [$ctext tag ranges sel]
7883 $ctext mark set anchor [lindex $sel 0]
7884 } elseif {$searchdirn eq "-forwards"} {
7885 $ctext mark set anchor @0,0
7887 $ctext mark set anchor @0,[winfo height $ctext]
7890 if {$searchstring ne {}} {
7891 set here [$ctext search $searchdirn -- $searchstring anchor]
7900 global sstring ctext searchstring searchdirn
7903 $sstring icursor end
7904 set searchdirn -forwards
7905 if {$searchstring ne {}} {
7906 set sel [$ctext tag ranges sel]
7908 set start "[lindex $sel 0] + 1c"
7909 } elseif {[catch {set start [$ctext index anchor]}]} {
7912 set match [$ctext search -count mlen -- $searchstring $start]
7913 $ctext tag remove sel 1.0 end
7919 set mend "$match + $mlen c"
7920 $ctext tag add sel $match $mend
7921 $ctext mark unset anchor
7925 proc dosearchback {} {
7926 global sstring ctext searchstring searchdirn
7929 $sstring icursor end
7930 set searchdirn -backwards
7931 if {$searchstring ne {}} {
7932 set sel [$ctext tag ranges sel]
7934 set start [lindex $sel 0]
7935 } elseif {[catch {set start [$ctext index anchor]}]} {
7936 set start @0,[winfo height $ctext]
7938 set match [$ctext search -backwards -count ml -- $searchstring $start]
7939 $ctext tag remove sel 1.0 end
7945 set mend "$match + $ml c"
7946 $ctext tag add sel $match $mend
7947 $ctext mark unset anchor
7951 proc searchmark {first last} {
7952 global ctext searchstring
7956 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7957 if {$match eq {}} break
7958 set mend "$match + $mlen c"
7959 $ctext tag add found $match $mend
7963 proc searchmarkvisible {doall} {
7964 global ctext smarktop smarkbot
7966 set topline [lindex [split [$ctext index @0,0] .] 0]
7967 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7968 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7969 # no overlap with previous
7970 searchmark $topline $botline
7971 set smarktop $topline
7972 set smarkbot $botline
7974 if {$topline < $smarktop} {
7975 searchmark $topline [expr {$smarktop-1}]
7976 set smarktop $topline
7978 if {$botline > $smarkbot} {
7979 searchmark [expr {$smarkbot+1}] $botline
7980 set smarkbot $botline
7985 proc scrolltext {f0 f1} {
7988 .bleft.bottom.sb set $f0 $f1
7989 if {$searchstring ne {}} {
7995 global linespc charspc canvx0 canvy0
7996 global xspc1 xspc2 lthickness
7998 set linespc [font metrics mainfont -linespace]
7999 set charspc [font measure mainfont "m"]
8000 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8001 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8002 set lthickness [expr {int($linespc / 9) + 1}]
8003 set xspc1(0) $linespc
8011 set ymax [lindex [$canv cget -scrollregion] 3]
8012 if {$ymax eq {} || $ymax == 0} return
8013 set span [$canv yview]
8016 allcanvs yview moveto [lindex $span 0]
8018 if {$selectedline ne {}} {
8019 selectline $selectedline 0
8020 allcanvs yview moveto [lindex $span 0]
8024 proc parsefont {f n} {
8027 set fontattr($f,family) [lindex $n 0]
8029 if {$s eq {} || $s == 0} {
8032 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8034 set fontattr($f,size) $s
8035 set fontattr($f,weight) normal
8036 set fontattr($f,slant) roman
8037 foreach style [lrange $n 2 end] {
8040 "bold" {set fontattr($f,weight) $style}
8042 "italic" {set fontattr($f,slant) $style}
8047 proc fontflags {f {isbold 0}} {
8050 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8051 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8052 -slant $fontattr($f,slant)]
8058 set n [list $fontattr($f,family) $fontattr($f,size)]
8059 if {$fontattr($f,weight) eq "bold"} {
8062 if {$fontattr($f,slant) eq "italic"} {
8068 proc incrfont {inc} {
8069 global mainfont textfont ctext canv cflist showrefstop
8070 global stopped entries fontattr
8073 set s $fontattr(mainfont,size)
8078 set fontattr(mainfont,size) $s
8079 font config mainfont -size $s
8080 font config mainfontbold -size $s
8081 set mainfont [fontname mainfont]
8082 set s $fontattr(textfont,size)
8087 set fontattr(textfont,size) $s
8088 font config textfont -size $s
8089 font config textfontbold -size $s
8090 set textfont [fontname textfont]
8097 global sha1entry sha1string
8098 if {[string length $sha1string] == 40} {
8099 $sha1entry delete 0 end
8103 proc sha1change {n1 n2 op} {
8104 global sha1string currentid sha1but
8105 if {$sha1string == {}
8106 || ([info exists currentid] && $sha1string == $currentid)} {
8111 if {[$sha1but cget -state] == $state} return
8112 if {$state == "normal"} {
8113 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8115 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8119 proc gotocommit {} {
8120 global sha1string tagids headids curview varcid
8122 if {$sha1string == {}
8123 || ([info exists currentid] && $sha1string == $currentid)} return
8124 if {[info exists tagids($sha1string)]} {
8125 set id $tagids($sha1string)
8126 } elseif {[info exists headids($sha1string)]} {
8127 set id $headids($sha1string)
8129 set id [string tolower $sha1string]
8130 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8131 set matches [longid $id]
8132 if {$matches ne {}} {
8133 if {[llength $matches] > 1} {
8134 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8137 set id [lindex $matches 0]
8140 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8141 error_popup [mc "Revision %s is not known" $sha1string]
8146 if {[commitinview $id $curview]} {
8147 selectline [rowofcommit $id] 1
8150 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8151 set msg [mc "SHA1 id %s is not known" $sha1string]
8153 set msg [mc "Revision %s is not in the current view" $sha1string]
8158 proc lineenter {x y id} {
8159 global hoverx hovery hoverid hovertimer
8160 global commitinfo canv
8162 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8166 if {[info exists hovertimer]} {
8167 after cancel $hovertimer
8169 set hovertimer [after 500 linehover]
8173 proc linemotion {x y id} {
8174 global hoverx hovery hoverid hovertimer
8176 if {[info exists hoverid] && $id == $hoverid} {
8179 if {[info exists hovertimer]} {
8180 after cancel $hovertimer
8182 set hovertimer [after 500 linehover]
8186 proc lineleave {id} {
8187 global hoverid hovertimer canv
8189 if {[info exists hoverid] && $id == $hoverid} {
8191 if {[info exists hovertimer]} {
8192 after cancel $hovertimer
8200 global hoverx hovery hoverid hovertimer
8201 global canv linespc lthickness
8204 set text [lindex $commitinfo($hoverid) 0]
8205 set ymax [lindex [$canv cget -scrollregion] 3]
8206 if {$ymax == {}} return
8207 set yfrac [lindex [$canv yview] 0]
8208 set x [expr {$hoverx + 2 * $linespc}]
8209 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8210 set x0 [expr {$x - 2 * $lthickness}]
8211 set y0 [expr {$y - 2 * $lthickness}]
8212 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8213 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8214 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8215 -fill \#ffff80 -outline black -width 1 -tags hover]
8217 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8222 proc clickisonarrow {id y} {
8225 set ranges [rowranges $id]
8226 set thresh [expr {2 * $lthickness + 6}]
8227 set n [expr {[llength $ranges] - 1}]
8228 for {set i 1} {$i < $n} {incr i} {
8229 set row [lindex $ranges $i]
8230 if {abs([yc $row] - $y) < $thresh} {
8237 proc arrowjump {id n y} {
8240 # 1 <-> 2, 3 <-> 4, etc...
8241 set n [expr {(($n - 1) ^ 1) + 1}]
8242 set row [lindex [rowranges $id] $n]
8244 set ymax [lindex [$canv cget -scrollregion] 3]
8245 if {$ymax eq {} || $ymax <= 0} return
8246 set view [$canv yview]
8247 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8248 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8252 allcanvs yview moveto $yfrac
8255 proc lineclick {x y id isnew} {
8256 global ctext commitinfo children canv thickerline curview
8258 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8263 # draw this line thicker than normal
8267 set ymax [lindex [$canv cget -scrollregion] 3]
8268 if {$ymax eq {}} return
8269 set yfrac [lindex [$canv yview] 0]
8270 set y [expr {$y + $yfrac * $ymax}]
8272 set dirn [clickisonarrow $id $y]
8274 arrowjump $id $dirn $y
8279 addtohistory [list lineclick $x $y $id 0] savectextpos
8281 # fill the details pane with info about this line
8282 $ctext conf -state normal
8285 $ctext insert end "[mc "Parent"]:\t"
8286 $ctext insert end $id link0
8288 set info $commitinfo($id)
8289 $ctext insert end "\n\t[lindex $info 0]\n"
8290 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8291 set date [formatdate [lindex $info 2]]
8292 $ctext insert end "\t[mc "Date"]:\t$date\n"
8293 set kids $children($curview,$id)
8295 $ctext insert end "\n[mc "Children"]:"
8297 foreach child $kids {
8299 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8300 set info $commitinfo($child)
8301 $ctext insert end "\n\t"
8302 $ctext insert end $child link$i
8303 setlink $child link$i
8304 $ctext insert end "\n\t[lindex $info 0]"
8305 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8306 set date [formatdate [lindex $info 2]]
8307 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8310 maybe_scroll_ctext 1
8311 $ctext conf -state disabled
8315 proc normalline {} {
8317 if {[info exists thickerline]} {
8324 proc selbyid {id {isnew 1}} {
8326 if {[commitinview $id $curview]} {
8327 selectline [rowofcommit $id] $isnew
8333 if {![info exists startmstime]} {
8334 set startmstime [clock clicks -milliseconds]
8336 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8339 proc rowmenu {x y id} {
8340 global rowctxmenu selectedline rowmenuid curview
8341 global nullid nullid2 fakerowmenu mainhead markedid
8345 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8350 if {$id ne $nullid && $id ne $nullid2} {
8351 set menu $rowctxmenu
8352 if {$mainhead ne {}} {
8353 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8355 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8357 if {[info exists markedid] && $markedid ne $id} {
8358 $menu entryconfigure 9 -state normal
8359 $menu entryconfigure 10 -state normal
8360 $menu entryconfigure 11 -state normal
8362 $menu entryconfigure 9 -state disabled
8363 $menu entryconfigure 10 -state disabled
8364 $menu entryconfigure 11 -state disabled
8367 set menu $fakerowmenu
8369 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8370 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8371 $menu entryconfigure [mca "Make patch"] -state $state
8372 tk_popup $menu $x $y
8376 global rowmenuid markedid canv
8378 set markedid $rowmenuid
8379 make_idmark $markedid
8385 if {[info exists markedid]} {
8390 proc replace_by_kids {l r} {
8391 global curview children
8393 set id [commitonrow $r]
8394 set l [lreplace $l 0 0]
8395 foreach kid $children($curview,$id) {
8396 lappend l [rowofcommit $kid]
8398 return [lsort -integer -decreasing -unique $l]
8401 proc find_common_desc {} {
8402 global markedid rowmenuid curview children
8404 if {![info exists markedid]} return
8405 if {![commitinview $markedid $curview] ||
8406 ![commitinview $rowmenuid $curview]} return
8407 #set t1 [clock clicks -milliseconds]
8408 set l1 [list [rowofcommit $markedid]]
8409 set l2 [list [rowofcommit $rowmenuid]]
8411 set r1 [lindex $l1 0]
8412 set r2 [lindex $l2 0]
8413 if {$r1 eq {} || $r2 eq {}} break
8419 set l1 [replace_by_kids $l1 $r1]
8421 set l2 [replace_by_kids $l2 $r2]
8424 #set t2 [clock clicks -milliseconds]
8425 #puts "took [expr {$t2-$t1}]ms"
8428 proc compare_commits {} {
8429 global markedid rowmenuid curview children
8431 if {![info exists markedid]} return
8432 if {![commitinview $markedid $curview]} return
8433 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8434 do_cmp_commits $markedid $rowmenuid
8437 proc getpatchid {id} {
8440 if {![info exists patchids($id)]} {
8441 set cmd [diffcmd [list $id] {-p --root}]
8442 # trim off the initial "|"
8443 set cmd [lrange $cmd 1 end]
8445 set x [eval exec $cmd | git patch-id]
8446 set patchids($id) [lindex $x 0]
8448 set patchids($id) "error"
8451 return $patchids($id)
8454 proc do_cmp_commits {a b} {
8455 global ctext curview parents children patchids commitinfo
8457 $ctext conf -state normal
8460 for {set i 0} {$i < 100} {incr i} {
8463 if {[llength $parents($curview,$a)] > 1} {
8464 appendshortlink $a [mc "Skipping merge commit "] "\n"
8467 set patcha [getpatchid $a]
8469 if {[llength $parents($curview,$b)] > 1} {
8470 appendshortlink $b [mc "Skipping merge commit "] "\n"
8473 set patchb [getpatchid $b]
8475 if {!$skipa && !$skipb} {
8476 set heada [lindex $commitinfo($a) 0]
8477 set headb [lindex $commitinfo($b) 0]
8478 if {$patcha eq "error"} {
8479 appendshortlink $a [mc "Error getting patch ID for "] \
8480 [mc " - stopping\n"]
8483 if {$patchb eq "error"} {
8484 appendshortlink $b [mc "Error getting patch ID for "] \
8485 [mc " - stopping\n"]
8488 if {$patcha eq $patchb} {
8489 if {$heada eq $headb} {
8490 appendshortlink $a [mc "Commit "]
8491 appendshortlink $b " == " " $heada\n"
8493 appendshortlink $a [mc "Commit "] " $heada\n"
8494 appendshortlink $b [mc " is the same patch as\n "] \
8500 $ctext insert end "\n"
8501 appendshortlink $a [mc "Commit "] " $heada\n"
8502 appendshortlink $b [mc " differs from\n "] \
8504 $ctext insert end [mc "Diff of commits:\n\n"]
8505 $ctext conf -state disabled
8512 set kids [real_children $curview,$a]
8513 if {[llength $kids] != 1} {
8514 $ctext insert end "\n"
8515 appendshortlink $a [mc "Commit "] \
8516 [mc " has %s children - stopping\n" [llength $kids]]
8519 set a [lindex $kids 0]
8522 set kids [real_children $curview,$b]
8523 if {[llength $kids] != 1} {
8524 appendshortlink $b [mc "Commit "] \
8525 [mc " has %s children - stopping\n" [llength $kids]]
8528 set b [lindex $kids 0]
8531 $ctext conf -state disabled
8534 proc diffcommits {a b} {
8535 global diffcontext diffids blobdifffd diffinhdr
8537 set tmpdir [gitknewtmpdir]
8538 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8539 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8541 exec git diff-tree -p --pretty $a >$fna
8542 exec git diff-tree -p --pretty $b >$fnb
8544 error_popup [mc "Error writing commit to file: %s" $err]
8548 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8550 error_popup [mc "Error diffing commits: %s" $err]
8553 set diffids [list commits $a $b]
8554 set blobdifffd($diffids) $fd
8556 filerun $fd [list getblobdiffline $fd $diffids]
8559 proc diffvssel {dirn} {
8560 global rowmenuid selectedline
8562 if {$selectedline eq {}} return
8564 set oldid [commitonrow $selectedline]
8565 set newid $rowmenuid
8567 set oldid $rowmenuid
8568 set newid [commitonrow $selectedline]
8570 addtohistory [list doseldiff $oldid $newid] savectextpos
8571 doseldiff $oldid $newid
8574 proc doseldiff {oldid newid} {
8578 $ctext conf -state normal
8580 init_flist [mc "Top"]
8581 $ctext insert end "[mc "From"] "
8582 $ctext insert end $oldid link0
8583 setlink $oldid link0
8584 $ctext insert end "\n "
8585 $ctext insert end [lindex $commitinfo($oldid) 0]
8586 $ctext insert end "\n\n[mc "To"] "
8587 $ctext insert end $newid link1
8588 setlink $newid link1
8589 $ctext insert end "\n "
8590 $ctext insert end [lindex $commitinfo($newid) 0]
8591 $ctext insert end "\n"
8592 $ctext conf -state disabled
8593 $ctext tag remove found 1.0 end
8594 startdiff [list $oldid $newid]
8598 global rowmenuid currentid commitinfo patchtop patchnum NS
8600 if {![info exists currentid]} return
8601 set oldid $currentid
8602 set oldhead [lindex $commitinfo($oldid) 0]
8603 set newid $rowmenuid
8604 set newhead [lindex $commitinfo($newid) 0]
8607 catch {destroy $top}
8609 make_transient $top .
8610 ${NS}::label $top.title -text [mc "Generate patch"]
8611 grid $top.title - -pady 10
8612 ${NS}::label $top.from -text [mc "From:"]
8613 ${NS}::entry $top.fromsha1 -width 40
8614 $top.fromsha1 insert 0 $oldid
8615 $top.fromsha1 conf -state readonly
8616 grid $top.from $top.fromsha1 -sticky w
8617 ${NS}::entry $top.fromhead -width 60
8618 $top.fromhead insert 0 $oldhead
8619 $top.fromhead conf -state readonly
8620 grid x $top.fromhead -sticky w
8621 ${NS}::label $top.to -text [mc "To:"]
8622 ${NS}::entry $top.tosha1 -width 40
8623 $top.tosha1 insert 0 $newid
8624 $top.tosha1 conf -state readonly
8625 grid $top.to $top.tosha1 -sticky w
8626 ${NS}::entry $top.tohead -width 60
8627 $top.tohead insert 0 $newhead
8628 $top.tohead conf -state readonly
8629 grid x $top.tohead -sticky w
8630 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8631 grid $top.rev x -pady 10 -padx 5
8632 ${NS}::label $top.flab -text [mc "Output file:"]
8633 ${NS}::entry $top.fname -width 60
8634 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8636 grid $top.flab $top.fname -sticky w
8637 ${NS}::frame $top.buts
8638 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8639 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8640 bind $top <Key-Return> mkpatchgo
8641 bind $top <Key-Escape> mkpatchcan
8642 grid $top.buts.gen $top.buts.can
8643 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8644 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8645 grid $top.buts - -pady 10 -sticky ew
8649 proc mkpatchrev {} {
8652 set oldid [$patchtop.fromsha1 get]
8653 set oldhead [$patchtop.fromhead get]
8654 set newid [$patchtop.tosha1 get]
8655 set newhead [$patchtop.tohead get]
8656 foreach e [list fromsha1 fromhead tosha1 tohead] \
8657 v [list $newid $newhead $oldid $oldhead] {
8658 $patchtop.$e conf -state normal
8659 $patchtop.$e delete 0 end
8660 $patchtop.$e insert 0 $v
8661 $patchtop.$e conf -state readonly
8666 global patchtop nullid nullid2
8668 set oldid [$patchtop.fromsha1 get]
8669 set newid [$patchtop.tosha1 get]
8670 set fname [$patchtop.fname get]
8671 set cmd [diffcmd [list $oldid $newid] -p]
8672 # trim off the initial "|"
8673 set cmd [lrange $cmd 1 end]
8674 lappend cmd >$fname &
8675 if {[catch {eval exec $cmd} err]} {
8676 error_popup "[mc "Error creating patch:"] $err" $patchtop
8678 catch {destroy $patchtop}
8682 proc mkpatchcan {} {
8685 catch {destroy $patchtop}
8690 global rowmenuid mktagtop commitinfo NS
8694 catch {destroy $top}
8696 make_transient $top .
8697 ${NS}::label $top.title -text [mc "Create tag"]
8698 grid $top.title - -pady 10
8699 ${NS}::label $top.id -text [mc "ID:"]
8700 ${NS}::entry $top.sha1 -width 40
8701 $top.sha1 insert 0 $rowmenuid
8702 $top.sha1 conf -state readonly
8703 grid $top.id $top.sha1 -sticky w
8704 ${NS}::entry $top.head -width 60
8705 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8706 $top.head conf -state readonly
8707 grid x $top.head -sticky w
8708 ${NS}::label $top.tlab -text [mc "Tag name:"]
8709 ${NS}::entry $top.tag -width 60
8710 grid $top.tlab $top.tag -sticky w
8711 ${NS}::label $top.op -text [mc "Tag message is optional"]
8712 grid $top.op -columnspan 2 -sticky we
8713 ${NS}::label $top.mlab -text [mc "Tag message:"]
8714 ${NS}::entry $top.msg -width 60
8715 grid $top.mlab $top.msg -sticky w
8716 ${NS}::frame $top.buts
8717 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8718 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8719 bind $top <Key-Return> mktaggo
8720 bind $top <Key-Escape> mktagcan
8721 grid $top.buts.gen $top.buts.can
8722 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8723 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8724 grid $top.buts - -pady 10 -sticky ew
8729 global mktagtop env tagids idtags
8731 set id [$mktagtop.sha1 get]
8732 set tag [$mktagtop.tag get]
8733 set msg [$mktagtop.msg get]
8735 error_popup [mc "No tag name specified"] $mktagtop
8738 if {[info exists tagids($tag)]} {
8739 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8744 exec git tag -a -m $msg $tag $id
8746 exec git tag $tag $id
8749 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8753 set tagids($tag) $id
8754 lappend idtags($id) $tag
8762 proc redrawtags {id} {
8763 global canv linehtag idpos currentid curview cmitlisted markedid
8764 global canvxmax iddrawn circleitem mainheadid circlecolors
8766 if {![commitinview $id $curview]} return
8767 if {![info exists iddrawn($id)]} return
8768 set row [rowofcommit $id]
8769 if {$id eq $mainheadid} {
8772 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8774 $canv itemconf $circleitem($row) -fill $ofill
8775 $canv delete tag.$id
8776 set xt [eval drawtags $id $idpos($id)]
8777 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8778 set text [$canv itemcget $linehtag($id) -text]
8779 set font [$canv itemcget $linehtag($id) -font]
8780 set xr [expr {$xt + [font measure $font $text]}]
8781 if {$xr > $canvxmax} {
8785 if {[info exists currentid] && $currentid == $id} {
8788 if {[info exists markedid] && $markedid eq $id} {
8796 catch {destroy $mktagtop}
8801 if {![domktag]} return
8805 proc writecommit {} {
8806 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8808 set top .writecommit
8810 catch {destroy $top}
8812 make_transient $top .
8813 ${NS}::label $top.title -text [mc "Write commit to file"]
8814 grid $top.title - -pady 10
8815 ${NS}::label $top.id -text [mc "ID:"]
8816 ${NS}::entry $top.sha1 -width 40
8817 $top.sha1 insert 0 $rowmenuid
8818 $top.sha1 conf -state readonly
8819 grid $top.id $top.sha1 -sticky w
8820 ${NS}::entry $top.head -width 60
8821 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8822 $top.head conf -state readonly
8823 grid x $top.head -sticky w
8824 ${NS}::label $top.clab -text [mc "Command:"]
8825 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8826 grid $top.clab $top.cmd -sticky w -pady 10
8827 ${NS}::label $top.flab -text [mc "Output file:"]
8828 ${NS}::entry $top.fname -width 60
8829 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8830 grid $top.flab $top.fname -sticky w
8831 ${NS}::frame $top.buts
8832 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8833 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8834 bind $top <Key-Return> wrcomgo
8835 bind $top <Key-Escape> wrcomcan
8836 grid $top.buts.gen $top.buts.can
8837 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8838 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8839 grid $top.buts - -pady 10 -sticky ew
8846 set id [$wrcomtop.sha1 get]
8847 set cmd "echo $id | [$wrcomtop.cmd get]"
8848 set fname [$wrcomtop.fname get]
8849 if {[catch {exec sh -c $cmd >$fname &} err]} {
8850 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8852 catch {destroy $wrcomtop}
8859 catch {destroy $wrcomtop}
8864 global rowmenuid mkbrtop NS
8867 catch {destroy $top}
8869 make_transient $top .
8870 ${NS}::label $top.title -text [mc "Create new branch"]
8871 grid $top.title - -pady 10
8872 ${NS}::label $top.id -text [mc "ID:"]
8873 ${NS}::entry $top.sha1 -width 40
8874 $top.sha1 insert 0 $rowmenuid
8875 $top.sha1 conf -state readonly
8876 grid $top.id $top.sha1 -sticky w
8877 ${NS}::label $top.nlab -text [mc "Name:"]
8878 ${NS}::entry $top.name -width 40
8879 grid $top.nlab $top.name -sticky w
8880 ${NS}::frame $top.buts
8881 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8882 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8883 bind $top <Key-Return> [list mkbrgo $top]
8884 bind $top <Key-Escape> "catch {destroy $top}"
8885 grid $top.buts.go $top.buts.can
8886 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8887 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8888 grid $top.buts - -pady 10 -sticky ew
8893 global headids idheads
8895 set name [$top.name get]
8896 set id [$top.sha1 get]
8900 error_popup [mc "Please specify a name for the new branch"] $top
8903 if {[info exists headids($name)]} {
8904 if {![confirm_popup [mc \
8905 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8908 set old_id $headids($name)
8911 catch {destroy $top}
8912 lappend cmdargs $name $id
8916 eval exec git branch $cmdargs
8922 if {$old_id ne {}} {
8928 set headids($name) $id
8929 lappend idheads($id) $name
8938 proc exec_citool {tool_args {baseid {}}} {
8939 global commitinfo env
8941 set save_env [array get env GIT_AUTHOR_*]
8943 if {$baseid ne {}} {
8944 if {![info exists commitinfo($baseid)]} {
8947 set author [lindex $commitinfo($baseid) 1]
8948 set date [lindex $commitinfo($baseid) 2]
8949 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8950 $author author name email]
8952 set env(GIT_AUTHOR_NAME) $name
8953 set env(GIT_AUTHOR_EMAIL) $email
8954 set env(GIT_AUTHOR_DATE) $date
8958 eval exec git citool $tool_args &
8960 array unset env GIT_AUTHOR_*
8961 array set env $save_env
8964 proc cherrypick {} {
8965 global rowmenuid curview
8966 global mainhead mainheadid
8968 set oldhead [exec git rev-parse HEAD]
8969 set dheads [descheads $rowmenuid]
8970 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8971 set ok [confirm_popup [mc "Commit %s is already\
8972 included in branch %s -- really re-apply it?" \
8973 [string range $rowmenuid 0 7] $mainhead]]
8976 nowbusy cherrypick [mc "Cherry-picking"]
8978 # Unfortunately git-cherry-pick writes stuff to stderr even when
8979 # no error occurs, and exec takes that as an indication of error...
8980 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8983 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8985 error_popup [mc "Cherry-pick failed because of local changes\
8986 to file '%s'.\nPlease commit, reset or stash\
8987 your changes and try again." $fname]
8988 } elseif {[regexp -line \
8989 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8991 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8992 conflict.\nDo you wish to run git citool to\
8994 # Force citool to read MERGE_MSG
8995 file delete [file join [gitdir] "GITGUI_MSG"]
8996 exec_citool {} $rowmenuid
9004 set newhead [exec git rev-parse HEAD]
9005 if {$newhead eq $oldhead} {
9007 error_popup [mc "No changes committed"]
9010 addnewchild $newhead $oldhead
9011 if {[commitinview $oldhead $curview]} {
9012 # XXX this isn't right if we have a path limit...
9013 insertrow $newhead $oldhead $curview
9014 if {$mainhead ne {}} {
9015 movehead $newhead $mainhead
9016 movedhead $newhead $mainhead
9018 set mainheadid $newhead
9027 global mainhead rowmenuid confirm_ok resettype NS
9030 set w ".confirmreset"
9033 wm title $w [mc "Confirm reset"]
9034 ${NS}::label $w.m -text \
9035 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9036 pack $w.m -side top -fill x -padx 20 -pady 20
9037 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9039 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9040 -text [mc "Soft: Leave working tree and index untouched"]
9041 grid $w.f.soft -sticky w
9042 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9043 -text [mc "Mixed: Leave working tree untouched, reset index"]
9044 grid $w.f.mixed -sticky w
9045 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9046 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9047 grid $w.f.hard -sticky w
9048 pack $w.f -side top -fill x -padx 4
9049 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9050 pack $w.ok -side left -fill x -padx 20 -pady 20
9051 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9052 bind $w <Key-Escape> [list destroy $w]
9053 pack $w.cancel -side right -fill x -padx 20 -pady 20
9054 bind $w <Visibility> "grab $w; focus $w"
9056 if {!$confirm_ok} return
9057 if {[catch {set fd [open \
9058 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9062 filerun $fd [list readresetstat $fd]
9063 nowbusy reset [mc "Resetting"]
9068 proc readresetstat {fd} {
9069 global mainhead mainheadid showlocalchanges rprogcoord
9071 if {[gets $fd line] >= 0} {
9072 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9073 set rprogcoord [expr {1.0 * $m / $n}]
9081 if {[catch {close $fd} err]} {
9084 set oldhead $mainheadid
9085 set newhead [exec git rev-parse HEAD]
9086 if {$newhead ne $oldhead} {
9087 movehead $newhead $mainhead
9088 movedhead $newhead $mainhead
9089 set mainheadid $newhead
9093 if {$showlocalchanges} {
9099 # context menu for a head
9100 proc headmenu {x y id head} {
9101 global headmenuid headmenuhead headctxmenu mainhead
9105 set headmenuhead $head
9107 if {[string match "remotes/*" $head]} {
9110 if {$head eq $mainhead} {
9113 $headctxmenu entryconfigure 0 -state $state
9114 $headctxmenu entryconfigure 1 -state $state
9115 tk_popup $headctxmenu $x $y
9119 global headmenuid headmenuhead headids
9120 global showlocalchanges
9122 # check the tree is clean first??
9123 nowbusy checkout [mc "Checking out"]
9127 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9131 if {$showlocalchanges} {
9135 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9139 proc readcheckoutstat {fd newhead newheadid} {
9140 global mainhead mainheadid headids showlocalchanges progresscoords
9141 global viewmainheadid curview
9143 if {[gets $fd line] >= 0} {
9144 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9145 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9150 set progresscoords {0 0}
9153 if {[catch {close $fd} err]} {
9156 set oldmainid $mainheadid
9157 set mainhead $newhead
9158 set mainheadid $newheadid
9159 set viewmainheadid($curview) $newheadid
9160 redrawtags $oldmainid
9161 redrawtags $newheadid
9163 if {$showlocalchanges} {
9169 global headmenuid headmenuhead mainhead
9172 set head $headmenuhead
9174 # this check shouldn't be needed any more...
9175 if {$head eq $mainhead} {
9176 error_popup [mc "Cannot delete the currently checked-out branch"]
9179 set dheads [descheads $id]
9180 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9181 # the stuff on this branch isn't on any other branch
9182 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9183 branch.\nReally delete branch %s?" $head $head]]} return
9187 if {[catch {exec git branch -D $head} err]} {
9192 removehead $id $head
9193 removedhead $id $head
9200 # Display a list of tags and heads
9202 global showrefstop bgcolor fgcolor selectbgcolor NS
9203 global bglist fglist reflistfilter reflist maincursor
9206 set showrefstop $top
9207 if {[winfo exists $top]} {
9213 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9214 make_transient $top .
9215 text $top.list -background $bgcolor -foreground $fgcolor \
9216 -selectbackground $selectbgcolor -font mainfont \
9217 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9218 -width 30 -height 20 -cursor $maincursor \
9219 -spacing1 1 -spacing3 1 -state disabled
9220 $top.list tag configure highlight -background $selectbgcolor
9221 lappend bglist $top.list
9222 lappend fglist $top.list
9223 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9224 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9225 grid $top.list $top.ysb -sticky nsew
9226 grid $top.xsb x -sticky ew
9228 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9229 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9230 set reflistfilter "*"
9231 trace add variable reflistfilter write reflistfilter_change
9232 pack $top.f.e -side right -fill x -expand 1
9233 pack $top.f.l -side left
9234 grid $top.f - -sticky ew -pady 2
9235 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9236 bind $top <Key-Escape> [list destroy $top]
9238 grid columnconfigure $top 0 -weight 1
9239 grid rowconfigure $top 0 -weight 1
9240 bind $top.list <1> {break}
9241 bind $top.list <B1-Motion> {break}
9242 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9247 proc sel_reflist {w x y} {
9248 global showrefstop reflist headids tagids otherrefids
9250 if {![winfo exists $showrefstop]} return
9251 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9252 set ref [lindex $reflist [expr {$l-1}]]
9253 set n [lindex $ref 0]
9254 switch -- [lindex $ref 1] {
9255 "H" {selbyid $headids($n)}
9256 "T" {selbyid $tagids($n)}
9257 "o" {selbyid $otherrefids($n)}
9259 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9262 proc unsel_reflist {} {
9265 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9266 $showrefstop.list tag remove highlight 0.0 end
9269 proc reflistfilter_change {n1 n2 op} {
9270 global reflistfilter
9272 after cancel refill_reflist
9273 after 200 refill_reflist
9276 proc refill_reflist {} {
9277 global reflist reflistfilter showrefstop headids tagids otherrefids
9280 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9282 foreach n [array names headids] {
9283 if {[string match $reflistfilter $n]} {
9284 if {[commitinview $headids($n) $curview]} {
9285 lappend refs [list $n H]
9287 interestedin $headids($n) {run refill_reflist}
9291 foreach n [array names tagids] {
9292 if {[string match $reflistfilter $n]} {
9293 if {[commitinview $tagids($n) $curview]} {
9294 lappend refs [list $n T]
9296 interestedin $tagids($n) {run refill_reflist}
9300 foreach n [array names otherrefids] {
9301 if {[string match $reflistfilter $n]} {
9302 if {[commitinview $otherrefids($n) $curview]} {
9303 lappend refs [list $n o]
9305 interestedin $otherrefids($n) {run refill_reflist}
9309 set refs [lsort -index 0 $refs]
9310 if {$refs eq $reflist} return
9312 # Update the contents of $showrefstop.list according to the
9313 # differences between $reflist (old) and $refs (new)
9314 $showrefstop.list conf -state normal
9315 $showrefstop.list insert end "\n"
9318 while {$i < [llength $reflist] || $j < [llength $refs]} {
9319 if {$i < [llength $reflist]} {
9320 if {$j < [llength $refs]} {
9321 set cmp [string compare [lindex $reflist $i 0] \
9322 [lindex $refs $j 0]]
9324 set cmp [string compare [lindex $reflist $i 1] \
9325 [lindex $refs $j 1]]
9335 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9343 set l [expr {$j + 1}]
9344 $showrefstop.list image create $l.0 -align baseline \
9345 -image reficon-[lindex $refs $j 1] -padx 2
9346 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9352 # delete last newline
9353 $showrefstop.list delete end-2c end-1c
9354 $showrefstop.list conf -state disabled
9357 # Stuff for finding nearby tags
9358 proc getallcommits {} {
9359 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9360 global idheads idtags idotherrefs allparents tagobjid
9362 if {![info exists allcommits]} {
9368 set allccache [file join [gitdir] "gitk.cache"]
9370 set f [open $allccache r]
9379 set cmd [list | git rev-list --parents]
9380 set allcupdate [expr {$seeds ne {}}]
9384 set refs [concat [array names idheads] [array names idtags] \
9385 [array names idotherrefs]]
9388 foreach name [array names tagobjid] {
9389 lappend tagobjs $tagobjid($name)
9391 foreach id [lsort -unique $refs] {
9392 if {![info exists allparents($id)] &&
9393 [lsearch -exact $tagobjs $id] < 0} {
9404 set fd [open [concat $cmd $ids] r]
9405 fconfigure $fd -blocking 0
9408 filerun $fd [list getallclines $fd]
9414 # Since most commits have 1 parent and 1 child, we group strings of
9415 # such commits into "arcs" joining branch/merge points (BMPs), which
9416 # are commits that either don't have 1 parent or don't have 1 child.
9418 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9419 # arcout(id) - outgoing arcs for BMP
9420 # arcids(a) - list of IDs on arc including end but not start
9421 # arcstart(a) - BMP ID at start of arc
9422 # arcend(a) - BMP ID at end of arc
9423 # growing(a) - arc a is still growing
9424 # arctags(a) - IDs out of arcids (excluding end) that have tags
9425 # archeads(a) - IDs out of arcids (excluding end) that have heads
9426 # The start of an arc is at the descendent end, so "incoming" means
9427 # coming from descendents, and "outgoing" means going towards ancestors.
9429 proc getallclines {fd} {
9430 global allparents allchildren idtags idheads nextarc
9431 global arcnos arcids arctags arcout arcend arcstart archeads growing
9432 global seeds allcommits cachedarcs allcupdate
9435 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9436 set id [lindex $line 0]
9437 if {[info exists allparents($id)]} {
9442 set olds [lrange $line 1 end]
9443 set allparents($id) $olds
9444 if {![info exists allchildren($id)]} {
9445 set allchildren($id) {}
9450 if {[llength $olds] == 1 && [llength $a] == 1} {
9451 lappend arcids($a) $id
9452 if {[info exists idtags($id)]} {
9453 lappend arctags($a) $id
9455 if {[info exists idheads($id)]} {
9456 lappend archeads($a) $id
9458 if {[info exists allparents($olds)]} {
9459 # seen parent already
9460 if {![info exists arcout($olds)]} {
9463 lappend arcids($a) $olds
9464 set arcend($a) $olds
9467 lappend allchildren($olds) $id
9468 lappend arcnos($olds) $a
9472 foreach a $arcnos($id) {
9473 lappend arcids($a) $id
9480 lappend allchildren($p) $id
9481 set a [incr nextarc]
9482 set arcstart($a) $id
9489 if {[info exists allparents($p)]} {
9490 # seen it already, may need to make a new branch
9491 if {![info exists arcout($p)]} {
9494 lappend arcids($a) $p
9498 lappend arcnos($p) $a
9503 global cached_dheads cached_dtags cached_atags
9504 catch {unset cached_dheads}
9505 catch {unset cached_dtags}
9506 catch {unset cached_atags}
9509 return [expr {$nid >= 1000? 2: 1}]
9513 fconfigure $fd -blocking 1
9516 # got an error reading the list of commits
9517 # if we were updating, try rereading the whole thing again
9523 error_popup "[mc "Error reading commit topology information;\
9524 branch and preceding/following tag information\
9525 will be incomplete."]\n($err)"
9528 if {[incr allcommits -1] == 0} {
9538 proc recalcarc {a} {
9539 global arctags archeads arcids idtags idheads
9543 foreach id [lrange $arcids($a) 0 end-1] {
9544 if {[info exists idtags($id)]} {
9547 if {[info exists idheads($id)]} {
9552 set archeads($a) $ah
9556 global arcnos arcids nextarc arctags archeads idtags idheads
9557 global arcstart arcend arcout allparents growing
9560 if {[llength $a] != 1} {
9561 puts "oops splitarc called but [llength $a] arcs already"
9565 set i [lsearch -exact $arcids($a) $p]
9567 puts "oops splitarc $p not in arc $a"
9570 set na [incr nextarc]
9571 if {[info exists arcend($a)]} {
9572 set arcend($na) $arcend($a)
9574 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9575 set j [lsearch -exact $arcnos($l) $a]
9576 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9578 set tail [lrange $arcids($a) [expr {$i+1}] end]
9579 set arcids($a) [lrange $arcids($a) 0 $i]
9581 set arcstart($na) $p
9583 set arcids($na) $tail
9584 if {[info exists growing($a)]} {
9590 if {[llength $arcnos($id)] == 1} {
9593 set j [lsearch -exact $arcnos($id) $a]
9594 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9598 # reconstruct tags and heads lists
9599 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9604 set archeads($na) {}
9608 # Update things for a new commit added that is a child of one
9609 # existing commit. Used when cherry-picking.
9610 proc addnewchild {id p} {
9611 global allparents allchildren idtags nextarc
9612 global arcnos arcids arctags arcout arcend arcstart archeads growing
9613 global seeds allcommits
9615 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9616 set allparents($id) [list $p]
9617 set allchildren($id) {}
9620 lappend allchildren($p) $id
9621 set a [incr nextarc]
9622 set arcstart($a) $id
9625 set arcids($a) [list $p]
9627 if {![info exists arcout($p)]} {
9630 lappend arcnos($p) $a
9631 set arcout($id) [list $a]
9634 # This implements a cache for the topology information.
9635 # The cache saves, for each arc, the start and end of the arc,
9636 # the ids on the arc, and the outgoing arcs from the end.
9637 proc readcache {f} {
9638 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9639 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9644 if {$lim - $a > 500} {
9645 set lim [expr {$a + 500}]
9649 # finish reading the cache and setting up arctags, etc.
9651 if {$line ne "1"} {error "bad final version"}
9653 foreach id [array names idtags] {
9654 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9655 [llength $allparents($id)] == 1} {
9656 set a [lindex $arcnos($id) 0]
9657 if {$arctags($a) eq {}} {
9662 foreach id [array names idheads] {
9663 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9664 [llength $allparents($id)] == 1} {
9665 set a [lindex $arcnos($id) 0]
9666 if {$archeads($a) eq {}} {
9671 foreach id [lsort -unique $possible_seeds] {
9672 if {$arcnos($id) eq {}} {
9678 while {[incr a] <= $lim} {
9680 if {[llength $line] != 3} {error "bad line"}
9681 set s [lindex $line 0]
9683 lappend arcout($s) $a
9684 if {![info exists arcnos($s)]} {
9685 lappend possible_seeds $s
9688 set e [lindex $line 1]
9693 if {![info exists arcout($e)]} {
9697 set arcids($a) [lindex $line 2]
9698 foreach id $arcids($a) {
9699 lappend allparents($s) $id
9701 lappend arcnos($id) $a
9703 if {![info exists allparents($s)]} {
9704 set allparents($s) {}
9709 set nextarc [expr {$a - 1}]
9722 global nextarc cachedarcs possible_seeds
9726 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9727 # make sure it's an integer
9728 set cachedarcs [expr {int([lindex $line 1])}]
9729 if {$cachedarcs < 0} {error "bad number of arcs"}
9731 set possible_seeds {}
9739 proc dropcache {err} {
9740 global allcwait nextarc cachedarcs seeds
9742 #puts "dropping cache ($err)"
9743 foreach v {arcnos arcout arcids arcstart arcend growing \
9744 arctags archeads allparents allchildren} {
9755 proc writecache {f} {
9756 global cachearc cachedarcs allccache
9757 global arcstart arcend arcnos arcids arcout
9761 if {$lim - $a > 1000} {
9762 set lim [expr {$a + 1000}]
9765 while {[incr a] <= $lim} {
9766 if {[info exists arcend($a)]} {
9767 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9769 puts $f [list $arcstart($a) {} $arcids($a)]
9774 catch {file delete $allccache}
9775 #puts "writing cache failed ($err)"
9778 set cachearc [expr {$a - 1}]
9779 if {$a > $cachedarcs} {
9788 global nextarc cachedarcs cachearc allccache
9790 if {$nextarc == $cachedarcs} return
9792 set cachedarcs $nextarc
9794 set f [open $allccache w]
9795 puts $f [list 1 $cachedarcs]
9800 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9801 # or 0 if neither is true.
9802 proc anc_or_desc {a b} {
9803 global arcout arcstart arcend arcnos cached_isanc
9805 if {$arcnos($a) eq $arcnos($b)} {
9806 # Both are on the same arc(s); either both are the same BMP,
9807 # or if one is not a BMP, the other is also not a BMP or is
9808 # the BMP at end of the arc (and it only has 1 incoming arc).
9809 # Or both can be BMPs with no incoming arcs.
9810 if {$a eq $b || $arcnos($a) eq {}} {
9813 # assert {[llength $arcnos($a)] == 1}
9814 set arc [lindex $arcnos($a) 0]
9815 set i [lsearch -exact $arcids($arc) $a]
9816 set j [lsearch -exact $arcids($arc) $b]
9817 if {$i < 0 || $i > $j} {
9824 if {![info exists arcout($a)]} {
9825 set arc [lindex $arcnos($a) 0]
9826 if {[info exists arcend($arc)]} {
9827 set aend $arcend($arc)
9831 set a $arcstart($arc)
9835 if {![info exists arcout($b)]} {
9836 set arc [lindex $arcnos($b) 0]
9837 if {[info exists arcend($arc)]} {
9838 set bend $arcend($arc)
9842 set b $arcstart($arc)
9852 if {[info exists cached_isanc($a,$bend)]} {
9853 if {$cached_isanc($a,$bend)} {
9857 if {[info exists cached_isanc($b,$aend)]} {
9858 if {$cached_isanc($b,$aend)} {
9861 if {[info exists cached_isanc($a,$bend)]} {
9866 set todo [list $a $b]
9869 for {set i 0} {$i < [llength $todo]} {incr i} {
9870 set x [lindex $todo $i]
9871 if {$anc($x) eq {}} {
9874 foreach arc $arcnos($x) {
9875 set xd $arcstart($arc)
9877 set cached_isanc($a,$bend) 1
9878 set cached_isanc($b,$aend) 0
9880 } elseif {$xd eq $aend} {
9881 set cached_isanc($b,$aend) 1
9882 set cached_isanc($a,$bend) 0
9885 if {![info exists anc($xd)]} {
9886 set anc($xd) $anc($x)
9888 } elseif {$anc($xd) ne $anc($x)} {
9893 set cached_isanc($a,$bend) 0
9894 set cached_isanc($b,$aend) 0
9898 # This identifies whether $desc has an ancestor that is
9899 # a growing tip of the graph and which is not an ancestor of $anc
9900 # and returns 0 if so and 1 if not.
9901 # If we subsequently discover a tag on such a growing tip, and that
9902 # turns out to be a descendent of $anc (which it could, since we
9903 # don't necessarily see children before parents), then $desc
9904 # isn't a good choice to display as a descendent tag of
9905 # $anc (since it is the descendent of another tag which is
9906 # a descendent of $anc). Similarly, $anc isn't a good choice to
9907 # display as a ancestor tag of $desc.
9909 proc is_certain {desc anc} {
9910 global arcnos arcout arcstart arcend growing problems
9913 if {[llength $arcnos($anc)] == 1} {
9914 # tags on the same arc are certain
9915 if {$arcnos($desc) eq $arcnos($anc)} {
9918 if {![info exists arcout($anc)]} {
9919 # if $anc is partway along an arc, use the start of the arc instead
9920 set a [lindex $arcnos($anc) 0]
9921 set anc $arcstart($a)
9924 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9927 set a [lindex $arcnos($desc) 0]
9933 set anclist [list $x]
9937 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9938 set x [lindex $anclist $i]
9943 foreach a $arcout($x) {
9944 if {[info exists growing($a)]} {
9945 if {![info exists growanc($x)] && $dl($x)} {
9951 if {[info exists dl($y)]} {
9955 if {![info exists done($y)]} {
9958 if {[info exists growanc($x)]} {
9962 for {set k 0} {$k < [llength $xl]} {incr k} {
9963 set z [lindex $xl $k]
9964 foreach c $arcout($z) {
9965 if {[info exists arcend($c)]} {
9967 if {[info exists dl($v)] && $dl($v)} {
9969 if {![info exists done($v)]} {
9972 if {[info exists growanc($v)]} {
9982 } elseif {$y eq $anc || !$dl($x)} {
9993 foreach x [array names growanc] {
10002 proc validate_arctags {a} {
10003 global arctags idtags
10006 set na $arctags($a)
10007 foreach id $arctags($a) {
10009 if {![info exists idtags($id)]} {
10010 set na [lreplace $na $i $i]
10014 set arctags($a) $na
10017 proc validate_archeads {a} {
10018 global archeads idheads
10021 set na $archeads($a)
10022 foreach id $archeads($a) {
10024 if {![info exists idheads($id)]} {
10025 set na [lreplace $na $i $i]
10029 set archeads($a) $na
10032 # Return the list of IDs that have tags that are descendents of id,
10033 # ignoring IDs that are descendents of IDs already reported.
10034 proc desctags {id} {
10035 global arcnos arcstart arcids arctags idtags allparents
10036 global growing cached_dtags
10038 if {![info exists allparents($id)]} {
10041 set t1 [clock clicks -milliseconds]
10043 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10044 # part-way along an arc; check that arc first
10045 set a [lindex $arcnos($id) 0]
10046 if {$arctags($a) ne {}} {
10047 validate_arctags $a
10048 set i [lsearch -exact $arcids($a) $id]
10050 foreach t $arctags($a) {
10051 set j [lsearch -exact $arcids($a) $t]
10052 if {$j >= $i} break
10059 set id $arcstart($a)
10060 if {[info exists idtags($id)]} {
10064 if {[info exists cached_dtags($id)]} {
10065 return $cached_dtags($id)
10069 set todo [list $id]
10072 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10073 set id [lindex $todo $i]
10075 set ta [info exists hastaggedancestor($id)]
10079 # ignore tags on starting node
10080 if {!$ta && $i > 0} {
10081 if {[info exists idtags($id)]} {
10082 set tagloc($id) $id
10084 } elseif {[info exists cached_dtags($id)]} {
10085 set tagloc($id) $cached_dtags($id)
10089 foreach a $arcnos($id) {
10090 set d $arcstart($a)
10091 if {!$ta && $arctags($a) ne {}} {
10092 validate_arctags $a
10093 if {$arctags($a) ne {}} {
10094 lappend tagloc($id) [lindex $arctags($a) end]
10097 if {$ta || $arctags($a) ne {}} {
10098 set tomark [list $d]
10099 for {set j 0} {$j < [llength $tomark]} {incr j} {
10100 set dd [lindex $tomark $j]
10101 if {![info exists hastaggedancestor($dd)]} {
10102 if {[info exists done($dd)]} {
10103 foreach b $arcnos($dd) {
10104 lappend tomark $arcstart($b)
10106 if {[info exists tagloc($dd)]} {
10109 } elseif {[info exists queued($dd)]} {
10112 set hastaggedancestor($dd) 1
10116 if {![info exists queued($d)]} {
10119 if {![info exists hastaggedancestor($d)]} {
10126 foreach id [array names tagloc] {
10127 if {![info exists hastaggedancestor($id)]} {
10128 foreach t $tagloc($id) {
10129 if {[lsearch -exact $tags $t] < 0} {
10135 set t2 [clock clicks -milliseconds]
10138 # remove tags that are descendents of other tags
10139 for {set i 0} {$i < [llength $tags]} {incr i} {
10140 set a [lindex $tags $i]
10141 for {set j 0} {$j < $i} {incr j} {
10142 set b [lindex $tags $j]
10143 set r [anc_or_desc $a $b]
10145 set tags [lreplace $tags $j $j]
10148 } elseif {$r == -1} {
10149 set tags [lreplace $tags $i $i]
10156 if {[array names growing] ne {}} {
10157 # graph isn't finished, need to check if any tag could get
10158 # eclipsed by another tag coming later. Simply ignore any
10159 # tags that could later get eclipsed.
10162 if {[is_certain $t $origid]} {
10166 if {$tags eq $ctags} {
10167 set cached_dtags($origid) $tags
10172 set cached_dtags($origid) $tags
10174 set t3 [clock clicks -milliseconds]
10175 if {0 && $t3 - $t1 >= 100} {
10176 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10177 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10182 proc anctags {id} {
10183 global arcnos arcids arcout arcend arctags idtags allparents
10184 global growing cached_atags
10186 if {![info exists allparents($id)]} {
10189 set t1 [clock clicks -milliseconds]
10191 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10192 # part-way along an arc; check that arc first
10193 set a [lindex $arcnos($id) 0]
10194 if {$arctags($a) ne {}} {
10195 validate_arctags $a
10196 set i [lsearch -exact $arcids($a) $id]
10197 foreach t $arctags($a) {
10198 set j [lsearch -exact $arcids($a) $t]
10204 if {![info exists arcend($a)]} {
10208 if {[info exists idtags($id)]} {
10212 if {[info exists cached_atags($id)]} {
10213 return $cached_atags($id)
10217 set todo [list $id]
10221 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10222 set id [lindex $todo $i]
10224 set td [info exists hastaggeddescendent($id)]
10228 # ignore tags on starting node
10229 if {!$td && $i > 0} {
10230 if {[info exists idtags($id)]} {
10231 set tagloc($id) $id
10233 } elseif {[info exists cached_atags($id)]} {
10234 set tagloc($id) $cached_atags($id)
10238 foreach a $arcout($id) {
10239 if {!$td && $arctags($a) ne {}} {
10240 validate_arctags $a
10241 if {$arctags($a) ne {}} {
10242 lappend tagloc($id) [lindex $arctags($a) 0]
10245 if {![info exists arcend($a)]} continue
10247 if {$td || $arctags($a) ne {}} {
10248 set tomark [list $d]
10249 for {set j 0} {$j < [llength $tomark]} {incr j} {
10250 set dd [lindex $tomark $j]
10251 if {![info exists hastaggeddescendent($dd)]} {
10252 if {[info exists done($dd)]} {
10253 foreach b $arcout($dd) {
10254 if {[info exists arcend($b)]} {
10255 lappend tomark $arcend($b)
10258 if {[info exists tagloc($dd)]} {
10261 } elseif {[info exists queued($dd)]} {
10264 set hastaggeddescendent($dd) 1
10268 if {![info exists queued($d)]} {
10271 if {![info exists hastaggeddescendent($d)]} {
10277 set t2 [clock clicks -milliseconds]
10280 foreach id [array names tagloc] {
10281 if {![info exists hastaggeddescendent($id)]} {
10282 foreach t $tagloc($id) {
10283 if {[lsearch -exact $tags $t] < 0} {
10290 # remove tags that are ancestors of other tags
10291 for {set i 0} {$i < [llength $tags]} {incr i} {
10292 set a [lindex $tags $i]
10293 for {set j 0} {$j < $i} {incr j} {
10294 set b [lindex $tags $j]
10295 set r [anc_or_desc $a $b]
10297 set tags [lreplace $tags $j $j]
10300 } elseif {$r == 1} {
10301 set tags [lreplace $tags $i $i]
10308 if {[array names growing] ne {}} {
10309 # graph isn't finished, need to check if any tag could get
10310 # eclipsed by another tag coming later. Simply ignore any
10311 # tags that could later get eclipsed.
10314 if {[is_certain $origid $t]} {
10318 if {$tags eq $ctags} {
10319 set cached_atags($origid) $tags
10324 set cached_atags($origid) $tags
10326 set t3 [clock clicks -milliseconds]
10327 if {0 && $t3 - $t1 >= 100} {
10328 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10329 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10334 # Return the list of IDs that have heads that are descendents of id,
10335 # including id itself if it has a head.
10336 proc descheads {id} {
10337 global arcnos arcstart arcids archeads idheads cached_dheads
10340 if {![info exists allparents($id)]} {
10344 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10345 # part-way along an arc; check it first
10346 set a [lindex $arcnos($id) 0]
10347 if {$archeads($a) ne {}} {
10348 validate_archeads $a
10349 set i [lsearch -exact $arcids($a) $id]
10350 foreach t $archeads($a) {
10351 set j [lsearch -exact $arcids($a) $t]
10356 set id $arcstart($a)
10359 set todo [list $id]
10362 for {set i 0} {$i < [llength $todo]} {incr i} {
10363 set id [lindex $todo $i]
10364 if {[info exists cached_dheads($id)]} {
10365 set ret [concat $ret $cached_dheads($id)]
10367 if {[info exists idheads($id)]} {
10370 foreach a $arcnos($id) {
10371 if {$archeads($a) ne {}} {
10372 validate_archeads $a
10373 if {$archeads($a) ne {}} {
10374 set ret [concat $ret $archeads($a)]
10377 set d $arcstart($a)
10378 if {![info exists seen($d)]} {
10385 set ret [lsort -unique $ret]
10386 set cached_dheads($origid) $ret
10387 return [concat $ret $aret]
10390 proc addedtag {id} {
10391 global arcnos arcout cached_dtags cached_atags
10393 if {![info exists arcnos($id)]} return
10394 if {![info exists arcout($id)]} {
10395 recalcarc [lindex $arcnos($id) 0]
10397 catch {unset cached_dtags}
10398 catch {unset cached_atags}
10401 proc addedhead {hid head} {
10402 global arcnos arcout cached_dheads
10404 if {![info exists arcnos($hid)]} return
10405 if {![info exists arcout($hid)]} {
10406 recalcarc [lindex $arcnos($hid) 0]
10408 catch {unset cached_dheads}
10411 proc removedhead {hid head} {
10412 global cached_dheads
10414 catch {unset cached_dheads}
10417 proc movedhead {hid head} {
10418 global arcnos arcout cached_dheads
10420 if {![info exists arcnos($hid)]} return
10421 if {![info exists arcout($hid)]} {
10422 recalcarc [lindex $arcnos($hid) 0]
10424 catch {unset cached_dheads}
10427 proc changedrefs {} {
10428 global cached_dheads cached_dtags cached_atags
10429 global arctags archeads arcnos arcout idheads idtags
10431 foreach id [concat [array names idheads] [array names idtags]] {
10432 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10433 set a [lindex $arcnos($id) 0]
10434 if {![info exists donearc($a)]} {
10440 catch {unset cached_dtags}
10441 catch {unset cached_atags}
10442 catch {unset cached_dheads}
10445 proc rereadrefs {} {
10446 global idtags idheads idotherrefs mainheadid
10448 set refids [concat [array names idtags] \
10449 [array names idheads] [array names idotherrefs]]
10450 foreach id $refids {
10451 if {![info exists ref($id)]} {
10452 set ref($id) [listrefs $id]
10455 set oldmainhead $mainheadid
10458 set refids [lsort -unique [concat $refids [array names idtags] \
10459 [array names idheads] [array names idotherrefs]]]
10460 foreach id $refids {
10461 set v [listrefs $id]
10462 if {![info exists ref($id)] || $ref($id) != $v} {
10466 if {$oldmainhead ne $mainheadid} {
10467 redrawtags $oldmainhead
10468 redrawtags $mainheadid
10473 proc listrefs {id} {
10474 global idtags idheads idotherrefs
10477 if {[info exists idtags($id)]} {
10481 if {[info exists idheads($id)]} {
10482 set y $idheads($id)
10485 if {[info exists idotherrefs($id)]} {
10486 set z $idotherrefs($id)
10488 return [list $x $y $z]
10491 proc showtag {tag isnew} {
10492 global ctext tagcontents tagids linknum tagobjid
10495 addtohistory [list showtag $tag 0] savectextpos
10497 $ctext conf -state normal
10501 if {![info exists tagcontents($tag)]} {
10503 set tagcontents($tag) [exec git cat-file tag $tag]
10506 if {[info exists tagcontents($tag)]} {
10507 set text $tagcontents($tag)
10509 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10511 appendwithlinks $text {}
10512 maybe_scroll_ctext 1
10513 $ctext conf -state disabled
10525 if {[info exists gitktmpdir]} {
10526 catch {file delete -force $gitktmpdir}
10530 proc mkfontdisp {font top which} {
10531 global fontattr fontpref $font NS use_ttk
10533 set fontpref($font) [set $font]
10534 ${NS}::button $top.${font}but -text $which \
10535 -command [list choosefont $font $which]
10536 ${NS}::label $top.$font -relief flat -font $font \
10537 -text $fontattr($font,family) -justify left
10538 grid x $top.${font}but $top.$font -sticky w
10541 proc choosefont {font which} {
10542 global fontparam fontlist fonttop fontattr
10545 set fontparam(which) $which
10546 set fontparam(font) $font
10547 set fontparam(family) [font actual $font -family]
10548 set fontparam(size) $fontattr($font,size)
10549 set fontparam(weight) $fontattr($font,weight)
10550 set fontparam(slant) $fontattr($font,slant)
10553 if {![winfo exists $top]} {
10555 eval font config sample [font actual $font]
10557 make_transient $top $prefstop
10558 wm title $top [mc "Gitk font chooser"]
10559 ${NS}::label $top.l -textvariable fontparam(which)
10560 pack $top.l -side top
10561 set fontlist [lsort [font families]]
10562 ${NS}::frame $top.f
10563 listbox $top.f.fam -listvariable fontlist \
10564 -yscrollcommand [list $top.f.sb set]
10565 bind $top.f.fam <<ListboxSelect>> selfontfam
10566 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10567 pack $top.f.sb -side right -fill y
10568 pack $top.f.fam -side left -fill both -expand 1
10569 pack $top.f -side top -fill both -expand 1
10570 ${NS}::frame $top.g
10571 spinbox $top.g.size -from 4 -to 40 -width 4 \
10572 -textvariable fontparam(size) \
10573 -validatecommand {string is integer -strict %s}
10574 checkbutton $top.g.bold -padx 5 \
10575 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10576 -variable fontparam(weight) -onvalue bold -offvalue normal
10577 checkbutton $top.g.ital -padx 5 \
10578 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10579 -variable fontparam(slant) -onvalue italic -offvalue roman
10580 pack $top.g.size $top.g.bold $top.g.ital -side left
10581 pack $top.g -side top
10582 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10584 $top.c create text 100 25 -anchor center -text $which -font sample \
10585 -fill black -tags text
10586 bind $top.c <Configure> [list centertext $top.c]
10587 pack $top.c -side top -fill x
10588 ${NS}::frame $top.buts
10589 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10590 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10591 bind $top <Key-Return> fontok
10592 bind $top <Key-Escape> fontcan
10593 grid $top.buts.ok $top.buts.can
10594 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10595 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10596 pack $top.buts -side bottom -fill x
10597 trace add variable fontparam write chg_fontparam
10600 $top.c itemconf text -text $which
10602 set i [lsearch -exact $fontlist $fontparam(family)]
10604 $top.f.fam selection set $i
10609 proc centertext {w} {
10610 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10614 global fontparam fontpref prefstop
10616 set f $fontparam(font)
10617 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10618 if {$fontparam(weight) eq "bold"} {
10619 lappend fontpref($f) "bold"
10621 if {$fontparam(slant) eq "italic"} {
10622 lappend fontpref($f) "italic"
10625 $w conf -text $fontparam(family) -font $fontpref($f)
10631 global fonttop fontparam
10633 if {[info exists fonttop]} {
10634 catch {destroy $fonttop}
10635 catch {font delete sample}
10641 if {[package vsatisfies [package provide Tk] 8.6]} {
10642 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10643 # function to make use of it.
10644 proc choosefont {font which} {
10645 tk fontchooser configure -title $which -font $font \
10646 -command [list on_choosefont $font $which]
10647 tk fontchooser show
10649 proc on_choosefont {font which newfont} {
10651 puts stderr "$font $newfont"
10652 array set f [font actual $newfont]
10653 set fontparam(which) $which
10654 set fontparam(font) $font
10655 set fontparam(family) $f(-family)
10656 set fontparam(size) $f(-size)
10657 set fontparam(weight) $f(-weight)
10658 set fontparam(slant) $f(-slant)
10663 proc selfontfam {} {
10664 global fonttop fontparam
10666 set i [$fonttop.f.fam curselection]
10668 set fontparam(family) [$fonttop.f.fam get $i]
10672 proc chg_fontparam {v sub op} {
10675 font config sample -$sub $fontparam($sub)
10679 global maxwidth maxgraphpct use_ttk NS
10680 global oldprefs prefstop showneartags showlocalchanges
10681 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10682 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10683 global hideremotes want_ttk have_ttk
10687 if {[winfo exists $top]} {
10691 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10692 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10693 set oldprefs($v) [set $v]
10696 wm title $top [mc "Gitk preferences"]
10697 make_transient $top .
10698 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10699 grid $top.ldisp - -sticky w -pady 10
10700 ${NS}::label $top.spacer -text " "
10701 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10702 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10703 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10704 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10705 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10706 grid x $top.maxpctl $top.maxpct -sticky w
10707 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10708 -variable showlocalchanges
10709 grid x $top.showlocal -sticky w
10710 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10711 -variable autoselect
10712 grid x $top.autoselect -sticky w
10713 ${NS}::checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10714 -variable hideremotes
10715 grid x $top.hideremotes -sticky w
10717 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10718 grid $top.ddisp - -sticky w -pady 10
10719 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10720 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10721 grid x $top.tabstopl $top.tabstop -sticky w
10722 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10723 -variable showneartags
10724 grid x $top.ntag -sticky w
10725 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10726 -variable limitdiffs
10727 grid x $top.ldiff -sticky w
10728 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10729 -variable perfile_attrs
10730 grid x $top.lattr -sticky w
10732 ${NS}::entry $top.extdifft -textvariable extdifftool
10733 ${NS}::frame $top.extdifff
10734 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10735 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10736 pack $top.extdifff.l $top.extdifff.b -side left
10737 pack configure $top.extdifff.l -padx 10
10738 grid x $top.extdifff $top.extdifft -sticky ew
10740 ${NS}::label $top.lgen -text [mc "General options"]
10741 grid $top.lgen - -sticky w -pady 10
10742 ${NS}::checkbutton $top.want_ttk -variable want_ttk \
10743 -text [mc "Use themed widgets"]
10745 ${NS}::label $top.ttk_note -text [mc "(change requires restart)"]
10747 ${NS}::label $top.ttk_note -text [mc "(currently unavailable)"]
10749 grid x $top.want_ttk $top.ttk_note -sticky w
10751 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10752 grid $top.cdisp - -sticky w -pady 10
10753 label $top.ui -padx 40 -relief sunk -background $uicolor
10754 ${NS}::button $top.uibut -text [mc "Interface"] \
10755 -command [list choosecolor uicolor {} $top.ui [mc "interface"] setui]
10756 grid x $top.uibut $top.ui -sticky w
10757 label $top.bg -padx 40 -relief sunk -background $bgcolor
10758 ${NS}::button $top.bgbut -text [mc "Background"] \
10759 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10760 grid x $top.bgbut $top.bg -sticky w
10761 label $top.fg -padx 40 -relief sunk -background $fgcolor
10762 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10763 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10764 grid x $top.fgbut $top.fg -sticky w
10765 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10766 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10767 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10768 [list $ctext tag conf d0 -foreground]]
10769 grid x $top.diffoldbut $top.diffold -sticky w
10770 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10771 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10772 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10773 [list $ctext tag conf dresult -foreground]]
10774 grid x $top.diffnewbut $top.diffnew -sticky w
10775 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10776 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10777 -command [list choosecolor diffcolors 2 $top.hunksep \
10778 [mc "diff hunk header"] \
10779 [list $ctext tag conf hunksep -foreground]]
10780 grid x $top.hunksepbut $top.hunksep -sticky w
10781 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10782 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10783 -command [list choosecolor markbgcolor {} $top.markbgsep \
10784 [mc "marked line background"] \
10785 [list $ctext tag conf omark -background]]
10786 grid x $top.markbgbut $top.markbgsep -sticky w
10787 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10788 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10789 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10790 grid x $top.selbgbut $top.selbgsep -sticky w
10792 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10793 grid $top.cfont - -sticky w -pady 10
10794 mkfontdisp mainfont $top [mc "Main font"]
10795 mkfontdisp textfont $top [mc "Diff display font"]
10796 mkfontdisp uifont $top [mc "User interface font"]
10798 ${NS}::frame $top.buts
10799 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10800 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10801 bind $top <Key-Return> prefsok
10802 bind $top <Key-Escape> prefscan
10803 grid $top.buts.ok $top.buts.can
10804 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10805 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10806 grid $top.buts - - -pady 10 -sticky ew
10807 grid columnconfigure $top 2 -weight 1
10808 bind $top <Visibility> "focus $top.buts.ok"
10811 proc choose_extdiff {} {
10814 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10816 set extdifftool $prog
10820 proc choosecolor {v vi w x cmd} {
10823 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10824 -title [mc "Gitk: choose color for %s" $x]]
10825 if {$c eq {}} return
10826 $w conf -background $c
10831 proc setselbg {c} {
10832 global bglist cflist
10833 foreach w $bglist {
10834 $w configure -selectbackground $c
10836 $cflist tag configure highlight \
10837 -background [$cflist cget -selectbackground]
10838 allcanvs itemconf secsel -fill $c
10841 # This sets the background color and the color scheme for the whole UI.
10842 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
10843 # if we don't specify one ourselves, which makes the checkbuttons and
10844 # radiobuttons look bad. This chooses white for selectColor if the
10845 # background color is light, or black if it is dark.
10847 set bg [winfo rgb . $c]
10849 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
10852 tk_setPalette background $c selectColor $selc
10858 foreach w $bglist {
10859 $w conf -background $c
10866 foreach w $fglist {
10867 $w conf -foreground $c
10869 allcanvs itemconf text -fill $c
10870 $canv itemconf circle -outline $c
10871 $canv itemconf markid -outline $c
10875 global oldprefs prefstop
10877 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10878 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10880 set $v $oldprefs($v)
10882 catch {destroy $prefstop}
10888 global maxwidth maxgraphpct
10889 global oldprefs prefstop showneartags showlocalchanges
10890 global fontpref mainfont textfont uifont
10891 global limitdiffs treediffs perfile_attrs
10894 catch {destroy $prefstop}
10898 if {$mainfont ne $fontpref(mainfont)} {
10899 set mainfont $fontpref(mainfont)
10900 parsefont mainfont $mainfont
10901 eval font configure mainfont [fontflags mainfont]
10902 eval font configure mainfontbold [fontflags mainfont 1]
10906 if {$textfont ne $fontpref(textfont)} {
10907 set textfont $fontpref(textfont)
10908 parsefont textfont $textfont
10909 eval font configure textfont [fontflags textfont]
10910 eval font configure textfontbold [fontflags textfont 1]
10912 if {$uifont ne $fontpref(uifont)} {
10913 set uifont $fontpref(uifont)
10914 parsefont uifont $uifont
10915 eval font configure uifont [fontflags uifont]
10918 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10919 if {$showlocalchanges} {
10925 if {$limitdiffs != $oldprefs(limitdiffs) ||
10926 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10927 # treediffs elements are limited by path;
10928 # won't have encodings cached if perfile_attrs was just turned on
10929 catch {unset treediffs}
10931 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10932 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10934 } elseif {$showneartags != $oldprefs(showneartags) ||
10935 $limitdiffs != $oldprefs(limitdiffs)} {
10938 if {$hideremotes != $oldprefs(hideremotes)} {
10943 proc formatdate {d} {
10944 global datetimeformat
10946 set d [clock format $d -format $datetimeformat]
10951 # This list of encoding names and aliases is distilled from
10952 # http://www.iana.org/assignments/character-sets.
10953 # Not all of them are supported by Tcl.
10954 set encoding_aliases {
10955 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10956 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10957 { ISO-10646-UTF-1 csISO10646UTF1 }
10958 { ISO_646.basic:1983 ref csISO646basic1983 }
10959 { INVARIANT csINVARIANT }
10960 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10961 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10962 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10963 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10964 { NATS-DANO iso-ir-9-1 csNATSDANO }
10965 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10966 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10967 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10968 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10969 { ISO-2022-KR csISO2022KR }
10971 { ISO-2022-JP csISO2022JP }
10972 { ISO-2022-JP-2 csISO2022JP2 }
10973 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10974 csISO13JISC6220jp }
10975 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10976 { IT iso-ir-15 ISO646-IT csISO15Italian }
10977 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10978 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10979 { greek7-old iso-ir-18 csISO18Greek7Old }
10980 { latin-greek iso-ir-19 csISO19LatinGreek }
10981 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10982 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10983 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10984 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10985 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10986 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10987 { INIS iso-ir-49 csISO49INIS }
10988 { INIS-8 iso-ir-50 csISO50INIS8 }
10989 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10990 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10991 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10992 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10993 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10994 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10995 csISO60Norwegian1 }
10996 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10997 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10998 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10999 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11000 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11001 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11002 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11003 { greek7 iso-ir-88 csISO88Greek7 }
11004 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11005 { iso-ir-90 csISO90 }
11006 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11007 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11008 csISO92JISC62991984b }
11009 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11010 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11011 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11012 csISO95JIS62291984handadd }
11013 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11014 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11015 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11016 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11017 CP819 csISOLatin1 }
11018 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11019 { T.61-7bit iso-ir-102 csISO102T617bit }
11020 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11021 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11022 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11023 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11024 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11025 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11026 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11027 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11028 arabic csISOLatinArabic }
11029 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11030 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11031 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11032 greek greek8 csISOLatinGreek }
11033 { T.101-G2 iso-ir-128 csISO128T101G2 }
11034 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11036 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11037 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11038 { CSN_369103 iso-ir-139 csISO139CSN369103 }
11039 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11040 { ISO_6937-2-add iso-ir-142 csISOTextComm }
11041 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11042 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11043 csISOLatinCyrillic }
11044 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11045 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11046 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11047 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11048 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11049 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11050 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11051 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11052 { ISO_10367-box iso-ir-155 csISO10367Box }
11053 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11054 { latin-lap lap iso-ir-158 csISO158Lap }
11055 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11056 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11059 { JIS_X0201 X0201 csHalfWidthKatakana }
11060 { KSC5636 ISO646-KR csKSC5636 }
11061 { ISO-10646-UCS-2 csUnicode }
11062 { ISO-10646-UCS-4 csUCS4 }
11063 { DEC-MCS dec csDECMCS }
11064 { hp-roman8 roman8 r8 csHPRoman8 }
11065 { macintosh mac csMacintosh }
11066 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11068 { IBM038 EBCDIC-INT cp038 csIBM038 }
11069 { IBM273 CP273 csIBM273 }
11070 { IBM274 EBCDIC-BE CP274 csIBM274 }
11071 { IBM275 EBCDIC-BR cp275 csIBM275 }
11072 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11073 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11074 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11075 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11076 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11077 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11078 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11079 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11080 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11081 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11082 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11083 { IBM437 cp437 437 csPC8CodePage437 }
11084 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11085 { IBM775 cp775 csPC775Baltic }
11086 { IBM850 cp850 850 csPC850Multilingual }
11087 { IBM851 cp851 851 csIBM851 }
11088 { IBM852 cp852 852 csPCp852 }
11089 { IBM855 cp855 855 csIBM855 }
11090 { IBM857 cp857 857 csIBM857 }
11091 { IBM860 cp860 860 csIBM860 }
11092 { IBM861 cp861 861 cp-is csIBM861 }
11093 { IBM862 cp862 862 csPC862LatinHebrew }
11094 { IBM863 cp863 863 csIBM863 }
11095 { IBM864 cp864 csIBM864 }
11096 { IBM865 cp865 865 csIBM865 }
11097 { IBM866 cp866 866 csIBM866 }
11098 { IBM868 CP868 cp-ar csIBM868 }
11099 { IBM869 cp869 869 cp-gr csIBM869 }
11100 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11101 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11102 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11103 { IBM891 cp891 csIBM891 }
11104 { IBM903 cp903 csIBM903 }
11105 { IBM904 cp904 904 csIBBM904 }
11106 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11107 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11108 { IBM1026 CP1026 csIBM1026 }
11109 { EBCDIC-AT-DE csIBMEBCDICATDE }
11110 { EBCDIC-AT-DE-A csEBCDICATDEA }
11111 { EBCDIC-CA-FR csEBCDICCAFR }
11112 { EBCDIC-DK-NO csEBCDICDKNO }
11113 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11114 { EBCDIC-FI-SE csEBCDICFISE }
11115 { EBCDIC-FI-SE-A csEBCDICFISEA }
11116 { EBCDIC-FR csEBCDICFR }
11117 { EBCDIC-IT csEBCDICIT }
11118 { EBCDIC-PT csEBCDICPT }
11119 { EBCDIC-ES csEBCDICES }
11120 { EBCDIC-ES-A csEBCDICESA }
11121 { EBCDIC-ES-S csEBCDICESS }
11122 { EBCDIC-UK csEBCDICUK }
11123 { EBCDIC-US csEBCDICUS }
11124 { UNKNOWN-8BIT csUnknown8BiT }
11125 { MNEMONIC csMnemonic }
11127 { VISCII csVISCII }
11130 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11131 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11132 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11133 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11134 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11135 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11136 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11137 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11138 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11139 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11140 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11141 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11142 { IBM1047 IBM-1047 }
11143 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11144 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11145 { UNICODE-1-1 csUnicode11 }
11146 { CESU-8 csCESU-8 }
11147 { BOCU-1 csBOCU-1 }
11148 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11149 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11151 { ISO-8859-15 ISO_8859-15 Latin-9 }
11152 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11153 { GBK CP936 MS936 windows-936 }
11154 { JIS_Encoding csJISEncoding }
11155 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11156 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11158 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11159 { ISO-10646-UCS-Basic csUnicodeASCII }
11160 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11161 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11162 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11163 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11164 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11165 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11166 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11167 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11168 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11169 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11170 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11171 { Ventura-US csVenturaUS }
11172 { Ventura-International csVenturaInternational }
11173 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11174 { PC8-Turkish csPC8Turkish }
11175 { IBM-Symbols csIBMSymbols }
11176 { IBM-Thai csIBMThai }
11177 { HP-Legal csHPLegal }
11178 { HP-Pi-font csHPPiFont }
11179 { HP-Math8 csHPMath8 }
11180 { Adobe-Symbol-Encoding csHPPSMath }
11181 { HP-DeskTop csHPDesktop }
11182 { Ventura-Math csVenturaMath }
11183 { Microsoft-Publishing csMicrosoftPublishing }
11184 { Windows-31J csWindows31J }
11185 { GB2312 csGB2312 }
11189 proc tcl_encoding {enc} {
11190 global encoding_aliases tcl_encoding_cache
11191 if {[info exists tcl_encoding_cache($enc)]} {
11192 return $tcl_encoding_cache($enc)
11194 set names [encoding names]
11195 set lcnames [string tolower $names]
11196 set enc [string tolower $enc]
11197 set i [lsearch -exact $lcnames $enc]
11199 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11200 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11201 set i [lsearch -exact $lcnames $encx]
11205 foreach l $encoding_aliases {
11206 set ll [string tolower $l]
11207 if {[lsearch -exact $ll $enc] < 0} continue
11208 # look through the aliases for one that tcl knows about
11210 set i [lsearch -exact $lcnames $e]
11212 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11213 set i [lsearch -exact $lcnames $ex]
11223 set tclenc [lindex $names $i]
11225 set tcl_encoding_cache($enc) $tclenc
11229 proc gitattr {path attr default} {
11230 global path_attr_cache
11231 if {[info exists path_attr_cache($attr,$path)]} {
11232 set r $path_attr_cache($attr,$path)
11234 set r "unspecified"
11235 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11236 regexp "(.*): $attr: (.*)" $line m f r
11238 set path_attr_cache($attr,$path) $r
11240 if {$r eq "unspecified"} {
11246 proc cache_gitattr {attr pathlist} {
11247 global path_attr_cache
11249 foreach path $pathlist {
11250 if {![info exists path_attr_cache($attr,$path)]} {
11251 lappend newlist $path
11255 if {[tk windowingsystem] == "win32"} {
11256 # windows has a 32k limit on the arguments to a command...
11259 while {$newlist ne {}} {
11260 set head [lrange $newlist 0 [expr {$lim - 1}]]
11261 set newlist [lrange $newlist $lim end]
11262 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11263 foreach row [split $rlist "\n"] {
11264 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11265 if {[string index $path 0] eq "\""} {
11266 set path [encoding convertfrom [lindex $path 0]]
11268 set path_attr_cache($attr,$path) $value
11275 proc get_path_encoding {path} {
11276 global gui_encoding perfile_attrs
11277 set tcl_enc $gui_encoding
11278 if {$path ne {} && $perfile_attrs} {
11279 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11287 # First check that Tcl/Tk is recent enough
11288 if {[catch {package require Tk 8.4} err]} {
11289 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11290 Gitk requires at least Tcl/Tk 8.4." list
11295 set wrcomcmd "git diff-tree --stdin -p --pretty"
11299 set gitencoding [exec git config --get i18n.commitencoding]
11302 set gitencoding [exec git config --get i18n.logoutputencoding]
11304 if {$gitencoding == ""} {
11305 set gitencoding "utf-8"
11307 set tclencoding [tcl_encoding $gitencoding]
11308 if {$tclencoding == {}} {
11309 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11312 set gui_encoding [encoding system]
11314 set enc [exec git config --get gui.encoding]
11316 set tclenc [tcl_encoding $enc]
11317 if {$tclenc ne {}} {
11318 set gui_encoding $tclenc
11320 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11325 if {[tk windowingsystem] eq "aqua"} {
11326 set mainfont {{Lucida Grande} 9}
11327 set textfont {Monaco 9}
11328 set uifont {{Lucida Grande} 9 bold}
11330 set mainfont {Helvetica 9}
11331 set textfont {Courier 9}
11332 set uifont {Helvetica 9 bold}
11335 set findmergefiles 0
11343 set cmitmode "patch"
11344 set wrapcomment "none"
11349 set showlocalchanges 1
11351 set datetimeformat "%Y-%m-%d %H:%M:%S"
11353 set perfile_attrs 0
11356 if {[tk windowingsystem] eq "aqua"} {
11357 set extdifftool "opendiff"
11359 set extdifftool "meld"
11362 set colors {green red blue magenta darkgrey brown orange}
11363 if {[tk windowingsystem] eq "win32"} {
11364 set uicolor SystemButtonFace
11365 set bgcolor SystemWindow
11366 set fgcolor SystemButtonText
11367 set selectbgcolor SystemHighlight
11372 set selectbgcolor gray85
11374 set diffcolors {red "#00a000" blue}
11377 set markbgcolor "#e0e0ff"
11379 set circlecolors {white blue gray blue blue}
11381 # button for popping up context menus
11382 if {[tk windowingsystem] eq "aqua"} {
11383 set ctxbut <Button-2>
11385 set ctxbut <Button-3>
11388 ## For msgcat loading, first locate the installation location.
11389 if { [info exists ::env(GITK_MSGSDIR)] } {
11390 ## Msgsdir was manually set in the environment.
11391 set gitk_msgsdir $::env(GITK_MSGSDIR)
11393 ## Let's guess the prefix from argv0.
11394 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11395 set gitk_libdir [file join $gitk_prefix share gitk lib]
11396 set gitk_msgsdir [file join $gitk_libdir msgs]
11400 ## Internationalization (i18n) through msgcat and gettext. See
11401 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11402 package require msgcat
11403 namespace import ::msgcat::mc
11404 ## And eventually load the actual message catalog
11405 ::msgcat::mcload $gitk_msgsdir
11407 catch {source ~/.gitk}
11409 parsefont mainfont $mainfont
11410 eval font create mainfont [fontflags mainfont]
11411 eval font create mainfontbold [fontflags mainfont 1]
11413 parsefont textfont $textfont
11414 eval font create textfont [fontflags textfont]
11415 eval font create textfontbold [fontflags textfont 1]
11417 parsefont uifont $uifont
11418 eval font create uifont [fontflags uifont]
11424 # check that we can find a .git directory somewhere...
11425 if {[catch {set gitdir [gitdir]}]} {
11426 show_error {} . [mc "Cannot find a git repository here."]
11429 if {![file isdirectory $gitdir]} {
11430 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11435 set selectheadid {}
11438 set cmdline_files {}
11440 set revtreeargscmd {}
11441 foreach arg $argv {
11442 switch -glob -- $arg {
11445 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11448 "--select-commit=*" {
11449 set selecthead [string range $arg 16 end]
11452 set revtreeargscmd [string range $arg 10 end]
11455 lappend revtreeargs $arg
11461 if {$selecthead eq "HEAD"} {
11465 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11466 # no -- on command line, but some arguments (other than --argscmd)
11468 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11469 set cmdline_files [split $f "\n"]
11470 set n [llength $cmdline_files]
11471 set revtreeargs [lrange $revtreeargs 0 end-$n]
11472 # Unfortunately git rev-parse doesn't produce an error when
11473 # something is both a revision and a filename. To be consistent
11474 # with git log and git rev-list, check revtreeargs for filenames.
11475 foreach arg $revtreeargs {
11476 if {[file exists $arg]} {
11477 show_error {} . [mc "Ambiguous argument '%s': both revision\
11478 and filename" $arg]
11483 # unfortunately we get both stdout and stderr in $err,
11484 # so look for "fatal:".
11485 set i [string first "fatal:" $err]
11487 set err [string range $err [expr {$i + 6}] end]
11489 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11494 set nullid "0000000000000000000000000000000000000000"
11495 set nullid2 "0000000000000000000000000000000000000001"
11496 set nullfile "/dev/null"
11498 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11499 if {![info exists have_ttk]} {
11500 set have_ttk [llength [info commands ::ttk::style]]
11502 set use_ttk [expr {$have_ttk && $want_ttk}]
11503 set NS [expr {$use_ttk ? "ttk" : ""}]
11505 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11512 set highlight_paths {}
11514 set searchdirn -forwards
11517 set diffelide {0 0}
11518 set markingmatches 0
11519 set linkentercount 0
11520 set need_redisplay 0
11527 set selectedhlview [mc "None"]
11528 set highlight_related [mc "None"]
11529 set highlight_files {}
11530 set viewfiles(0) {}
11533 set viewargscmd(0) {}
11535 set selectedline {}
11543 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11547 image create photo gitlogo -width 16 -height 16
11549 image create photo gitlogominus -width 4 -height 2
11550 gitlogominus put #C00000 -to 0 0 4 2
11551 gitlogo copy gitlogominus -to 1 5
11552 gitlogo copy gitlogominus -to 6 5
11553 gitlogo copy gitlogominus -to 11 5
11554 image delete gitlogominus
11556 image create photo gitlogoplus -width 4 -height 4
11557 gitlogoplus put #008000 -to 1 0 3 4
11558 gitlogoplus put #008000 -to 0 1 4 3
11559 gitlogo copy gitlogoplus -to 1 9
11560 gitlogo copy gitlogoplus -to 6 9
11561 gitlogo copy gitlogoplus -to 11 9
11562 image delete gitlogoplus
11564 image create photo gitlogo32 -width 32 -height 32
11565 gitlogo32 copy gitlogo -zoom 2 2
11567 wm iconphoto . -default gitlogo gitlogo32
11569 # wait for the window to become visible
11570 tkwait visibility .
11571 wm title . "[file tail $argv0]: [file tail [pwd]]"
11575 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11576 # create a view for the files/dirs specified on the command line
11580 set viewname(1) [mc "Command line"]
11581 set viewfiles(1) $cmdline_files
11582 set viewargs(1) $revtreeargs
11583 set viewargscmd(1) $revtreeargscmd
11587 .bar.view entryconf [mca "Edit view..."] -state normal
11588 .bar.view entryconf [mca "Delete view"] -state normal
11591 if {[info exists permviews]} {
11592 foreach v $permviews {
11595 set viewname($n) [lindex $v 0]
11596 set viewfiles($n) [lindex $v 1]
11597 set viewargs($n) [lindex $v 2]
11598 set viewargscmd($n) [lindex $v 3]
11604 if {[tk windowingsystem] eq "win32"} {