2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright © 2005-2009 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
14 if {[info exists env
(GIT_DIR
)]} {
17 return [exec git rev-parse
--git-dir]
21 # A simple scheduler for compute-intensive stuff.
22 # The aim is to make sure that event handlers for GUI actions can
23 # run at least every 50-100 ms. Unfortunately fileevent handlers are
24 # run before X event handlers, so reading from a fast source can
25 # make the GUI completely unresponsive.
27 global isonrunq runq currunq
30 if {[info exists isonrunq
($script)]} return
31 if {$runq eq
{} && ![info exists currunq
]} {
34 lappend runq
[list
{} $script]
35 set isonrunq
($script) 1
38 proc filerun
{fd
script} {
39 fileevent
$fd readable
[list filereadable
$fd $script]
42 proc filereadable
{fd
script} {
45 fileevent
$fd readable
{}
46 if {$runq eq
{} && ![info exists currunq
]} {
49 lappend runq
[list
$fd $script]
55 for {set i
0} {$i < [llength
$runq]} {} {
56 if {[lindex
$runq $i 0] eq
$fd} {
57 set runq
[lreplace
$runq $i $i]
65 global isonrunq runq currunq
67 set tstart
[clock clicks
-milliseconds]
69 while {[llength
$runq] > 0} {
70 set fd
[lindex
$runq 0 0]
71 set script [lindex
$runq 0 1]
72 set currunq
[lindex
$runq 0]
73 set runq
[lrange
$runq 1 end
]
74 set repeat
[eval $script]
76 set t1
[clock clicks
-milliseconds]
77 set t
[expr {$t1 - $t0}]
78 if {$repeat ne
{} && $repeat} {
79 if {$fd eq
{} ||
$repeat == 2} {
80 # script returns 1 if it wants to be readded
81 # file readers return 2 if they could do more straight away
82 lappend runq
[list
$fd $script]
84 fileevent
$fd readable
[list filereadable
$fd $script]
86 } elseif
{$fd eq
{}} {
87 unset isonrunq
($script)
90 if {$t1 - $tstart >= 80} break
97 proc reg_instance
{fd
} {
98 global commfd leftover loginstance
100 set i
[incr loginstance
]
106 proc unmerged_files
{files
} {
109 # find the list of unmerged files
113 set fd
[open
"| git ls-files -u" r
]
115 show_error
{} .
"[mc "Couldn
't get list of unmerged files:"] $err"
118 while {[gets $fd line] >= 0} {
119 set i [string first "\t" $line]
121 set fname [string range $line [expr {$i+1}] end]
122 if {[lsearch -exact $mlist $fname] >= 0} continue
124 if {$files eq {} || [path_filter $files $fname]} {
132 proc parseviewargs {n arglist} {
133 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs
141 set origargs $arglist
145 foreach arg $arglist {
152 switch -glob -- $arg {
156 # remove from origargs in case we hit an unknown option
157 set origargs [lreplace $origargs $i $i]
161 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
162 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
163 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
164 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
165 "--ignore-space-change" - "-U*" - "--unified=*" {
166 # These request or affect diff output, which we don't want.
167 # Some could be used to set our defaults for diff display.
168 lappend diffargs
$arg
170 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
171 "--name-only" - "--name-status" - "--color" - "--color-words" -
172 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
173 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
174 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
175 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
176 "--objects" - "--objects-edge" - "--reverse" {
177 # These cause our parsing of git log's output to fail, or else
178 # they're options we want to set ourselves, so ignore them.
180 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
181 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
182 "--full-history" - "--dense" - "--sparse" -
183 "--follow" - "--left-right" - "--encoding=*" {
184 # These are harmless, and some are even useful
187 "--diff-filter=*" - "--no-merges" - "--unpacked" -
188 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
189 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
190 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
191 "--remove-empty" - "--first-parent" - "--cherry-pick" -
192 "-S*" - "--pickaxe-all" - "--pickaxe-regex" -
193 "--simplify-by-decoration" {
194 # These mean that we get a subset of the commits
199 # This appears to be the only one that has a value as a
200 # separate word following it
210 # git rev-parse doesn't understand --merge
211 lappend revargs
--gitk-symmetric-diff-marker MERGE_HEAD...HEAD
214 # Other flag arguments including -<n>
215 if {[string is digit
-strict [string range
$arg 1 end
]]} {
218 # a flag argument that we don't recognize;
219 # that means we can't optimize
225 # Non-flag arguments specify commits or ranges of commits
226 if {[string match
"*...*" $arg]} {
227 lappend revargs
--gitk-symmetric-diff-marker
233 set vdflags
($n) $diffargs
234 set vflags
($n) $glflags
235 set vrevs
($n) $revargs
236 set vfiltered
($n) $filtered
237 set vorigargs
($n) $origargs
241 proc parseviewrevs
{view revs
} {
242 global vposids vnegids
247 if {[catch
{set ids
[eval exec git rev-parse
$revs]} err
]} {
248 # we get stdout followed by stderr in $err
249 # for an unknown rev, git rev-parse echoes it and then errors out
250 set errlines
[split $err "\n"]
252 for {set l
0} {$l < [llength
$errlines]} {incr l
} {
253 set line
[lindex
$errlines $l]
254 if {!([string length
$line] == 40 && [string is xdigit
$line])} {
255 if {[string match
"fatal:*" $line]} {
256 if {[string match
"fatal: ambiguous argument*" $line]
258 if {[llength
$badrev] == 1} {
259 set err
"unknown revision $badrev"
261 set err
"unknown revisions: [join $badrev ", "]"
264 set err
[join [lrange
$errlines $l end
] "\n"]
271 error_popup
"[mc "Error parsing revisions
:"] $err"
278 foreach id
[split $ids "\n"] {
279 if {$id eq
"--gitk-symmetric-diff-marker"} {
281 } elseif
{[string match
"^*" $id]} {
288 lappend neg
[string range
$id 1 end
]
293 lset ret end
$id...
[lindex
$ret end
]
299 set vposids
($view) $pos
300 set vnegids
($view) $neg
304 # Start off a git log process and arrange to read its output
305 proc start_rev_list
{view
} {
306 global startmsecs commitidx viewcomplete curview
308 global viewargs viewargscmd viewfiles vfilelimit
309 global showlocalchanges
310 global viewactive viewinstances vmergeonly
311 global mainheadid viewmainheadid viewmainheadid_orig
312 global vcanopt vflags vrevs vorigargs
314 set startmsecs
[clock clicks
-milliseconds]
315 set commitidx
($view) 0
316 # these are set this way for the error exits
317 set viewcomplete
($view) 1
318 set viewactive
($view) 0
321 set args
$viewargs($view)
322 if {$viewargscmd($view) ne
{}} {
324 set str
[exec sh
-c $viewargscmd($view)]
326 error_popup
"[mc "Error executing
--argscmd command:"] $err"
329 set args
[concat
$args [split $str "\n"]]
331 set vcanopt
($view) [parseviewargs
$view $args]
333 set files
$viewfiles($view)
334 if {$vmergeonly($view)} {
335 set files
[unmerged_files
$files]
338 if {$nr_unmerged == 0} {
339 error_popup
[mc
"No files selected: --merge specified but\
340 no files are unmerged."]
342 error_popup
[mc
"No files selected: --merge specified but\
343 no unmerged files are within file limit."]
348 set vfilelimit
($view) $files
350 if {$vcanopt($view)} {
351 set revs
[parseviewrevs
$view $vrevs($view)]
355 set args
[concat
$vflags($view) $revs]
357 set args
$vorigargs($view)
361 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
362 --boundary $args "--" $files] r
]
364 error_popup
"[mc "Error executing git log
:"] $err"
367 set i
[reg_instance
$fd]
368 set viewinstances
($view) [list
$i]
369 set viewmainheadid
($view) $mainheadid
370 set viewmainheadid_orig
($view) $mainheadid
371 if {$files ne
{} && $mainheadid ne
{}} {
372 get_viewmainhead
$view
374 if {$showlocalchanges && $viewmainheadid($view) ne
{}} {
375 interestedin
$viewmainheadid($view) dodiffindex
377 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
378 if {$tclencoding != {}} {
379 fconfigure
$fd -encoding $tclencoding
381 filerun
$fd [list getcommitlines
$fd $i $view 0]
382 nowbusy
$view [mc
"Reading"]
383 set viewcomplete
($view) 0
384 set viewactive
($view) 1
388 proc stop_instance
{inst
} {
389 global commfd leftover
391 set fd
$commfd($inst)
395 if {$
::tcl_platform
(platform
) eq
{windows
}} {
404 unset leftover
($inst)
407 proc stop_backends
{} {
410 foreach inst
[array names commfd
] {
415 proc stop_rev_list
{view
} {
418 foreach inst
$viewinstances($view) {
421 set viewinstances
($view) {}
424 proc reset_pending_select
{selid
} {
425 global pending_select mainheadid selectheadid
428 set pending_select
$selid
429 } elseif
{$selectheadid ne
{}} {
430 set pending_select
$selectheadid
432 set pending_select
$mainheadid
436 proc getcommits
{selid
} {
437 global canv curview need_redisplay viewactive
440 if {[start_rev_list
$curview]} {
441 reset_pending_select
$selid
442 show_status
[mc
"Reading commits..."]
445 show_status
[mc
"No commits selected"]
449 proc updatecommits
{} {
450 global curview vcanopt vorigargs vfilelimit viewinstances
451 global viewactive viewcomplete tclencoding
452 global startmsecs showneartags showlocalchanges
453 global mainheadid viewmainheadid viewmainheadid_orig pending_select
455 global varcid vposids vnegids vflags vrevs
457 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
460 if {$mainheadid ne
$viewmainheadid_orig($view)} {
461 if {$showlocalchanges} {
464 set viewmainheadid
($view) $mainheadid
465 set viewmainheadid_orig
($view) $mainheadid
466 if {$vfilelimit($view) ne
{}} {
467 get_viewmainhead
$view
470 if {$showlocalchanges} {
473 if {$vcanopt($view)} {
474 set oldpos
$vposids($view)
475 set oldneg
$vnegids($view)
476 set revs
[parseviewrevs
$view $vrevs($view)]
480 # note: getting the delta when negative refs change is hard,
481 # and could require multiple git log invocations, so in that
482 # case we ask git log for all the commits (not just the delta)
483 if {$oldneg eq
$vnegids($view)} {
486 # take out positive refs that we asked for before or
487 # that we have already seen
489 if {[string length
$rev] == 40} {
490 if {[lsearch
-exact $oldpos $rev] < 0
491 && ![info exists varcid
($view,$rev)]} {
496 lappend
$newrevs $rev
499 if {$npos == 0} return
501 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
503 set args
[concat
$vflags($view) $revs --not $oldpos]
505 set args
$vorigargs($view)
508 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
509 --boundary $args "--" $vfilelimit($view)] r
]
511 error_popup
"[mc "Error executing git log
:"] $err"
514 if {$viewactive($view) == 0} {
515 set startmsecs
[clock clicks
-milliseconds]
517 set i
[reg_instance
$fd]
518 lappend viewinstances
($view) $i
519 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
520 if {$tclencoding != {}} {
521 fconfigure
$fd -encoding $tclencoding
523 filerun
$fd [list getcommitlines
$fd $i $view 1]
524 incr viewactive
($view)
525 set viewcomplete
($view) 0
526 reset_pending_select
{}
527 nowbusy
$view [mc
"Reading"]
533 proc reloadcommits
{} {
534 global curview viewcomplete selectedline currentid thickerline
535 global showneartags treediffs commitinterest cached_commitrow
539 if {$selectedline ne
{}} {
543 if {!$viewcomplete($curview)} {
544 stop_rev_list
$curview
548 catch
{unset currentid
}
549 catch
{unset thickerline
}
550 catch
{unset treediffs
}
557 catch
{unset commitinterest
}
558 catch
{unset cached_commitrow
}
559 catch
{unset targetid
}
565 # This makes a string representation of a positive integer which
566 # sorts as a string in numerical order
569 return [format
"%x" $n]
570 } elseif
{$n < 256} {
571 return [format
"x%.2x" $n]
572 } elseif
{$n < 65536} {
573 return [format
"y%.4x" $n]
575 return [format
"z%.8x" $n]
578 # Procedures used in reordering commits from git log (without
579 # --topo-order) into the order for display.
581 proc varcinit
{view
} {
582 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
583 global vtokmod varcmod vrowmod varcix vlastins
585 set varcstart
($view) {{}}
586 set vupptr
($view) {0}
587 set vdownptr
($view) {0}
588 set vleftptr
($view) {0}
589 set vbackptr
($view) {0}
590 set varctok
($view) {{}}
591 set varcrow
($view) {{}}
592 set vtokmod
($view) {}
595 set varcix
($view) {{}}
596 set vlastins
($view) {0}
599 proc resetvarcs
{view
} {
600 global varcid varccommits parents children vseedcount ordertok
602 foreach vid
[array names varcid
$view,*] {
607 # some commits might have children but haven't been seen yet
608 foreach vid
[array names children
$view,*] {
611 foreach va
[array names varccommits
$view,*] {
612 unset varccommits
($va)
614 foreach vd
[array names vseedcount
$view,*] {
615 unset vseedcount
($vd)
617 catch
{unset ordertok
}
620 # returns a list of the commits with no children
622 global vdownptr vleftptr varcstart
625 set a
[lindex
$vdownptr($v) 0]
627 lappend ret
[lindex
$varcstart($v) $a]
628 set a
[lindex
$vleftptr($v) $a]
633 proc newvarc
{view id
} {
634 global varcid varctok parents children vdatemode
635 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
636 global commitdata commitinfo vseedcount varccommits vlastins
638 set a
[llength
$varctok($view)]
640 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
641 if {![info exists commitinfo
($id)]} {
642 parsecommit
$id $commitdata($id) 1
644 set cdate
[lindex
$commitinfo($id) 4]
645 if {![string is integer
-strict $cdate]} {
648 if {![info exists vseedcount
($view,$cdate)]} {
649 set vseedcount
($view,$cdate) -1
651 set c
[incr vseedcount
($view,$cdate)]
652 set cdate
[expr {$cdate ^
0xffffffff}]
653 set tok
"s[strrep $cdate][strrep $c]"
658 if {[llength
$children($vid)] > 0} {
659 set kid
[lindex
$children($vid) end
]
660 set k
$varcid($view,$kid)
661 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
664 set tok
[lindex
$varctok($view) $k]
668 set i
[lsearch
-exact $parents($view,$ki) $id]
669 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
670 append tok
[strrep
$j]
672 set c
[lindex
$vlastins($view) $ka]
673 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
675 set b
[lindex
$vdownptr($view) $ka]
677 set b
[lindex
$vleftptr($view) $c]
679 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
681 set b
[lindex
$vleftptr($view) $c]
684 lset vdownptr
($view) $ka $a
685 lappend vbackptr
($view) 0
687 lset vleftptr
($view) $c $a
688 lappend vbackptr
($view) $c
690 lset vlastins
($view) $ka $a
691 lappend vupptr
($view) $ka
692 lappend vleftptr
($view) $b
694 lset vbackptr
($view) $b $a
696 lappend varctok
($view) $tok
697 lappend varcstart
($view) $id
698 lappend vdownptr
($view) 0
699 lappend varcrow
($view) {}
700 lappend varcix
($view) {}
701 set varccommits
($view,$a) {}
702 lappend vlastins
($view) 0
706 proc splitvarc
{p v
} {
707 global varcid varcstart varccommits varctok vtokmod
708 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
710 set oa
$varcid($v,$p)
711 set otok
[lindex
$varctok($v) $oa]
712 set ac
$varccommits($v,$oa)
713 set i
[lsearch
-exact $varccommits($v,$oa) $p]
715 set na
[llength
$varctok($v)]
716 # "%" sorts before "0"...
717 set tok
"$otok%[strrep $i]"
718 lappend varctok
($v) $tok
719 lappend varcrow
($v) {}
720 lappend varcix
($v) {}
721 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
722 set varccommits
($v,$na) [lrange
$ac $i end
]
723 lappend varcstart
($v) $p
724 foreach id
$varccommits($v,$na) {
725 set varcid
($v,$id) $na
727 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
728 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
729 lset vdownptr
($v) $oa $na
730 lset vlastins
($v) $oa 0
731 lappend vupptr
($v) $oa
732 lappend vleftptr
($v) 0
733 lappend vbackptr
($v) 0
734 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
735 lset vupptr
($v) $b $na
737 if {[string compare
$otok $vtokmod($v)] <= 0} {
742 proc renumbervarc
{a v
} {
743 global parents children varctok varcstart varccommits
744 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
746 set t1
[clock clicks
-milliseconds]
752 if {[info exists isrelated
($a)]} {
754 set id
[lindex
$varccommits($v,$a) end
]
755 foreach p
$parents($v,$id) {
756 if {[info exists varcid
($v,$p)]} {
757 set isrelated
($varcid($v,$p)) 1
762 set b
[lindex
$vdownptr($v) $a]
765 set b
[lindex
$vleftptr($v) $a]
767 set a
[lindex
$vupptr($v) $a]
773 if {![info exists kidchanged
($a)]} continue
774 set id
[lindex
$varcstart($v) $a]
775 if {[llength
$children($v,$id)] > 1} {
776 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
779 set oldtok
[lindex
$varctok($v) $a]
780 if {!$vdatemode($v)} {
786 set kid
[last_real_child
$v,$id]
788 set k
$varcid($v,$kid)
789 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
792 set tok
[lindex
$varctok($v) $k]
796 set i
[lsearch
-exact $parents($v,$ki) $id]
797 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
798 append tok
[strrep
$j]
800 if {$tok eq
$oldtok} {
803 set id
[lindex
$varccommits($v,$a) end
]
804 foreach p
$parents($v,$id) {
805 if {[info exists varcid
($v,$p)]} {
806 set kidchanged
($varcid($v,$p)) 1
811 lset varctok
($v) $a $tok
812 set b
[lindex
$vupptr($v) $a]
814 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
817 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
820 set c
[lindex
$vbackptr($v) $a]
821 set d
[lindex
$vleftptr($v) $a]
823 lset vdownptr
($v) $b $d
825 lset vleftptr
($v) $c $d
828 lset vbackptr
($v) $d $c
830 if {[lindex
$vlastins($v) $b] == $a} {
831 lset vlastins
($v) $b $c
833 lset vupptr
($v) $a $ka
834 set c
[lindex
$vlastins($v) $ka]
836 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
838 set b
[lindex
$vdownptr($v) $ka]
840 set b
[lindex
$vleftptr($v) $c]
843 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
845 set b
[lindex
$vleftptr($v) $c]
848 lset vdownptr
($v) $ka $a
849 lset vbackptr
($v) $a 0
851 lset vleftptr
($v) $c $a
852 lset vbackptr
($v) $a $c
854 lset vleftptr
($v) $a $b
856 lset vbackptr
($v) $b $a
858 lset vlastins
($v) $ka $a
861 foreach id
[array names sortkids
] {
862 if {[llength
$children($v,$id)] > 1} {
863 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
867 set t2
[clock clicks
-milliseconds]
868 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
871 # Fix up the graph after we have found out that in view $v,
872 # $p (a commit that we have already seen) is actually the parent
873 # of the last commit in arc $a.
874 proc fix_reversal
{p a v
} {
875 global varcid varcstart varctok vupptr
877 set pa
$varcid($v,$p)
878 if {$p ne
[lindex
$varcstart($v) $pa]} {
880 set pa
$varcid($v,$p)
882 # seeds always need to be renumbered
883 if {[lindex
$vupptr($v) $pa] == 0 ||
884 [string compare
[lindex
$varctok($v) $a] \
885 [lindex
$varctok($v) $pa]] > 0} {
890 proc insertrow
{id p v
} {
891 global cmitlisted children parents varcid varctok vtokmod
892 global varccommits ordertok commitidx numcommits curview
893 global targetid targetrow
897 set cmitlisted
($vid) 1
898 set children
($vid) {}
899 set parents
($vid) [list
$p]
900 set a
[newvarc
$v $id]
902 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
905 lappend varccommits
($v,$a) $id
907 if {[llength
[lappend children
($vp) $id]] > 1} {
908 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
909 catch
{unset ordertok
}
911 fix_reversal
$p $a $v
913 if {$v == $curview} {
914 set numcommits
$commitidx($v)
916 if {[info exists targetid
]} {
917 if {![comes_before
$targetid $p]} {
924 proc insertfakerow
{id p
} {
925 global varcid varccommits parents children cmitlisted
926 global commitidx varctok vtokmod targetid targetrow curview numcommits
930 set i
[lsearch
-exact $varccommits($v,$a) $p]
932 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
935 set children
($v,$id) {}
936 set parents
($v,$id) [list
$p]
937 set varcid
($v,$id) $a
938 lappend children
($v,$p) $id
939 set cmitlisted
($v,$id) 1
940 set numcommits
[incr commitidx
($v)]
941 # note we deliberately don't update varcstart($v) even if $i == 0
942 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
944 if {[info exists targetid
]} {
945 if {![comes_before
$targetid $p]} {
953 proc removefakerow
{id
} {
954 global varcid varccommits parents children commitidx
955 global varctok vtokmod cmitlisted currentid selectedline
956 global targetid curview numcommits
959 if {[llength
$parents($v,$id)] != 1} {
960 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
963 set p
[lindex
$parents($v,$id) 0]
964 set a
$varcid($v,$id)
965 set i
[lsearch
-exact $varccommits($v,$a) $id]
967 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
971 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
972 unset parents
($v,$id)
973 unset children
($v,$id)
974 unset cmitlisted
($v,$id)
975 set numcommits
[incr commitidx
($v) -1]
976 set j
[lsearch
-exact $children($v,$p) $id]
978 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
981 if {[info exist currentid
] && $id eq
$currentid} {
985 if {[info exists targetid
] && $targetid eq
$id} {
992 proc real_children
{vp
} {
993 global children nullid nullid2
996 foreach id
$children($vp) {
997 if {$id ne
$nullid && $id ne
$nullid2} {
1004 proc first_real_child
{vp
} {
1005 global children nullid nullid2
1007 foreach id
$children($vp) {
1008 if {$id ne
$nullid && $id ne
$nullid2} {
1015 proc last_real_child
{vp
} {
1016 global children nullid nullid2
1018 set kids
$children($vp)
1019 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
1020 set id
[lindex
$kids $i]
1021 if {$id ne
$nullid && $id ne
$nullid2} {
1028 proc vtokcmp
{v a b
} {
1029 global varctok varcid
1031 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1032 [lindex
$varctok($v) $varcid($v,$b)]]
1035 # This assumes that if lim is not given, the caller has checked that
1036 # arc a's token is less than $vtokmod($v)
1037 proc modify_arc
{v a
{lim
{}}} {
1038 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1041 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
1044 set r
[lindex
$varcrow($v) $a]
1045 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
1048 set vtokmod
($v) [lindex
$varctok($v) $a]
1050 if {$v == $curview} {
1051 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
1052 set a
[lindex
$vupptr($v) $a]
1058 set lim
[llength
$varccommits($v,$a)]
1060 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1067 proc update_arcrows
{v
} {
1068 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1069 global varcid vrownum varcorder varcix varccommits
1070 global vupptr vdownptr vleftptr varctok
1071 global displayorder parentlist curview cached_commitrow
1073 if {$vrowmod($v) == $commitidx($v)} return
1074 if {$v == $curview} {
1075 if {[llength
$displayorder] > $vrowmod($v)} {
1076 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1077 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1079 catch
{unset cached_commitrow
}
1081 set narctot
[expr {[llength
$varctok($v)] - 1}]
1083 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1084 # go up the tree until we find something that has a row number,
1085 # or we get to a seed
1086 set a
[lindex
$vupptr($v) $a]
1089 set a
[lindex
$vdownptr($v) 0]
1092 set varcorder
($v) [list
$a]
1093 lset varcix
($v) $a 0
1094 lset varcrow
($v) $a 0
1098 set arcn
[lindex
$varcix($v) $a]
1099 if {[llength
$vrownum($v)] > $arcn + 1} {
1100 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1101 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1103 set row
[lindex
$varcrow($v) $a]
1107 incr row
[llength
$varccommits($v,$a)]
1108 # go down if possible
1109 set b
[lindex
$vdownptr($v) $a]
1111 # if not, go left, or go up until we can go left
1113 set b
[lindex
$vleftptr($v) $a]
1115 set a
[lindex
$vupptr($v) $a]
1121 lappend vrownum
($v) $row
1122 lappend varcorder
($v) $a
1123 lset varcix
($v) $a $arcn
1124 lset varcrow
($v) $a $row
1126 set vtokmod
($v) [lindex
$varctok($v) $p]
1128 set vrowmod
($v) $row
1129 if {[info exists currentid
]} {
1130 set selectedline
[rowofcommit
$currentid]
1134 # Test whether view $v contains commit $id
1135 proc commitinview
{id v
} {
1138 return [info exists varcid
($v,$id)]
1141 # Return the row number for commit $id in the current view
1142 proc rowofcommit
{id
} {
1143 global varcid varccommits varcrow curview cached_commitrow
1144 global varctok vtokmod
1147 if {![info exists varcid
($v,$id)]} {
1148 puts
"oops rowofcommit no arc for [shortids $id]"
1151 set a
$varcid($v,$id)
1152 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1155 if {[info exists cached_commitrow
($id)]} {
1156 return $cached_commitrow($id)
1158 set i
[lsearch
-exact $varccommits($v,$a) $id]
1160 puts
"oops didn't find commit [shortids $id] in arc $a"
1163 incr i
[lindex
$varcrow($v) $a]
1164 set cached_commitrow
($id) $i
1168 # Returns 1 if a is on an earlier row than b, otherwise 0
1169 proc comes_before
{a b
} {
1170 global varcid varctok curview
1173 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1174 ![info exists varcid
($v,$b)]} {
1177 if {$varcid($v,$a) != $varcid($v,$b)} {
1178 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1179 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1181 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1184 proc bsearch
{l elt
} {
1185 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1190 while {$hi - $lo > 1} {
1191 set mid
[expr {int
(($lo + $hi) / 2)}]
1192 set t
[lindex
$l $mid]
1195 } elseif
{$elt > $t} {
1204 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1205 proc make_disporder
{start end
} {
1206 global vrownum curview commitidx displayorder parentlist
1207 global varccommits varcorder parents vrowmod varcrow
1208 global d_valid_start d_valid_end
1210 if {$end > $vrowmod($curview)} {
1211 update_arcrows
$curview
1213 set ai
[bsearch
$vrownum($curview) $start]
1214 set start
[lindex
$vrownum($curview) $ai]
1215 set narc
[llength
$vrownum($curview)]
1216 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1217 set a
[lindex
$varcorder($curview) $ai]
1218 set l
[llength
$displayorder]
1219 set al
[llength
$varccommits($curview,$a)]
1220 if {$l < $r + $al} {
1222 set pad
[ntimes
[expr {$r - $l}] {}]
1223 set displayorder
[concat
$displayorder $pad]
1224 set parentlist
[concat
$parentlist $pad]
1225 } elseif
{$l > $r} {
1226 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1227 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1229 foreach id
$varccommits($curview,$a) {
1230 lappend displayorder
$id
1231 lappend parentlist
$parents($curview,$id)
1233 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1235 foreach id
$varccommits($curview,$a) {
1236 lset displayorder
$i $id
1237 lset parentlist
$i $parents($curview,$id)
1245 proc commitonrow
{row
} {
1248 set id
[lindex
$displayorder $row]
1250 make_disporder
$row [expr {$row + 1}]
1251 set id
[lindex
$displayorder $row]
1256 proc closevarcs
{v
} {
1257 global varctok varccommits varcid parents children
1258 global cmitlisted commitidx vtokmod
1260 set missing_parents
0
1262 set narcs
[llength
$varctok($v)]
1263 for {set a
1} {$a < $narcs} {incr a
} {
1264 set id
[lindex
$varccommits($v,$a) end
]
1265 foreach p
$parents($v,$id) {
1266 if {[info exists varcid
($v,$p)]} continue
1267 # add p as a new commit
1268 incr missing_parents
1269 set cmitlisted
($v,$p) 0
1270 set parents
($v,$p) {}
1271 if {[llength
$children($v,$p)] == 1 &&
1272 [llength
$parents($v,$id)] == 1} {
1275 set b
[newvarc
$v $p]
1277 set varcid
($v,$p) $b
1278 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1281 lappend varccommits
($v,$b) $p
1283 set scripts
[check_interest
$p $scripts]
1286 if {$missing_parents > 0} {
1287 foreach s
$scripts {
1293 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1294 # Assumes we already have an arc for $rwid.
1295 proc rewrite_commit
{v id rwid
} {
1296 global children parents varcid varctok vtokmod varccommits
1298 foreach ch
$children($v,$id) {
1299 # make $rwid be $ch's parent in place of $id
1300 set i
[lsearch
-exact $parents($v,$ch) $id]
1302 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1304 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1305 # add $ch to $rwid's children and sort the list if necessary
1306 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1307 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1308 $children($v,$rwid)]
1310 # fix the graph after joining $id to $rwid
1311 set a
$varcid($v,$ch)
1312 fix_reversal
$rwid $a $v
1313 # parentlist is wrong for the last element of arc $a
1314 # even if displayorder is right, hence the 3rd arg here
1315 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1319 # Mechanism for registering a command to be executed when we come
1320 # across a particular commit. To handle the case when only the
1321 # prefix of the commit is known, the commitinterest array is now
1322 # indexed by the first 4 characters of the ID. Each element is a
1323 # list of id, cmd pairs.
1324 proc interestedin
{id cmd
} {
1325 global commitinterest
1327 lappend commitinterest
([string range
$id 0 3]) $id $cmd
1330 proc check_interest
{id scripts
} {
1331 global commitinterest
1333 set prefix
[string range
$id 0 3]
1334 if {[info exists commitinterest
($prefix)]} {
1336 foreach
{i
script} $commitinterest($prefix) {
1337 if {[string match
"$i*" $id]} {
1338 lappend scripts
[string map
[list
"%I" $id "%P" $i] $script]
1340 lappend newlist
$i $script
1343 if {$newlist ne
{}} {
1344 set commitinterest
($prefix) $newlist
1346 unset commitinterest
($prefix)
1352 proc getcommitlines
{fd inst view updating
} {
1353 global cmitlisted leftover
1354 global commitidx commitdata vdatemode
1355 global parents children curview hlview
1356 global idpending ordertok
1357 global varccommits varcid varctok vtokmod vfilelimit
1359 set stuff
[read $fd 500000]
1360 # git log doesn't terminate the last commit with a null...
1361 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1368 global commfd viewcomplete viewactive viewname
1369 global viewinstances
1371 set i
[lsearch
-exact $viewinstances($view) $inst]
1373 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1375 # set it blocking so we wait for the process to terminate
1376 fconfigure
$fd -blocking 1
1377 if {[catch
{close
$fd} err
]} {
1379 if {$view != $curview} {
1380 set fv
" for the \"$viewname($view)\" view"
1382 if {[string range
$err 0 4] == "usage"} {
1383 set err
"Gitk: error reading commits$fv:\
1384 bad arguments to git log."
1385 if {$viewname($view) eq
"Command line"} {
1387 " (Note: arguments to gitk are passed to git log\
1388 to allow selection of commits to be displayed.)"
1391 set err
"Error reading commits$fv: $err"
1395 if {[incr viewactive
($view) -1] <= 0} {
1396 set viewcomplete
($view) 1
1397 # Check if we have seen any ids listed as parents that haven't
1398 # appeared in the list
1402 if {$view == $curview} {
1411 set i
[string first
"\0" $stuff $start]
1413 append leftover
($inst) [string range
$stuff $start end
]
1417 set cmit
$leftover($inst)
1418 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1419 set leftover
($inst) {}
1421 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1423 set start
[expr {$i + 1}]
1424 set j
[string first
"\n" $cmit]
1427 if {$j >= 0 && [string match
"commit *" $cmit]} {
1428 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1429 if {[string match
{[-^
<>]*} $ids]} {
1430 switch
-- [string index
$ids 0] {
1436 set ids
[string range
$ids 1 end
]
1440 if {[string length
$id] != 40} {
1448 if {[string length
$shortcmit] > 80} {
1449 set shortcmit
"[string range $shortcmit 0 80]..."
1451 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1454 set id [lindex $ids 0]
1457 if {!$listed && $updating && ![info exists varcid($vid)] &&
1458 $vfilelimit($view) ne {}} {
1459 # git log doesn't rewrite parents
for unlisted commits
1460 # when doing path limiting, so work around that here
1461 # by working out the rewritten parent with git rev-list
1462 # and if we already know about it, using the rewritten
1463 # parent as a substitute parent for $id's children.
1465 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1466 $id -- $vfilelimit($view)]
1468 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1469 # use $rwid in place of $id
1470 rewrite_commit
$view $id $rwid
1477 if {[info exists varcid
($vid)]} {
1478 if {$cmitlisted($vid) ||
!$listed} continue
1482 set olds
[lrange
$ids 1 end
]
1486 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1487 set cmitlisted
($vid) $listed
1488 set parents
($vid) $olds
1489 if {![info exists children
($vid)]} {
1490 set children
($vid) {}
1491 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1492 set k
[lindex
$children($vid) 0]
1493 if {[llength
$parents($view,$k)] == 1 &&
1494 (!$vdatemode($view) ||
1495 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1496 set a
$varcid($view,$k)
1501 set a
[newvarc
$view $id]
1503 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1506 if {![info exists varcid
($vid)]} {
1508 lappend varccommits
($view,$a) $id
1509 incr commitidx
($view)
1514 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1516 if {[llength
[lappend children
($vp) $id]] > 1 &&
1517 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1518 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1520 catch
{unset ordertok
}
1522 if {[info exists varcid
($view,$p)]} {
1523 fix_reversal
$p $a $view
1529 set scripts
[check_interest
$id $scripts]
1533 global numcommits hlview
1535 if {$view == $curview} {
1536 set numcommits
$commitidx($view)
1539 if {[info exists hlview
] && $view == $hlview} {
1540 # we never actually get here...
1543 foreach s
$scripts {
1550 proc chewcommits
{} {
1551 global curview hlview viewcomplete
1552 global pending_select
1555 if {$viewcomplete($curview)} {
1556 global commitidx varctok
1557 global numcommits startmsecs
1559 if {[info exists pending_select
]} {
1561 reset_pending_select
{}
1563 if {[commitinview
$pending_select $curview]} {
1564 selectline
[rowofcommit
$pending_select] 1
1566 set row
[first_real_row
]
1570 if {$commitidx($curview) > 0} {
1571 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1572 #puts "overall $ms ms for $numcommits commits"
1573 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1575 show_status
[mc
"No commits selected"]
1582 proc do_readcommit
{id
} {
1585 # Invoke git-log to handle automatic encoding conversion
1586 set fd
[open
[concat | git log
--no-color --pretty=raw
-1 $id] r
]
1587 # Read the results using i18n.logoutputencoding
1588 fconfigure
$fd -translation lf
-eofchar {}
1589 if {$tclencoding != {}} {
1590 fconfigure
$fd -encoding $tclencoding
1592 set contents
[read $fd]
1594 # Remove the heading line
1595 regsub
{^commit
[0-9a-f]+\n} $contents {} contents
1600 proc readcommit
{id
} {
1601 if {[catch
{set contents
[do_readcommit
$id]}]} return
1602 parsecommit
$id $contents 1
1605 proc parsecommit
{id contents listed
} {
1606 global commitinfo cdate
1615 set hdrend
[string first
"\n\n" $contents]
1617 # should never happen...
1618 set hdrend
[string length
$contents]
1620 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1621 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1622 foreach line
[split $header "\n"] {
1623 set line
[split $line " "]
1624 set tag
[lindex
$line 0]
1625 if {$tag == "author"} {
1626 set audate
[lindex
$line end-1
]
1627 set auname
[join [lrange
$line 1 end-2
] " "]
1628 } elseif
{$tag == "committer"} {
1629 set comdate
[lindex
$line end-1
]
1630 set comname
[join [lrange
$line 1 end-2
] " "]
1634 # take the first non-blank line of the comment as the headline
1635 set headline
[string trimleft
$comment]
1636 set i
[string first
"\n" $headline]
1638 set headline
[string range
$headline 0 $i]
1640 set headline
[string trimright
$headline]
1641 set i
[string first
"\r" $headline]
1643 set headline
[string trimright
[string range
$headline 0 $i]]
1646 # git log indents the comment by 4 spaces;
1647 # if we got this via git cat-file, add the indentation
1649 foreach line
[split $comment "\n"] {
1650 append newcomment
" "
1651 append newcomment
$line
1652 append newcomment
"\n"
1654 set comment
$newcomment
1656 if {$comdate != {}} {
1657 set cdate
($id) $comdate
1659 set commitinfo
($id) [list
$headline $auname $audate \
1660 $comname $comdate $comment]
1663 proc getcommit
{id
} {
1664 global commitdata commitinfo
1666 if {[info exists commitdata
($id)]} {
1667 parsecommit
$id $commitdata($id) 1
1670 if {![info exists commitinfo
($id)]} {
1671 set commitinfo
($id) [list
[mc
"No commit information available"]]
1677 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1678 # and are present in the current view.
1679 # This is fairly slow...
1680 proc longid
{prefix
} {
1681 global varcid curview
1684 foreach match
[array names varcid
"$curview,$prefix*"] {
1685 lappend ids
[lindex
[split $match ","] 1]
1691 global tagids idtags headids idheads tagobjid
1692 global otherrefids idotherrefs mainhead mainheadid
1693 global selecthead selectheadid
1696 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1699 set refd
[open
[list | git show-ref
-d] r
]
1700 while {[gets
$refd line
] >= 0} {
1701 if {[string index
$line 40] ne
" "} continue
1702 set id
[string range
$line 0 39]
1703 set ref
[string range
$line 41 end
]
1704 if {![string match
"refs/*" $ref]} continue
1705 set name
[string range
$ref 5 end
]
1706 if {[string match
"remotes/*" $name]} {
1707 if {![string match
"*/HEAD" $name] && !$hideremotes} {
1708 set headids
($name) $id
1709 lappend idheads
($id) $name
1711 } elseif
{[string match
"heads/*" $name]} {
1712 set name
[string range
$name 6 end
]
1713 set headids
($name) $id
1714 lappend idheads
($id) $name
1715 } elseif
{[string match
"tags/*" $name]} {
1716 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1717 # which is what we want since the former is the commit ID
1718 set name
[string range
$name 5 end
]
1719 if {[string match
"*^{}" $name]} {
1720 set name
[string range
$name 0 end-3
]
1722 set tagobjid
($name) $id
1724 set tagids
($name) $id
1725 lappend idtags
($id) $name
1727 set otherrefids
($name) $id
1728 lappend idotherrefs
($id) $name
1735 set mainheadid
[exec git rev-parse HEAD
]
1736 set thehead
[exec git symbolic-ref HEAD
]
1737 if {[string match
"refs/heads/*" $thehead]} {
1738 set mainhead
[string range
$thehead 11 end
]
1742 if {$selecthead ne
{}} {
1744 set selectheadid
[exec git rev-parse
--verify $selecthead]
1749 # skip over fake commits
1750 proc first_real_row
{} {
1751 global nullid nullid2 numcommits
1753 for {set row
0} {$row < $numcommits} {incr row
} {
1754 set id
[commitonrow
$row]
1755 if {$id ne
$nullid && $id ne
$nullid2} {
1762 # update things for a head moved to a child of its previous location
1763 proc movehead
{id name
} {
1764 global headids idheads
1766 removehead
$headids($name) $name
1767 set headids
($name) $id
1768 lappend idheads
($id) $name
1771 # update things when a head has been removed
1772 proc removehead
{id name
} {
1773 global headids idheads
1775 if {$idheads($id) eq
$name} {
1778 set i
[lsearch
-exact $idheads($id) $name]
1780 set idheads
($id) [lreplace
$idheads($id) $i $i]
1783 unset headids
($name)
1786 proc ttk_toplevel
{w args
} {
1788 eval [linsert
$args 0 ::toplevel
$w]
1790 place
[ttk
::frame
$w._toplevel_background
] -x 0 -y 0 -relwidth 1 -relheight 1
1795 proc make_transient
{window origin
} {
1798 # In MacOS Tk 8.4 transient appears to work by setting
1799 # overrideredirect, which is utterly useless, since the
1800 # windows get no border, and are not even kept above
1802 if {!$have_tk85 && [tk windowingsystem
] eq
{aqua
}} return
1804 wm transient
$window $origin
1806 # Windows fails to place transient windows normally, so
1807 # schedule a callback to center them on the parent.
1808 if {[tk windowingsystem
] eq
{win32
}} {
1809 after idle
[list tk
::PlaceWindow
$window widget
$origin]
1813 proc show_error
{w top msg
} {
1815 if {![info exists NS
]} {set NS
""}
1816 if {[wm state
$top] eq
"withdrawn"} { wm deiconify
$top }
1817 message
$w.m
-text $msg -justify center
-aspect 400
1818 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1819 ${NS}::button
$w.ok
-default active
-text [mc OK
] -command "destroy $top"
1820 pack
$w.ok
-side bottom
-fill x
1821 bind $top <Visibility
> "grab $top; focus $top"
1822 bind $top <Key-Return
> "destroy $top"
1823 bind $top <Key-space
> "destroy $top"
1824 bind $top <Key-Escape
> "destroy $top"
1828 proc error_popup
{msg
{owner .
}} {
1829 if {[tk windowingsystem
] eq
"win32"} {
1830 tk_messageBox
-icon error
-type ok
-title [wm title .
] \
1831 -parent $owner -message $msg
1835 make_transient
$w $owner
1836 show_error
$w $w $msg
1840 proc confirm_popup
{msg
{owner .
}} {
1841 global confirm_ok NS
1845 make_transient
$w $owner
1846 message
$w.m
-text $msg -justify center
-aspect 400
1847 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1848 ${NS}::button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1849 pack
$w.ok
-side left
-fill x
1850 ${NS}::button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1851 pack
$w.cancel
-side right
-fill x
1852 bind $w <Visibility
> "grab $w; focus $w"
1853 bind $w <Key-Return
> "set confirm_ok 1; destroy $w"
1854 bind $w <Key-space
> "set confirm_ok 1; destroy $w"
1855 bind $w <Key-Escape
> "destroy $w"
1856 tk
::PlaceWindow
$w widget
$owner
1861 proc setoptions
{} {
1862 if {[tk windowingsystem
] ne
"win32"} {
1863 option add
*Panedwindow.showHandle
1 startupFile
1864 option add
*Panedwindow.sashRelief raised startupFile
1865 if {[tk windowingsystem
] ne
"aqua"} {
1866 option add
*Menu.font uifont startupFile
1869 option add
*Menu.TearOff
0 startupFile
1871 option add
*Button.font uifont startupFile
1872 option add
*Checkbutton.font uifont startupFile
1873 option add
*Radiobutton.font uifont startupFile
1874 option add
*Menubutton.font uifont startupFile
1875 option add
*Label.font uifont startupFile
1876 option add
*Message.font uifont startupFile
1877 option add
*Entry.font uifont startupFile
1878 option add
*Labelframe.font uifont startupFile
1881 # Make a menu and submenus.
1882 # m is the window name for the menu, items is the list of menu items to add.
1883 # Each item is a list {mc label type description options...}
1884 # mc is ignored; it's so we can put mc there to alert xgettext
1885 # label is the string that appears in the menu
1886 # type is cascade, command or radiobutton (should add checkbutton)
1887 # description depends on type; it's the sublist for cascade, the
1888 # command to invoke for command, or {variable value} for radiobutton
1889 proc makemenu
{m items
} {
1891 if {[tk windowingsystem
] eq
{aqua
}} {
1897 set name
[mc
[lindex
$i 1]]
1898 set type [lindex
$i 2]
1899 set thing
[lindex
$i 3]
1900 set params
[list
$type]
1902 set u
[string first
"&" [string map
{&& x
} $name]]
1903 lappend params
-label [string map
{&& & & {}} $name]
1905 lappend params
-underline $u
1910 set submenu
[string tolower
[string map
{& ""} [lindex
$i 1]]]
1911 lappend params
-menu $m.
$submenu
1914 lappend params
-command $thing
1917 lappend params
-variable [lindex
$thing 0] \
1918 -value [lindex
$thing 1]
1921 set tail [lrange
$i 4 end
]
1922 regsub
-all {\yMeta1\y
} $tail $Meta1 tail
1923 eval $m add
$params $tail
1924 if {$type eq
"cascade"} {
1925 makemenu
$m.
$submenu $thing
1930 # translate string and remove ampersands
1932 return [string map
{&& & & {}} [mc
$str]]
1935 proc makedroplist
{w varname args
} {
1939 foreach label
$args {
1940 set cx
[string length
$label]
1941 if {$cx > $width} {set width
$cx}
1943 set gm
[ttk
::combobox
$w -width $width -state readonly\
1944 -textvariable $varname -values $args]
1946 set gm
[eval [linsert
$args 0 tk_optionMenu
$w $varname]]
1951 proc makewindow
{} {
1952 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1954 global findtype findtypemenu findloc findstring fstring geometry
1955 global entries sha1entry sha1string sha1but
1956 global diffcontextstring diffcontext
1958 global maincursor textcursor curtextcursor
1959 global rowctxmenu fakerowmenu mergemax wrapcomment
1960 global highlight_files gdttype
1961 global searchstring sstring
1962 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1963 global headctxmenu progresscanv progressitem progresscoords statusw
1964 global fprogitem fprogcoord lastprogupdate progupdatepending
1965 global rprogitem rprogcoord rownumsel numcommits
1966 global have_tk85 use_ttk NS
1968 # The "mc" arguments here are purely so that xgettext
1969 # sees the following string as needing to be translated
1972 {mc
"Update" command updatecommits
-accelerator F5
}
1973 {mc
"Reload" command reloadcommits
-accelerator Meta1-F5
}
1974 {mc
"Reread references" command rereadrefs
}
1975 {mc
"List references" command showrefs
-accelerator F2
}
1977 {mc
"Start git gui" command {exec git gui
&}}
1979 {mc
"Quit" command doquit
-accelerator Meta1-Q
}
1983 {mc
"Preferences" command doprefs
}
1987 {mc
"New view..." command {newview
0} -accelerator Shift-F4
}
1988 {mc
"Edit view..." command editview
-state disabled
-accelerator F4
}
1989 {mc
"Delete view" command delview
-state disabled
}
1991 {mc
"All files" radiobutton
{selectedview
0} -command {showview
0}}
1993 if {[tk windowingsystem
] ne
"aqua"} {
1996 {mc
"About gitk" command about
}
1997 {mc
"Key bindings" command keys
}
1999 set bar
[list
$file $edit $view $help]
2001 proc
::tk
::mac
::ShowPreferences
{} {doprefs
}
2002 proc
::tk
::mac
::Quit
{} {doquit
}
2003 lset
file end
[lreplace
[lindex
$file end
] end-1 end
]
2005 xx
"Apple" cascade
{
2006 {mc
"About gitk" command about
}
2011 {mc
"Key bindings" command keys
}
2013 set bar
[list
$apple $file $view $help]
2016 . configure
-menu .bar
2019 # cover the non-themed toplevel with a themed frame.
2020 place
[ttk
::frame ._main_background
] -x 0 -y 0 -relwidth 1 -relheight 1
2023 # the gui has upper and lower half, parts of a paned window.
2024 ${NS}::panedwindow .ctop
-orient vertical
2026 # possibly use assumed geometry
2027 if {![info exists geometry
(pwsash0
)]} {
2028 set geometry
(topheight
) [expr {15 * $linespc}]
2029 set geometry
(topwidth
) [expr {80 * $charspc}]
2030 set geometry
(botheight
) [expr {15 * $linespc}]
2031 set geometry
(botwidth
) [expr {50 * $charspc}]
2032 set geometry
(pwsash0
) [list
[expr {40 * $charspc}] 2]
2033 set geometry
(pwsash1
) [list
[expr {60 * $charspc}] 2]
2036 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2037 ${NS}::frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
2038 ${NS}::frame .tf.histframe
2039 ${NS}::panedwindow .tf.histframe.pwclist
-orient horizontal
2041 .tf.histframe.pwclist configure
-sashpad 0 -handlesize 4
2044 # create three canvases
2045 set cscroll .tf.histframe.csb
2046 set canv .tf.histframe.pwclist.canv
2048 -selectbackground $selectbgcolor \
2049 -background $bgcolor -bd 0 \
2050 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2051 .tf.histframe.pwclist add
$canv
2052 set canv2 .tf.histframe.pwclist.canv2
2054 -selectbackground $selectbgcolor \
2055 -background $bgcolor -bd 0 -yscrollincr $linespc
2056 .tf.histframe.pwclist add
$canv2
2057 set canv3 .tf.histframe.pwclist.canv3
2059 -selectbackground $selectbgcolor \
2060 -background $bgcolor -bd 0 -yscrollincr $linespc
2061 .tf.histframe.pwclist add
$canv3
2063 bind .tf.histframe.pwclist
<Map
> {
2065 .tf.histframe.pwclist sashpos
1 [lindex $
::geometry
(pwsash1
) 0]
2066 .tf.histframe.pwclist sashpos
0 [lindex $
::geometry
(pwsash0
) 0]
2069 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
2070 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
2073 # a scroll bar to rule them
2074 ${NS}::scrollbar
$cscroll -command {allcanvs yview
}
2075 if {!$use_ttk} {$cscroll configure
-highlightthickness 0}
2076 pack
$cscroll -side right
-fill y
2077 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
2078 lappend bglist
$canv $canv2 $canv3
2079 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
2081 # we have two button bars at bottom of top frame. Bar 1
2082 ${NS}::frame .tf.bar
2083 ${NS}::frame .tf.lbar
-height 15
2085 set sha1entry .tf.bar.sha1
2086 set entries
$sha1entry
2087 set sha1but .tf.bar.sha1label
2088 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
2089 -command gotocommit
-width 8
2090 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
2091 pack .tf.bar.sha1label
-side left
2092 ${NS}::entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
2093 trace add variable sha1string
write sha1change
2094 pack
$sha1entry -side left
-pady 2
2096 image create bitmap bm-left
-data {
2097 #define left_width 16
2098 #define left_height 16
2099 static unsigned char left_bits
[] = {
2100 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2101 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2102 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2104 image create bitmap bm-right
-data {
2105 #define right_width 16
2106 #define right_height 16
2107 static unsigned char right_bits
[] = {
2108 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2109 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2110 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2112 ${NS}::button .tf.bar.leftbut
-image bm-left
-command goback \
2113 -state disabled
-width 26
2114 pack .tf.bar.leftbut
-side left
-fill y
2115 ${NS}::button .tf.bar.rightbut
-image bm-right
-command goforw \
2116 -state disabled
-width 26
2117 pack .tf.bar.rightbut
-side left
-fill y
2119 ${NS}::label .tf.bar.rowlabel
-text [mc
"Row"]
2121 ${NS}::label .tf.bar.rownum
-width 7 -textvariable rownumsel \
2122 -relief sunken
-anchor e
2123 ${NS}::label .tf.bar.rowlabel2
-text "/"
2124 ${NS}::label .tf.bar.numcommits
-width 7 -textvariable numcommits \
2125 -relief sunken
-anchor e
2126 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2129 foreach w
{rownum numcommits
} {.tf.bar.
$w configure
-font textfont
}
2132 trace add variable selectedline
write selectedline_change
2134 # Status label and progress bar
2135 set statusw .tf.bar.status
2136 ${NS}::label
$statusw -width 15 -relief sunken
2137 pack
$statusw -side left
-padx 5
2139 set progresscanv
[ttk
::progressbar .tf.bar.progress
]
2141 set h
[expr {[font metrics uifont
-linespace] + 2}]
2142 set progresscanv .tf.bar.progress
2143 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
2144 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
2145 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
2146 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
2148 pack
$progresscanv -side right
-expand 1 -fill x
-padx {0 2}
2149 set progresscoords
{0 0}
2152 bind $progresscanv <Configure
> adjustprogress
2153 set lastprogupdate
[clock clicks
-milliseconds]
2154 set progupdatepending
0
2156 # build up the bottom bar of upper window
2157 ${NS}::label .tf.lbar.flabel
-text "[mc "Find
"] "
2158 ${NS}::button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
2159 ${NS}::button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
2160 ${NS}::label .tf.lbar.flab2
-text " [mc "commit
"] "
2161 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2163 set gdttype
[mc
"containing:"]
2164 set gm
[makedroplist .tf.lbar.gdttype gdttype \
2165 [mc
"containing:"] \
2166 [mc
"touching paths:"] \
2167 [mc
"adding/removing string:"]]
2168 trace add variable gdttype
write gdttype_change
2169 pack .tf.lbar.gdttype
-side left
-fill y
2172 set fstring .tf.lbar.findstring
2173 lappend entries
$fstring
2174 ${NS}::entry
$fstring -width 30 -font textfont
-textvariable findstring
2175 trace add variable findstring
write find_change
2176 set findtype
[mc
"Exact"]
2177 set findtypemenu
[makedroplist .tf.lbar.findtype \
2178 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
2179 trace add variable findtype
write findcom_change
2180 set findloc
[mc
"All fields"]
2181 makedroplist .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
2182 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
2183 trace add variable findloc
write find_change
2184 pack .tf.lbar.findloc
-side right
2185 pack .tf.lbar.findtype
-side right
2186 pack
$fstring -side left
-expand 1 -fill x
2188 # Finish putting the upper half of the viewer together
2189 pack .tf.lbar
-in .tf
-side bottom
-fill x
2190 pack .tf.bar
-in .tf
-side bottom
-fill x
2191 pack .tf.histframe
-fill both
-side top
-expand 1
2194 .ctop paneconfigure .tf
-height $geometry(topheight
)
2195 .ctop paneconfigure .tf
-width $geometry(topwidth
)
2198 # now build up the bottom
2199 ${NS}::panedwindow .pwbottom
-orient horizontal
2201 # lower left, a text box over search bar, scroll bar to the right
2202 # if we know window height, then that will set the lower text height, otherwise
2203 # we set lower text height which will drive window height
2204 if {[info exists geometry
(main
)]} {
2205 ${NS}::frame .bleft
-width $geometry(botwidth
)
2207 ${NS}::frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
2209 ${NS}::frame .bleft.top
2210 ${NS}::frame .bleft.mid
2211 ${NS}::frame .bleft.bottom
2213 ${NS}::button .bleft.top.search
-text [mc
"Search"] -command dosearch
2214 pack .bleft.top.search
-side left
-padx 5
2215 set sstring .bleft.top.sstring
2217 ${NS}::entry
$sstring -width 20 -font textfont
-textvariable searchstring
2218 lappend entries
$sstring
2219 trace add variable searchstring
write incrsearch
2220 pack
$sstring -side left
-expand 1 -fill x
2221 ${NS}::radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
2222 -command changediffdisp
-variable diffelide
-value {0 0}
2223 ${NS}::radiobutton .bleft.mid.old
-text [mc
"Old version"] \
2224 -command changediffdisp
-variable diffelide
-value {0 1}
2225 ${NS}::radiobutton .bleft.mid.new
-text [mc
"New version"] \
2226 -command changediffdisp
-variable diffelide
-value {1 0}
2227 ${NS}::label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
2228 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
2229 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
2230 -from 0 -increment 1 -to 10000000 \
2231 -validate all
-validatecommand "diffcontextvalidate %P" \
2232 -textvariable diffcontextstring
2233 .bleft.mid.diffcontext
set $diffcontext
2234 trace add variable diffcontextstring
write diffcontextchange
2235 lappend entries .bleft.mid.diffcontext
2236 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
2237 ${NS}::checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
2238 -command changeignorespace
-variable ignorespace
2239 pack .bleft.mid.ignspace
-side left
-padx 5
2240 set ctext .bleft.bottom.ctext
2241 text
$ctext -background $bgcolor -foreground $fgcolor \
2242 -state disabled
-font textfont \
2243 -yscrollcommand scrolltext
-wrap none \
2244 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2246 $ctext conf
-tabstyle wordprocessor
2248 ${NS}::scrollbar .bleft.bottom.sb
-command "$ctext yview"
2249 ${NS}::scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h
2250 pack .bleft.top
-side top
-fill x
2251 pack .bleft.mid
-side top
-fill x
2252 grid
$ctext .bleft.bottom.sb
-sticky nsew
2253 grid .bleft.bottom.sbhorizontal
-sticky ew
2254 grid columnconfigure .bleft.bottom
0 -weight 1
2255 grid rowconfigure .bleft.bottom
0 -weight 1
2256 grid rowconfigure .bleft.bottom
1 -weight 0
2257 pack .bleft.bottom
-side top
-fill both
-expand 1
2258 lappend bglist
$ctext
2259 lappend fglist
$ctext
2261 $ctext tag conf comment
-wrap $wrapcomment
2262 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
2263 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
2264 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
2265 $ctext tag conf dresult
-fore [lindex
$diffcolors 1]
2266 $ctext tag conf m0
-fore red
2267 $ctext tag conf m1
-fore blue
2268 $ctext tag conf m2
-fore green
2269 $ctext tag conf m3
-fore purple
2270 $ctext tag conf
m4 -fore brown
2271 $ctext tag conf m5
-fore "#009090"
2272 $ctext tag conf m6
-fore magenta
2273 $ctext tag conf m7
-fore "#808000"
2274 $ctext tag conf m8
-fore "#009000"
2275 $ctext tag conf m9
-fore "#ff0080"
2276 $ctext tag conf m10
-fore cyan
2277 $ctext tag conf m11
-fore "#b07070"
2278 $ctext tag conf m12
-fore "#70b0f0"
2279 $ctext tag conf m13
-fore "#70f0b0"
2280 $ctext tag conf m14
-fore "#f0b070"
2281 $ctext tag conf m15
-fore "#ff70b0"
2282 $ctext tag conf mmax
-fore darkgrey
2284 $ctext tag conf mresult
-font textfontbold
2285 $ctext tag conf msep
-font textfontbold
2286 $ctext tag conf found
-back yellow
2288 .pwbottom add .bleft
2290 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2294 ${NS}::frame .bright
2295 ${NS}::frame .bright.mode
2296 ${NS}::radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2297 -command reselectline
-variable cmitmode
-value "patch"
2298 ${NS}::radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2299 -command reselectline
-variable cmitmode
-value "tree"
2300 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2301 pack .bright.mode
-side top
-fill x
2302 set cflist .bright.cfiles
2303 set indent
[font measure mainfont
"nn"]
2305 -selectbackground $selectbgcolor \
2306 -background $bgcolor -foreground $fgcolor \
2308 -tabs [list
$indent [expr {2 * $indent}]] \
2309 -yscrollcommand ".bright.sb set" \
2310 -cursor [. cget
-cursor] \
2311 -spacing1 1 -spacing3 1
2312 lappend bglist
$cflist
2313 lappend fglist
$cflist
2314 ${NS}::scrollbar .bright.sb
-command "$cflist yview"
2315 pack .bright.sb
-side right
-fill y
2316 pack
$cflist -side left
-fill both
-expand 1
2317 $cflist tag configure highlight \
2318 -background [$cflist cget
-selectbackground]
2319 $cflist tag configure bold
-font mainfontbold
2321 .pwbottom add .bright
2324 # restore window width & height if known
2325 if {[info exists geometry
(main
)]} {
2326 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2327 if {$w > [winfo screenwidth .
]} {
2328 set w
[winfo screenwidth .
]
2330 if {$h > [winfo screenheight .
]} {
2331 set h
[winfo screenheight .
]
2333 wm geometry .
"${w}x$h"
2337 if {[info exists geometry
(state
)] && $geometry(state
) eq
"zoomed"} {
2338 wm state .
$geometry(state
)
2341 if {[tk windowingsystem
] eq
{aqua
}} {
2352 %W sashpos
0 $
::geometry
(topheight
)
2354 bind .pwbottom
<Map
> {
2356 %W sashpos
0 $
::geometry
(botwidth
)
2360 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2361 pack .ctop
-fill both
-expand 1
2362 bindall
<1> {selcanvline
%W
%x
%y
}
2363 #bindall <B1-Motion> {selcanvline %W %x %y}
2364 if {[tk windowingsystem
] == "win32"} {
2365 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2366 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2368 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2369 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2370 if {[tk windowingsystem
] eq
"aqua"} {
2371 bindall
<MouseWheel
> {
2372 set delta
[expr {- (%D
)}]
2373 allcanvs yview scroll
$delta units
2375 bindall
<Shift-MouseWheel
> {
2376 set delta
[expr {- (%D
)}]
2377 $canv xview scroll
$delta units
2381 bindall
<$
::BM
> "canvscan mark %W %x %y"
2382 bindall
<B$
::BM-Motion
> "canvscan dragto %W %x %y"
2383 bindkey
<Home
> selfirstline
2384 bindkey
<End
> sellastline
2385 bind .
<Key-Up
> "selnextline -1"
2386 bind .
<Key-Down
> "selnextline 1"
2387 bind .
<Shift-Key-Up
> "dofind -1 0"
2388 bind .
<Shift-Key-Down
> "dofind 1 0"
2389 bindkey
<Key-Right
> "goforw"
2390 bindkey
<Key-Left
> "goback"
2391 bind .
<Key-Prior
> "selnextpage -1"
2392 bind .
<Key-Next
> "selnextpage 1"
2393 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2394 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2395 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2396 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2397 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2398 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2399 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2400 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2401 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2402 bindkey p
"selnextline -1"
2403 bindkey n
"selnextline 1"
2406 bindkey i
"selnextline -1"
2407 bindkey k
"selnextline 1"
2411 bindkey d
"$ctext yview scroll 18 units"
2412 bindkey u
"$ctext yview scroll -18 units"
2413 bindkey
/ {focus
$fstring}
2414 bindkey
<Key-KP_Divide
> {focus
$fstring}
2415 bindkey
<Key-Return
> {dofind
1 1}
2416 bindkey ?
{dofind
-1 1}
2418 bind .
<F5
> updatecommits
2419 bind .
<$M1B-F5> reloadcommits
2420 bind .
<F2
> showrefs
2421 bind .
<Shift-F4
> {newview
0}
2422 catch
{ bind .
<Shift-Key-XF86_Switch_VT_4
> {newview
0} }
2423 bind .
<F4
> edit_or_newview
2424 bind .
<$M1B-q> doquit
2425 bind .
<$M1B-f> {dofind
1 1}
2426 bind .
<$M1B-g> {dofind
1 0}
2427 bind .
<$M1B-r> dosearchback
2428 bind .
<$M1B-s> dosearch
2429 bind .
<$M1B-equal> {incrfont
1}
2430 bind .
<$M1B-plus> {incrfont
1}
2431 bind .
<$M1B-KP_Add> {incrfont
1}
2432 bind .
<$M1B-minus> {incrfont
-1}
2433 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2434 wm protocol . WM_DELETE_WINDOW doquit
2435 bind .
<Destroy
> {stop_backends
}
2436 bind .
<Button-1
> "click %W"
2437 bind $fstring <Key-Return
> {dofind
1 1}
2438 bind $sha1entry <Key-Return
> {gotocommit
; break}
2439 bind $sha1entry <<PasteSelection>> clearsha1
2440 bind $cflist <1> {sel_flist %W %x %y; break}
2441 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2442 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2444 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2445 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2447 set maincursor [. cget -cursor]
2448 set textcursor [$ctext cget -cursor]
2449 set curtextcursor $textcursor
2451 set rowctxmenu .rowctxmenu
2452 makemenu $rowctxmenu {
2453 {mc "Diff this -> selected" command {diffvssel 0}}
2454 {mc "Diff selected -> this" command {diffvssel 1}}
2455 {mc "Make patch" command mkpatch}
2456 {mc "Create tag" command mktag}
2457 {mc "Write commit to file" command writecommit}
2458 {mc "Create new branch" command mkbranch}
2459 {mc "Cherry-pick this commit" command cherrypick}
2460 {mc "Reset HEAD branch to here" command resethead}
2461 {mc "Mark this commit" command markhere}
2462 {mc "Return to mark" command gotomark}
2463 {mc "Find descendant of this and mark" command find_common_desc}
2464 {mc "Compare with marked commit" command compare_commits}
2466 $rowctxmenu configure -tearoff 0
2468 set fakerowmenu .fakerowmenu
2469 makemenu $fakerowmenu {
2470 {mc "Diff this -> selected" command {diffvssel 0}}
2471 {mc "Diff selected -> this" command {diffvssel 1}}
2472 {mc "Make patch" command mkpatch}
2474 $fakerowmenu configure -tearoff 0
2476 set headctxmenu .headctxmenu
2477 makemenu $headctxmenu {
2478 {mc "Check out this branch" command cobranch}
2479 {mc "Remove this branch" command rmbranch}
2481 $headctxmenu configure -tearoff 0
2484 set flist_menu .flistctxmenu
2485 makemenu $flist_menu {
2486 {mc "Highlight this too" command {flist_hl 0}}
2487 {mc "Highlight this only" command {flist_hl 1}}
2488 {mc "External diff" command {external_diff}}
2489 {mc "Blame parent commit" command {external_blame 1}}
2491 $flist_menu configure -tearoff 0
2494 set diff_menu .diffctxmenu
2495 makemenu $diff_menu {
2496 {mc "Show origin of this line" command show_line_source}
2497 {mc "Run git gui blame on this line" command {external_blame_diff}}
2499 $diff_menu configure -tearoff 0
2502 # Windows sends all mouse wheel events to the current focused window, not
2503 # the one where the mouse hovers, so bind those events here and redirect
2504 # to the correct window
2505 proc windows_mousewheel_redirector {W X Y D} {
2506 global canv canv2 canv3
2507 set w [winfo containing -displayof $W $X $Y]
2509 set u [expr {$D < 0 ? 5 : -5}]
2510 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2511 allcanvs yview scroll $u units
2514 $w yview scroll $u units
2520 # Update row number label when selectedline changes
2521 proc selectedline_change {n1 n2 op} {
2522 global selectedline rownumsel
2524 if {$selectedline eq {}} {
2527 set rownumsel [expr {$selectedline + 1}]
2531 # mouse-2 makes all windows scan vertically, but only the one
2532 # the cursor is in scans horizontally
2533 proc canvscan {op w x y} {
2534 global canv canv2 canv3
2535 foreach c [list $canv $canv2 $canv3] {
2544 proc scrollcanv {cscroll f0 f1} {
2545 $cscroll set $f0 $f1
2550 # when we make a key binding for the toplevel, make sure
2551 # it doesn't get triggered when that key is pressed in the
2552 # find string entry widget.
2553 proc bindkey {ev script} {
2556 set escript [bind Entry $ev]
2557 if {$escript == {}} {
2558 set escript [bind Entry <Key>]
2560 foreach e $entries {
2561 bind $e $ev "$escript; break"
2565 # set the focus back to the toplevel for any click outside
2568 global ctext entries
2569 foreach e [concat $entries $ctext] {
2570 if {$w == $e} return
2575 # Adjust the progress bar for a change in requested extent or canvas size
2576 proc adjustprogress {} {
2577 global progresscanv progressitem progresscoords
2578 global fprogitem fprogcoord lastprogupdate progupdatepending
2579 global rprogitem rprogcoord use_ttk
2582 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2586 set w [expr {[winfo width $progresscanv] - 4}]
2587 set x0 [expr {$w * [lindex $progresscoords 0]}]
2588 set x1 [expr {$w * [lindex $progresscoords 1]}]
2589 set h [winfo height $progresscanv]
2590 $progresscanv coords $progressitem $x0 0 $x1 $h
2591 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2592 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2593 set now [clock clicks -milliseconds]
2594 if {$now >= $lastprogupdate + 100} {
2595 set progupdatepending 0
2597 } elseif {!$progupdatepending} {
2598 set progupdatepending 1
2599 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2603 proc doprogupdate {} {
2604 global lastprogupdate progupdatepending
2606 if {$progupdatepending} {
2607 set progupdatepending 0
2608 set lastprogupdate [clock clicks -milliseconds]
2613 proc savestuff {w} {
2614 global canv canv2 canv3 mainfont textfont uifont tabstop
2615 global stuffsaved findmergefiles maxgraphpct
2616 global maxwidth showneartags showlocalchanges
2617 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2618 global cmitmode wrapcomment datetimeformat limitdiffs
2619 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2620 global autoselect extdifftool perfile_attrs markbgcolor use_ttk
2621 global hideremotes want_ttk
2623 if {$stuffsaved} return
2624 if {![winfo viewable .]} return
2626 set f [open "~/.gitk-new" w]
2627 if {$::tcl_platform(platform) eq {windows}} {
2628 file attributes "~/.gitk-new" -hidden true
2630 puts $f [list set mainfont $mainfont]
2631 puts $f [list set textfont $textfont]
2632 puts $f [list set uifont $uifont]
2633 puts $f [list set tabstop $tabstop]
2634 puts $f [list set findmergefiles $findmergefiles]
2635 puts $f [list set maxgraphpct $maxgraphpct]
2636 puts $f [list set maxwidth $maxwidth]
2637 puts $f [list set cmitmode $cmitmode]
2638 puts $f [list set wrapcomment $wrapcomment]
2639 puts $f [list set autoselect $autoselect]
2640 puts $f [list set showneartags $showneartags]
2641 puts $f [list set hideremotes $hideremotes]
2642 puts $f [list set showlocalchanges $showlocalchanges]
2643 puts $f [list set datetimeformat $datetimeformat]
2644 puts $f [list set limitdiffs $limitdiffs]
2645 puts $f [list set want_ttk $want_ttk]
2646 puts $f [list set bgcolor $bgcolor]
2647 puts $f [list set fgcolor $fgcolor]
2648 puts $f [list set colors $colors]
2649 puts $f [list set diffcolors $diffcolors]
2650 puts $f [list set markbgcolor $markbgcolor]
2651 puts $f [list set diffcontext $diffcontext]
2652 puts $f [list set selectbgcolor $selectbgcolor]
2653 puts $f [list set extdifftool $extdifftool]
2654 puts $f [list set perfile_attrs $perfile_attrs]
2656 puts $f "set geometry(main) [wm geometry .]"
2657 puts $f "set geometry(state) [wm state .]"
2658 puts $f "set geometry(topwidth) [winfo width .tf]"
2659 puts $f "set geometry(topheight) [winfo height .tf]"
2661 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2662 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2664 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2665 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2667 puts $f "set geometry(botwidth) [winfo width .bleft]"
2668 puts $f "set geometry(botheight) [winfo height .bleft]"
2670 puts -nonewline $f "set permviews {"
2671 for {set v 0} {$v < $nextviewnum} {incr v} {
2672 if {$viewperm($v)} {
2673 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2678 file rename -force "~/.gitk-new" "~/.gitk"
2683 proc resizeclistpanes {win w} {
2684 global oldwidth use_ttk
2685 if {[info exists oldwidth($win)]} {
2687 set s0 [$win sashpos 0]
2688 set s1 [$win sashpos 1]
2690 set s0 [$win sash coord 0]
2691 set s1 [$win sash coord 1]
2694 set sash0 [expr {int($w/2 - 2)}]
2695 set sash1 [expr {int($w*5/6 - 2)}]
2697 set factor [expr {1.0 * $w / $oldwidth($win)}]
2698 set sash0 [expr {int($factor * [lindex $s0 0])}]
2699 set sash1 [expr {int($factor * [lindex $s1 0])}]
2703 if {$sash1 < $sash0 + 20} {
2704 set sash1 [expr {$sash0 + 20}]
2706 if {$sash1 > $w - 10} {
2707 set sash1 [expr {$w - 10}]
2708 if {$sash0 > $sash1 - 20} {
2709 set sash0 [expr {$sash1 - 20}]
2714 $win sashpos 0 $sash0
2715 $win sashpos 1 $sash1
2717 $win sash place 0 $sash0 [lindex $s0 1]
2718 $win sash place 1 $sash1 [lindex $s1 1]
2721 set oldwidth($win) $w
2724 proc resizecdetpanes {win w} {
2725 global oldwidth use_ttk
2726 if {[info exists oldwidth($win)]} {
2728 set s0 [$win sashpos 0]
2730 set s0 [$win sash coord 0]
2733 set sash0 [expr {int($w*3/4 - 2)}]
2735 set factor [expr {1.0 * $w / $oldwidth($win)}]
2736 set sash0 [expr {int($factor * [lindex $s0 0])}]
2740 if {$sash0 > $w - 15} {
2741 set sash0 [expr {$w - 15}]
2745 $win sashpos 0 $sash0
2747 $win sash place 0 $sash0 [lindex $s0 1]
2750 set oldwidth($win) $w
2753 proc allcanvs args {
2754 global canv canv2 canv3
2760 proc bindall {event action} {
2761 global canv canv2 canv3
2762 bind $canv $event $action
2763 bind $canv2 $event $action
2764 bind $canv3 $event $action
2770 if {[winfo exists $w]} {
2775 wm title $w [mc "About gitk"]
2777 message $w.m -text [mc "
2778 Gitk - a commit viewer for git
2780 Copyright \u00a9 2005-2009 Paul Mackerras
2782 Use and redistribute under the terms of the GNU General Public License"] \
2783 -justify center -aspect 400 -border 2 -bg white -relief groove
2784 pack $w.m -side top -fill x -padx 2 -pady 2
2785 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2786 pack $w.ok -side bottom
2787 bind $w <Visibility> "focus $w.ok"
2788 bind $w <Key-Escape> "destroy $w"
2789 bind $w <Key-Return> "destroy $w"
2790 tk::PlaceWindow $w widget .
2796 if {[winfo exists $w]} {
2800 if {[tk windowingsystem] eq {aqua}} {
2806 wm title $w [mc "Gitk key bindings"]
2808 message $w.m -text "
2809 [mc "Gitk key bindings:"]
2811 [mc "<%s-Q> Quit" $M1T]
2812 [mc "<Home> Move to first commit"]
2813 [mc "<End> Move to last commit"]
2814 [mc "<Up>, p, i Move up one commit"]
2815 [mc "<Down>, n, k Move down one commit"]
2816 [mc "<Left>, z, j Go back in history list"]
2817 [mc "<Right>, x, l Go forward in history list"]
2818 [mc "<PageUp> Move up one page in commit list"]
2819 [mc "<PageDown> Move down one page in commit list"]
2820 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2821 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2822 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2823 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2824 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2825 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2826 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2827 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2828 [mc "<Delete>, b Scroll diff view up one page"]
2829 [mc "<Backspace> Scroll diff view up one page"]
2830 [mc "<Space> Scroll diff view down one page"]
2831 [mc "u Scroll diff view up 18 lines"]
2832 [mc "d Scroll diff view down 18 lines"]
2833 [mc "<%s-F> Find" $M1T]
2834 [mc "<%s-G> Move to next find hit" $M1T]
2835 [mc "<Return> Move to next find hit"]
2836 [mc "/ Focus the search box"]
2837 [mc "? Move to previous find hit"]
2838 [mc "f Scroll diff view to next file"]
2839 [mc "<%s-S> Search for next hit in diff view" $M1T]
2840 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2841 [mc "<%s-KP+> Increase font size" $M1T]
2842 [mc "<%s-plus> Increase font size" $M1T]
2843 [mc "<%s-KP-> Decrease font size" $M1T]
2844 [mc "<%s-minus> Decrease font size" $M1T]
2847 -justify left -bg white -border 2 -relief groove
2848 pack $w.m -side top -fill both -padx 2 -pady 2
2849 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2850 bind $w <Key-Escape> [list destroy $w]
2851 pack $w.ok -side bottom
2852 bind $w <Visibility> "focus $w.ok"
2853 bind $w <Key-Escape> "destroy $w"
2854 bind $w <Key-Return> "destroy $w"
2857 # Procedures for manipulating the file list window at the
2858 # bottom right of the overall window.
2860 proc treeview {w l openlevs} {
2861 global treecontents treediropen treeheight treeparent treeindex
2871 set treecontents() {}
2872 $w conf -state normal
2874 while {[string range $f 0 $prefixend] ne $prefix} {
2875 if {$lev <= $openlevs} {
2876 $w mark set e:$treeindex($prefix) "end -1c"
2877 $w mark gravity e:$treeindex($prefix) left
2879 set treeheight($prefix) $ht
2880 incr ht [lindex $htstack end]
2881 set htstack [lreplace $htstack end end]
2882 set prefixend [lindex $prefendstack end]
2883 set prefendstack [lreplace $prefendstack end end]
2884 set prefix [string range $prefix 0 $prefixend]
2887 set tail [string range $f [expr {$prefixend+1}] end]
2888 while {[set slash [string first "/" $tail]] >= 0} {
2891 lappend prefendstack $prefixend
2892 incr prefixend [expr {$slash + 1}]
2893 set d [string range $tail 0 $slash]
2894 lappend treecontents($prefix) $d
2895 set oldprefix $prefix
2897 set treecontents($prefix) {}
2898 set treeindex($prefix) [incr ix]
2899 set treeparent($prefix) $oldprefix
2900 set tail [string range $tail [expr {$slash+1}] end]
2901 if {$lev <= $openlevs} {
2903 set treediropen($prefix) [expr {$lev < $openlevs}]
2904 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2905 $w mark set d:$ix "end -1c"
2906 $w mark gravity d:$ix left
2908 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2910 $w image create end -align center -image $bm -padx 1 \
2912 $w insert end $d [highlight_tag $prefix]
2913 $w mark set s:$ix "end -1c"
2914 $w mark gravity s:$ix left
2919 if {$lev <= $openlevs} {
2922 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2924 $w insert end $tail [highlight_tag $f]
2926 lappend treecontents($prefix) $tail
2929 while {$htstack ne {}} {
2930 set treeheight($prefix) $ht
2931 incr ht [lindex $htstack end]
2932 set htstack [lreplace $htstack end end]
2933 set prefixend [lindex $prefendstack end]
2934 set prefendstack [lreplace $prefendstack end end]
2935 set prefix [string range $prefix 0 $prefixend]
2937 $w conf -state disabled
2940 proc linetoelt {l} {
2941 global treeheight treecontents
2946 foreach e $treecontents($prefix) {
2951 if {[string index $e end] eq "/"} {
2952 set n $treeheight($prefix$e)
2964 proc highlight_tree {y prefix} {
2965 global treeheight treecontents cflist
2967 foreach e $treecontents($prefix) {
2969 if {[highlight_tag $path] ne {}} {
2970 $cflist tag add bold $y.0 "$y.0 lineend"
2973 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2974 set y [highlight_tree $y $path]
2980 proc treeclosedir {w dir} {
2981 global treediropen treeheight treeparent treeindex
2983 set ix $treeindex($dir)
2984 $w conf -state normal
2985 $w delete s:$ix e:$ix
2986 set treediropen($dir) 0
2987 $w image configure a:$ix -image tri-rt
2988 $w conf -state disabled
2989 set n [expr {1 - $treeheight($dir)}]
2990 while {$dir ne {}} {
2991 incr treeheight($dir) $n
2992 set dir $treeparent($dir)
2996 proc treeopendir {w dir} {
2997 global treediropen treeheight treeparent treecontents treeindex
2999 set ix $treeindex($dir)
3000 $w conf -state normal
3001 $w image configure a:$ix -image tri-dn
3002 $w mark set e:$ix s:$ix
3003 $w mark gravity e:$ix right
3006 set n [llength $treecontents($dir)]
3007 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3010 incr treeheight($x) $n
3012 foreach e $treecontents($dir) {
3014 if {[string index $e end] eq "/"} {
3015 set iy $treeindex($de)
3016 $w mark set d:$iy e:$ix
3017 $w mark gravity d:$iy left
3018 $w insert e:$ix $str
3019 set treediropen($de) 0
3020 $w image create e:$ix -align center -image tri-rt -padx 1 \
3022 $w insert e:$ix $e [highlight_tag $de]
3023 $w mark set s:$iy e:$ix
3024 $w mark gravity s:$iy left
3025 set treeheight($de) 1
3027 $w insert e:$ix $str
3028 $w insert e:$ix $e [highlight_tag $de]
3031 $w mark gravity e:$ix right
3032 $w conf -state disabled
3033 set treediropen($dir) 1
3034 set top [lindex [split [$w index @0,0] .] 0]
3035 set ht [$w cget -height]
3036 set l [lindex [split [$w index s:$ix] .] 0]
3039 } elseif {$l + $n + 1 > $top + $ht} {
3040 set top [expr {$l + $n + 2 - $ht}]
3048 proc treeclick {w x y} {
3049 global treediropen cmitmode ctext cflist cflist_top
3051 if {$cmitmode ne "tree"} return
3052 if {![info exists cflist_top]} return
3053 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3054 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3055 $cflist tag add highlight $l.0 "$l.0 lineend"
3061 set e [linetoelt $l]
3062 if {[string index $e end] ne "/"} {
3064 } elseif {$treediropen($e)} {
3071 proc setfilelist {id} {
3072 global treefilelist cflist jump_to_here
3074 treeview $cflist $treefilelist($id) 0
3075 if {$jump_to_here ne {}} {
3076 set f [lindex $jump_to_here 0]
3077 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3083 image create bitmap tri-rt -background black -foreground blue -data {
3084 #define tri-rt_width 13
3085 #define tri-rt_height 13
3086 static unsigned char tri-rt_bits[] = {
3087 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3088 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3091 #define tri-rt-mask_width 13
3092 #define tri-rt-mask_height 13
3093 static unsigned char tri-rt-mask_bits[] = {
3094 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3095 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3098 image create bitmap tri-dn -background black -foreground blue -data {
3099 #define tri-dn_width 13
3100 #define tri-dn_height 13
3101 static unsigned char tri-dn_bits[] = {
3102 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3103 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3106 #define tri-dn-mask_width 13
3107 #define tri-dn-mask_height 13
3108 static unsigned char tri-dn-mask_bits[] = {
3109 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3110 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3114 image create bitmap reficon-T -background black -foreground yellow -data {
3115 #define tagicon_width 13
3116 #define tagicon_height 9
3117 static unsigned char tagicon_bits[] = {
3118 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3119 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3121 #define tagicon-mask_width 13
3122 #define tagicon-mask_height 9
3123 static unsigned char tagicon-mask_bits[] = {
3124 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3125 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3128 #define headicon_width 13
3129 #define headicon_height 9
3130 static unsigned char headicon_bits[] = {
3131 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3132 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3135 #define headicon-mask_width 13
3136 #define headicon-mask_height 9
3137 static unsigned char headicon-mask_bits[] = {
3138 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3139 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3141 image create bitmap reficon-H -background black -foreground green \
3142 -data $rectdata -maskdata $rectmask
3143 image create bitmap reficon-o -background black -foreground "#ddddff" \
3144 -data $rectdata -maskdata $rectmask
3146 proc init_flist {first} {
3147 global cflist cflist_top difffilestart
3149 $cflist conf -state normal
3150 $cflist delete 0.0 end
3152 $cflist insert end $first
3154 $cflist tag add highlight 1.0 "1.0 lineend"
3156 catch {unset cflist_top}
3158 $cflist conf -state disabled
3159 set difffilestart {}
3162 proc highlight_tag {f} {
3163 global highlight_paths
3165 foreach p $highlight_paths {
3166 if {[string match $p $f]} {
3173 proc highlight_filelist {} {
3174 global cmitmode cflist
3176 $cflist conf -state normal
3177 if {$cmitmode ne "tree"} {
3178 set end [lindex [split [$cflist index end] .] 0]
3179 for {set l 2} {$l < $end} {incr l} {
3180 set line [$cflist get $l.0 "$l.0 lineend"]
3181 if {[highlight_tag $line] ne {}} {
3182 $cflist tag add bold $l.0 "$l.0 lineend"
3188 $cflist conf -state disabled
3191 proc unhighlight_filelist {} {
3194 $cflist conf -state normal
3195 $cflist tag remove bold 1.0 end
3196 $cflist conf -state disabled
3199 proc add_flist {fl} {
3202 $cflist conf -state normal
3204 $cflist insert end "\n"
3205 $cflist insert end $f [highlight_tag $f]
3207 $cflist conf -state disabled
3210 proc sel_flist {w x y} {
3211 global ctext difffilestart cflist cflist_top cmitmode
3213 if {$cmitmode eq "tree"} return
3214 if {![info exists cflist_top]} return
3215 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3216 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3217 $cflist tag add highlight $l.0 "$l.0 lineend"
3222 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3226 proc pop_flist_menu {w X Y x y} {
3227 global ctext cflist cmitmode flist_menu flist_menu_file
3228 global treediffs diffids
3231 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3233 if {$cmitmode eq "tree"} {
3234 set e [linetoelt $l]
3235 if {[string index $e end] eq "/"} return
3237 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3239 set flist_menu_file $e
3240 set xdiffstate "normal"
3241 if {$cmitmode eq "tree"} {
3242 set xdiffstate "disabled"
3244 # Disable "External diff" item in tree mode
3245 $flist_menu entryconf 2 -state $xdiffstate
3246 tk_popup $flist_menu $X $Y
3249 proc find_ctext_fileinfo {line} {
3250 global ctext_file_names ctext_file_lines
3252 set ok [bsearch $ctext_file_lines $line]
3253 set tline [lindex $ctext_file_lines $ok]
3255 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3258 return [list [lindex $ctext_file_names $ok] $tline]
3262 proc pop_diff_menu {w X Y x y} {
3263 global ctext diff_menu flist_menu_file
3264 global diff_menu_txtpos diff_menu_line
3265 global diff_menu_filebase
3267 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3268 set diff_menu_line [lindex $diff_menu_txtpos 0]
3269 # don't pop up the menu on hunk-separator or file-separator lines
3270 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3274 set f [find_ctext_fileinfo $diff_menu_line]
3275 if {$f eq {}} return
3276 set flist_menu_file [lindex $f 0]
3277 set diff_menu_filebase [lindex $f 1]
3278 tk_popup $diff_menu $X $Y
3281 proc flist_hl {only} {
3282 global flist_menu_file findstring gdttype
3284 set x [shellquote $flist_menu_file]
3285 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3288 append findstring " " $x
3290 set gdttype [mc "touching paths:"]
3293 proc gitknewtmpdir {} {
3294 global diffnum gitktmpdir gitdir
3296 if {![info exists gitktmpdir]} {
3297 set gitktmpdir [file join [file dirname $gitdir] \
3298 [format ".gitk-tmp.%s" [pid]]]
3299 if {[catch {file mkdir $gitktmpdir} err]} {
3300 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3307 set diffdir [file join $gitktmpdir $diffnum]
3308 if {[catch {file mkdir $diffdir} err]} {
3309 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3315 proc save_file_from_commit {filename output what} {
3318 if {[catch {exec git show $filename -- > $output} err]} {
3319 if {[string match "fatal: bad revision *" $err]} {
3322 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3328 proc external_diff_get_one_file {diffid filename diffdir} {
3329 global nullid nullid2 nullfile
3332 if {$diffid == $nullid} {
3333 set difffile [file join [file dirname $gitdir] $filename]
3334 if {[file exists $difffile]} {
3339 if {$diffid == $nullid2} {
3340 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3341 return [save_file_from_commit :$filename $difffile index]
3343 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3344 return [save_file_from_commit $diffid:$filename $difffile \
3348 proc external_diff {} {
3349 global nullid nullid2
3350 global flist_menu_file
3354 if {[llength $diffids] == 1} {
3355 # no reference commit given
3356 set diffidto [lindex $diffids 0]
3357 if {$diffidto eq $nullid} {
3358 # diffing working copy with index
3359 set diffidfrom $nullid2
3360 } elseif {$diffidto eq $nullid2} {
3361 # diffing index with HEAD
3362 set diffidfrom "HEAD"
3364 # use first parent commit
3365 global parentlist selectedline
3366 set diffidfrom [lindex $parentlist $selectedline 0]
3369 set diffidfrom [lindex $diffids 0]
3370 set diffidto [lindex $diffids 1]
3373 # make sure that several diffs wont collide
3374 set diffdir [gitknewtmpdir]
3375 if {$diffdir eq {}} return
3377 # gather files to diff
3378 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3379 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3381 if {$difffromfile ne {} && $difftofile ne {}} {
3382 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3383 if {[catch {set fl [open |$cmd r]} err]} {
3384 file delete -force $diffdir
3385 error_popup "$extdifftool: [mc "command failed:"] $err"
3387 fconfigure $fl -blocking 0
3388 filerun $fl [list delete_at_eof $fl $diffdir]
3393 proc find_hunk_blamespec {base line} {
3396 # Find and parse the hunk header
3397 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3398 if {$s_lix eq {}} return
3400 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3401 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3402 s_line old_specs osz osz1 new_line nsz]} {
3406 # base lines for the parents
3407 set base_lines [list $new_line]
3408 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3409 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3410 old_spec old_line osz]} {
3413 lappend base_lines $old_line
3416 # Now scan the lines to determine offset within the hunk
3417 set max_parent [expr {[llength $base_lines]-2}]
3419 set s_lno [lindex [split $s_lix "."] 0]
3421 # Determine if the line is removed
3422 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3423 if {[string match {[-+ ]*} $chunk]} {
3424 set removed_idx [string first "-" $chunk]
3425 # Choose a parent index
3426 if {$removed_idx >= 0} {
3427 set parent $removed_idx
3429 set unchanged_idx [string first " " $chunk]
3430 if {$unchanged_idx >= 0} {
3431 set parent $unchanged_idx
3433 # blame the current commit
3437 # then count other lines that belong to it
3438 for {set i $line} {[incr i -1] > $s_lno} {} {
3439 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3440 # Determine if the line is removed
3441 set removed_idx [string first "-" $chunk]
3443 set code [string index $chunk $parent]
3444 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3448 if {$removed_idx < 0} {
3458 incr dline [lindex $base_lines $parent]
3459 return [list $parent $dline]
3462 proc external_blame_diff {} {
3463 global currentid cmitmode
3464 global diff_menu_txtpos diff_menu_line
3465 global diff_menu_filebase flist_menu_file
3467 if {$cmitmode eq "tree"} {
3469 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3471 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3473 set parent_idx [lindex $hinfo 0]
3474 set line [lindex $hinfo 1]
3481 external_blame $parent_idx $line
3484 # Find the SHA1 ID of the blob for file $fname in the index
3486 proc index_sha1 {fname} {
3487 set f [open [list | git ls-files -s $fname] r]
3488 while {[gets $f line] >= 0} {
3489 set info [lindex [split $line "\t"] 0]
3490 set stage [lindex $info 2]
3491 if {$stage eq "0" || $stage eq "2"} {
3493 return [lindex $info 1]
3500 # Turn an absolute path into one relative to the current directory
3501 proc make_relative {f} {
3502 set elts [file split $f]
3503 set here [file split [pwd]]
3508 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3515 set elts [concat $res [lrange $elts $ei end]]
3516 return [eval file join $elts]
3519 proc external_blame {parent_idx {line {}}} {
3520 global flist_menu_file gitdir
3521 global nullid nullid2
3522 global parentlist selectedline currentid
3524 if {$parent_idx > 0} {
3525 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3527 set base_commit $currentid
3530 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3531 error_popup [mc "No such commit"]
3535 set cmdline [list git gui blame]
3536 if {$line ne {} && $line > 1} {
3537 lappend cmdline "--line=$line"
3539 set f [file join [file dirname $gitdir] $flist_menu_file]
3540 # Unfortunately it seems git gui blame doesn't like
3541 # being given an absolute path...
3542 set f [make_relative $f]
3543 lappend cmdline $base_commit $f
3544 if {[catch {eval exec $cmdline &} err]} {
3545 error_popup "[mc "git gui blame: command failed:"] $err"
3549 proc show_line_source {} {
3550 global cmitmode currentid parents curview blamestuff blameinst
3551 global diff_menu_line diff_menu_filebase flist_menu_file
3552 global nullid nullid2 gitdir
3555 if {$cmitmode eq "tree"} {
3557 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3559 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3560 if {$h eq {}} return
3561 set pi [lindex $h 0]
3563 mark_ctext_line $diff_menu_line
3567 if {$currentid eq $nullid} {
3569 # must be a merge in progress...
3571 # get the last line from .git/MERGE_HEAD
3572 set f [open [file join $gitdir MERGE_HEAD] r]
3573 set id [lindex [split [read $f] "\n"] end-1]
3576 error_popup [mc "Couldn't read merge head: %s" $err]
3579 } elseif {$parents($curview,$currentid) eq $nullid2} {
3580 # need to do the blame from the index
3582 set from_index [index_sha1 $flist_menu_file]
3584 error_popup [mc "Error reading index: %s" $err]
3588 set id $parents($curview,$currentid)
3591 set id [lindex $parents($curview,$currentid) $pi]
3593 set line [lindex $h 1]
3596 if {$from_index ne {}} {
3597 lappend blameargs | git cat-file blob $from_index
3599 lappend blameargs | git blame -p -L$line,+1
3600 if {$from_index ne {}} {
3601 lappend blameargs --contents -
3603 lappend blameargs $id
3605 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3607 set f [open $blameargs r]
3609 error_popup [mc "Couldn't start git blame: %s" $err]
3612 nowbusy blaming [mc "Searching"]
3613 fconfigure $f -blocking 0
3614 set i [reg_instance $f]
3615 set blamestuff($i) {}
3617 filerun $f [list read_line_source $f $i]
3620 proc stopblaming {} {
3623 if {[info exists blameinst]} {
3624 stop_instance $blameinst
3630 proc read_line_source {fd inst} {
3631 global blamestuff curview commfd blameinst nullid nullid2
3633 while {[gets $fd line] >= 0} {
3634 lappend blamestuff($inst) $line
3642 fconfigure $fd -blocking 1
3643 if {[catch {close $fd} err]} {
3644 error_popup [mc "Error running git blame: %s" $err]
3649 set line [split [lindex $blamestuff($inst) 0] " "]
3650 set id [lindex $line 0]
3651 set lnum [lindex $line 1]
3652 if {[string length $id] == 40 && [string is xdigit $id] &&
3653 [string is digit -strict $lnum]} {
3654 # look for "filename" line
3655 foreach l $blamestuff($inst) {
3656 if {[string match "filename *" $l]} {
3657 set fname [string range $l 9 end]
3663 # all looks good, select it
3664 if {$id eq $nullid} {
3665 # blame uses all-zeroes to mean not committed,
3666 # which would mean a change in the index
3669 if {[commitinview $id $curview]} {
3670 selectline [rowofcommit $id] 1 [list $fname $lnum]
3672 error_popup [mc "That line comes from commit %s, \
3673 which is not in this view" [shortids $id]]
3676 puts "oops couldn't parse git blame output"
3681 # delete $dir when we see eof on $f (presumably because the child has exited)
3682 proc delete_at_eof {f dir} {
3683 while {[gets $f line] >= 0} {}
3685 if {[catch {close $f} err]} {
3686 error_popup "[mc "External diff viewer failed:"] $err"
3688 file delete -force $dir
3694 # Functions for adding and removing shell-type quoting
3696 proc shellquote {str} {
3697 if {![string match "*\['\"\\ \t]*" $str]} {
3700 if {![string match "*\['\"\\]*" $str]} {
3703 if {![string match "*'*" $str]} {
3706 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3709 proc shellarglist {l} {
3715 append str [shellquote $a]
3720 proc shelldequote {str} {
3725 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3726 append ret [string range $str $used end]
3727 set used [string length $str]
3730 set first [lindex $first 0]
3731 set ch [string index $str $first]
3732 if {$first > $used} {
3733 append ret [string range $str $used [expr {$first - 1}]]
3736 if {$ch eq " " || $ch eq "\t"} break
3739 set first [string first "'" $str $used]
3741 error "unmatched single-quote"
3743 append ret [string range $str $used [expr {$first - 1}]]
3748 if {$used >= [string length $str]} {
3749 error "trailing backslash"
3751 append ret [string index $str $used]
3756 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3757 error "unmatched double-quote"
3759 set first [lindex $first 0]
3760 set ch [string index $str $first]
3761 if {$first > $used} {
3762 append ret [string range $str $used [expr {$first - 1}]]
3765 if {$ch eq "\""} break
3767 append ret [string index $str $used]
3771 return [list $used $ret]
3774 proc shellsplit {str} {
3777 set str [string trimleft $str]
3778 if {$str eq {}} break
3779 set dq [shelldequote $str]
3780 set n [lindex $dq 0]
3781 set word [lindex $dq 1]
3782 set str [string range $str $n end]
3788 # Code to implement multiple views
3790 proc newview {ishighlight} {
3791 global nextviewnum newviewname newishighlight
3792 global revtreeargs viewargscmd newviewopts curview
3794 set newishighlight $ishighlight
3796 if {[winfo exists $top]} {
3800 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3801 set newviewopts($nextviewnum,perm) 0
3802 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3803 decode_view_opts $nextviewnum $revtreeargs
3804 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3807 set known_view_options {
3808 {perm b . {} {mc "Remember this view"}}
3809 {reflabel l + {} {mc "References (space separated list):"}}
3810 {refs t15 .. {} {mc "Branches & tags:"}}
3811 {allrefs b *. "--all" {mc "All refs"}}
3812 {branches b . "--branches" {mc "All (local) branches"}}
3813 {tags b . "--tags" {mc "All tags"}}
3814 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
3815 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
3816 {author t15 .. "--author=*" {mc "Author:"}}
3817 {committer t15 . "--committer=*" {mc "Committer:"}}
3818 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
3819 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
3820 {changes_l l + {} {mc "Changes to Files:"}}
3821 {pickaxe_s r0 . {} {mc "Fixed String"}}
3822 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
3823 {pickaxe t15 .. "-S*" {mc "Search string:"}}
3824 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3825 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
3826 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
3827 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
3828 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
3829 {skip t10 . "--skip=*" {mc "Number to skip:"}}
3830 {misc_lbl l + {} {mc "Miscellaneous options:"}}
3831 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
3832 {lright b . "--left-right" {mc "Mark branch sides"}}
3833 {first b . "--first-parent" {mc "Limit to first parent"}}
3834 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
3835 {args t50 *. {} {mc "Additional arguments to git log:"}}
3836 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
3837 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3840 proc encode_view_opts {n} {
3841 global known_view_options newviewopts
3844 foreach opt $known_view_options {
3845 set patterns [lindex $opt 3]
3846 if {$patterns eq {}} continue
3847 set pattern [lindex $patterns 0]
3849 if {[lindex $opt 1] eq "b"} {
3850 set val $newviewopts($n,[lindex $opt 0])
3852 lappend rargs $pattern
3854 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
3855 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
3856 set val $newviewopts($n,$button_id)
3857 if {$val eq $value} {
3858 lappend rargs $pattern
3861 set val $newviewopts($n,[lindex $opt 0])
3862 set val [string trim $val]
3864 set pfix [string range $pattern 0 end-1]
3865 lappend rargs $pfix$val
3869 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
3870 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3873 proc decode_view_opts {n view_args} {
3874 global known_view_options newviewopts
3876 foreach opt $known_view_options {
3877 set id [lindex $opt 0]
3878 if {[lindex $opt 1] eq "b"} {
3881 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
3883 regexp {^(.*_)} $id uselessvar id
3889 set newviewopts($n,$id) $val
3893 foreach arg $view_args {
3894 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3895 && ![info exists found(limit)]} {
3896 set newviewopts($n,limit) $cnt
3901 foreach opt $known_view_options {
3902 set id [lindex $opt 0]
3903 if {[info exists found($id)]} continue
3904 foreach pattern [lindex $opt 3] {
3905 if {![string match $pattern $arg]} continue
3906 if {[lindex $opt 1] eq "b"} {
3909 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
3911 regexp {^(.*_)} $id uselessvar id
3915 set size [string length $pattern]
3916 set val [string range $arg [expr {$size-1}] end]
3918 set newviewopts($n,$id) $val
3922 if {[info exists val]} break
3924 if {[info exists val]} continue
3925 if {[regexp {^-} $arg]} {
3928 lappend refargs $arg
3931 set newviewopts($n,refs) [shellarglist $refargs]
3932 set newviewopts($n,args) [shellarglist $oargs]
3935 proc edit_or_newview {} {
3947 global viewname viewperm newviewname newviewopts
3948 global viewargs viewargscmd
3950 set top .gitkvedit-$curview
3951 if {[winfo exists $top]} {
3955 set newviewname($curview) $viewname($curview)
3956 set newviewopts($curview,perm) $viewperm($curview)
3957 set newviewopts($curview,cmd) $viewargscmd($curview)
3958 decode_view_opts $curview $viewargs($curview)
3959 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3962 proc vieweditor {top n title} {
3963 global newviewname newviewopts viewfiles bgcolor
3964 global known_view_options NS
3967 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
3968 make_transient $top .
3971 ${NS}::frame $top.nfr
3972 ${NS}::label $top.nl -text [mc "View Name"]
3973 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
3974 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3975 pack $top.nl -in $top.nfr -side left -padx {0 5}
3976 pack $top.name -in $top.nfr -side left -padx {0 25}
3982 foreach opt $known_view_options {
3983 set id [lindex $opt 0]
3984 set type [lindex $opt 1]
3985 set flags [lindex $opt 2]
3986 set title [eval [lindex $opt 4]]
3989 if {$flags eq "+" || $flags eq "*"} {
3990 set cframe $top.fr$cnt
3992 ${NS}::frame $cframe
3993 pack $cframe -in $top -fill x -pady 3 -padx 3
3994 set cexpand [expr {$flags eq "*"}]
3995 } elseif {$flags eq ".." || $flags eq "*."} {
3996 set cframe $top.fr$cnt
3998 ${NS}::frame $cframe
3999 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4000 set cexpand [expr {$flags eq "*."}]
4006 ${NS}::label $cframe.l_$id -text $title
4007 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4008 } elseif {$type eq "b"} {
4009 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4010 pack $cframe.c_$id -in $cframe -side left \
4011 -padx [list $lxpad 0] -expand $cexpand -anchor w
4012 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4013 regexp {^(.*_)} $id uselessvar button_id
4014 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4015 pack $cframe.c_$id -in $cframe -side left \
4016 -padx [list $lxpad 0] -expand $cexpand -anchor w
4017 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4018 ${NS}::label $cframe.l_$id -text $title
4019 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4020 -textvariable newviewopts($n,$id)
4021 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4022 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4023 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4024 ${NS}::label $cframe.l_$id -text $title
4025 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4026 -textvariable newviewopts($n,$id)
4027 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4028 pack $cframe.e_$id -in $cframe -side top -fill x
4029 } elseif {$type eq "path"} {
4030 ${NS}::label $top.l -text $title
4031 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4032 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
4033 if {[info exists viewfiles($n)]} {
4034 foreach f $viewfiles($n) {
4035 $top.t insert end $f
4036 $top.t insert end "\n"
4038 $top.t delete {end - 1c} end
4039 $top.t mark set insert 0.0
4041 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4045 ${NS}::frame $top.buts
4046 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4047 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4048 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4049 bind $top <Control-Return> [list newviewok $top $n]
4050 bind $top <F5> [list newviewok $top $n 1]
4051 bind $top <Escape> [list destroy $top]
4052 grid $top.buts.ok $top.buts.apply $top.buts.can
4053 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4054 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4055 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4056 pack $top.buts -in $top -side top -fill x
4060 proc doviewmenu {m first cmd op argv} {
4061 set nmenu [$m index end]
4062 for {set i $first} {$i <= $nmenu} {incr i} {
4063 if {[$m entrycget $i -command] eq $cmd} {
4064 eval $m $op $i $argv
4070 proc allviewmenus {n op args} {
4073 doviewmenu .bar.view 5 [list showview $n] $op $args
4074 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4077 proc newviewok {top n {apply 0}} {
4078 global nextviewnum newviewperm newviewname newishighlight
4079 global viewname viewfiles viewperm selectedview curview
4080 global viewargs viewargscmd newviewopts viewhlmenu
4083 set newargs [encode_view_opts $n]
4085 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4089 foreach f [split [$top.t get 0.0 end] "\n"] {
4090 set ft [string trim $f]
4095 if {![info exists viewfiles($n)]} {
4096 # creating a new view
4098 set viewname($n) $newviewname($n)
4099 set viewperm($n) $newviewopts($n,perm)
4100 set viewfiles($n) $files
4101 set viewargs($n) $newargs
4102 set viewargscmd($n) $newviewopts($n,cmd)
4104 if {!$newishighlight} {
4107 run addvhighlight $n
4110 # editing an existing view
4111 set viewperm($n) $newviewopts($n,perm)
4112 if {$newviewname($n) ne $viewname($n)} {
4113 set viewname($n) $newviewname($n)
4114 doviewmenu .bar.view 5 [list showview $n] \
4115 entryconf [list -label $viewname($n)]
4116 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4117 # entryconf [list -label $viewname($n) -value $viewname($n)]
4119 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4120 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4121 set viewfiles($n) $files
4122 set viewargs($n) $newargs
4123 set viewargscmd($n) $newviewopts($n,cmd)
4124 if {$curview == $n} {
4130 catch {destroy $top}
4134 global curview viewperm hlview selectedhlview
4136 if {$curview == 0} return
4137 if {[info exists hlview] && $hlview == $curview} {
4138 set selectedhlview [mc "None"]
4141 allviewmenus $curview delete
4142 set viewperm($curview) 0
4146 proc addviewmenu {n} {
4147 global viewname viewhlmenu
4149 .bar.view add radiobutton -label $viewname($n) \
4150 -command [list showview $n] -variable selectedview -value $n
4151 #$viewhlmenu add radiobutton -label $viewname($n) \
4152 # -command [list addvhighlight $n] -variable selectedhlview
4156 global curview cached_commitrow ordertok
4157 global displayorder parentlist rowidlist rowisopt rowfinal
4158 global colormap rowtextx nextcolor canvxmax
4159 global numcommits viewcomplete
4160 global selectedline currentid canv canvy0
4162 global pending_select mainheadid
4165 global hlview selectedhlview commitinterest
4167 if {$n == $curview} return
4169 set ymax [lindex [$canv cget -scrollregion] 3]
4170 set span [$canv yview]
4171 set ytop [expr {[lindex $span 0] * $ymax}]
4172 set ybot [expr {[lindex $span 1] * $ymax}]
4173 set yscreen [expr {($ybot - $ytop) / 2}]
4174 if {$selectedline ne {}} {
4175 set selid $currentid
4176 set y [yc $selectedline]
4177 if {$ytop < $y && $y < $ybot} {
4178 set yscreen [expr {$y - $ytop}]
4180 } elseif {[info exists pending_select]} {
4181 set selid $pending_select
4182 unset pending_select
4186 catch {unset treediffs}
4188 if {[info exists hlview] && $hlview == $n} {
4190 set selectedhlview [mc "None"]
4192 catch {unset commitinterest}
4193 catch {unset cached_commitrow}
4194 catch {unset ordertok}
4198 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4199 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4202 if {![info exists viewcomplete($n)]} {
4212 set numcommits $commitidx($n)
4214 catch {unset colormap}
4215 catch {unset rowtextx}
4217 set canvxmax [$canv cget -width]
4223 if {$selid ne {} && [commitinview $selid $n]} {
4224 set row [rowofcommit $selid]
4225 # try to get the selected row in the same position on the screen
4226 set ymax [lindex [$canv cget -scrollregion] 3]
4227 set ytop [expr {[yc $row] - $yscreen}]
4231 set yf [expr {$ytop * 1.0 / $ymax}]
4233 allcanvs yview moveto $yf
4237 } elseif {!$viewcomplete($n)} {
4238 reset_pending_select $selid
4240 reset_pending_select {}
4242 if {[commitinview $pending_select $curview]} {
4243 selectline [rowofcommit $pending_select] 1
4245 set row [first_real_row]
4246 if {$row < $numcommits} {
4251 if {!$viewcomplete($n)} {
4252 if {$numcommits == 0} {
4253 show_status [mc "Reading commits..."]
4255 } elseif {$numcommits == 0} {
4256 show_status [mc "No commits selected"]
4260 # Stuff relating to the highlighting facility
4262 proc ishighlighted {id} {
4263 global vhighlights fhighlights nhighlights rhighlights
4265 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4266 return $nhighlights($id)
4268 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4269 return $vhighlights($id)
4271 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4272 return $fhighlights($id)
4274 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4275 return $rhighlights($id)
4280 proc bolden {id font} {
4281 global canv linehtag currentid boldids need_redisplay markedid
4283 # need_redisplay = 1 means the display is stale and about to be redrawn
4284 if {$need_redisplay} return
4286 $canv itemconf $linehtag($id) -font $font
4287 if {[info exists currentid] && $id eq $currentid} {
4289 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4290 -outline {{}} -tags secsel \
4291 -fill [$canv cget -selectbackground]]
4294 if {[info exists markedid] && $id eq $markedid} {
4299 proc bolden_name {id font} {
4300 global canv2 linentag currentid boldnameids need_redisplay
4302 if {$need_redisplay} return
4303 lappend boldnameids $id
4304 $canv2 itemconf $linentag($id) -font $font
4305 if {[info exists currentid] && $id eq $currentid} {
4306 $canv2 delete secsel
4307 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4308 -outline {{}} -tags secsel \
4309 -fill [$canv2 cget -selectbackground]]
4318 foreach id $boldids {
4319 if {![ishighlighted $id]} {
4322 lappend stillbold $id
4325 set boldids $stillbold
4328 proc addvhighlight {n} {
4329 global hlview viewcomplete curview vhl_done commitidx
4331 if {[info exists hlview]} {
4335 if {$n != $curview && ![info exists viewcomplete($n)]} {
4338 set vhl_done $commitidx($hlview)
4339 if {$vhl_done > 0} {
4344 proc delvhighlight {} {
4345 global hlview vhighlights
4347 if {![info exists hlview]} return
4349 catch {unset vhighlights}
4353 proc vhighlightmore {} {
4354 global hlview vhl_done commitidx vhighlights curview
4356 set max $commitidx($hlview)
4357 set vr [visiblerows]
4358 set r0 [lindex $vr 0]
4359 set r1 [lindex $vr 1]
4360 for {set i $vhl_done} {$i < $max} {incr i} {
4361 set id [commitonrow $i $hlview]
4362 if {[commitinview $id $curview]} {
4363 set row [rowofcommit $id]
4364 if {$r0 <= $row && $row <= $r1} {
4365 if {![highlighted $row]} {
4366 bolden $id mainfontbold
4368 set vhighlights($id) 1
4376 proc askvhighlight {row id} {
4377 global hlview vhighlights iddrawn
4379 if {[commitinview $id $hlview]} {
4380 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4381 bolden $id mainfontbold
4383 set vhighlights($id) 1
4385 set vhighlights($id) 0
4389 proc hfiles_change {} {
4390 global highlight_files filehighlight fhighlights fh_serial
4391 global highlight_paths
4393 if {[info exists filehighlight]} {
4394 # delete previous highlights
4395 catch {close $filehighlight}
4397 catch {unset fhighlights}
4399 unhighlight_filelist
4401 set highlight_paths {}
4402 after cancel do_file_hl $fh_serial
4404 if {$highlight_files ne {}} {
4405 after 300 do_file_hl $fh_serial
4409 proc gdttype_change {name ix op} {
4410 global gdttype highlight_files findstring findpattern
4413 if {$findstring ne {}} {
4414 if {$gdttype eq [mc "containing:"]} {
4415 if {$highlight_files ne {}} {
4416 set highlight_files {}
4421 if {$findpattern ne {}} {
4425 set highlight_files $findstring
4430 # enable/disable findtype/findloc menus too
4433 proc find_change {name ix op} {
4434 global gdttype findstring highlight_files
4437 if {$gdttype eq [mc "containing:"]} {
4440 if {$highlight_files ne $findstring} {
4441 set highlight_files $findstring
4448 proc findcom_change args {
4449 global nhighlights boldnameids
4450 global findpattern findtype findstring gdttype
4453 # delete previous highlights, if any
4454 foreach id $boldnameids {
4455 bolden_name $id mainfont
4458 catch {unset nhighlights}
4461 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4463 } elseif {$findtype eq [mc "Regexp"]} {
4464 set findpattern $findstring
4466 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4468 set findpattern "*$e*"
4472 proc makepatterns {l} {
4475 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4476 if {[string index $ee end] eq "/"} {
4486 proc do_file_hl {serial} {
4487 global highlight_files filehighlight highlight_paths gdttype fhl_list
4489 if {$gdttype eq [mc "touching paths:"]} {
4490 if {[catch {set paths [shellsplit $highlight_files]}]} return
4491 set highlight_paths [makepatterns $paths]
4493 set gdtargs [concat -- $paths]
4494 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4495 set gdtargs [list "-S$highlight_files"]
4497 # must be "containing:", i.e. we're searching commit info
4500 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4501 set filehighlight [open $cmd r+]
4502 fconfigure $filehighlight -blocking 0
4503 filerun $filehighlight readfhighlight
4509 proc flushhighlights {} {
4510 global filehighlight fhl_list
4512 if {[info exists filehighlight]} {
4514 puts $filehighlight ""
4515 flush $filehighlight
4519 proc askfilehighlight {row id} {
4520 global filehighlight fhighlights fhl_list
4522 lappend fhl_list $id
4523 set fhighlights($id) -1
4524 puts $filehighlight $id
4527 proc readfhighlight {} {
4528 global filehighlight fhighlights curview iddrawn
4529 global fhl_list find_dirn
4531 if {![info exists filehighlight]} {
4535 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4536 set line [string trim $line]
4537 set i [lsearch -exact $fhl_list $line]
4538 if {$i < 0} continue
4539 for {set j 0} {$j < $i} {incr j} {
4540 set id [lindex $fhl_list $j]
4541 set fhighlights($id) 0
4543 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4544 if {$line eq {}} continue
4545 if {![commitinview $line $curview]} continue
4546 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4547 bolden $line mainfontbold
4549 set fhighlights($line) 1
4551 if {[eof $filehighlight]} {
4553 puts "oops, git diff-tree died"
4554 catch {close $filehighlight}
4558 if {[info exists find_dirn]} {
4564 proc doesmatch {f} {
4565 global findtype findpattern
4567 if {$findtype eq [mc "Regexp"]} {
4568 return [regexp $findpattern $f]
4569 } elseif {$findtype eq [mc "IgnCase"]} {
4570 return [string match -nocase $findpattern $f]
4572 return [string match $findpattern $f]
4576 proc askfindhighlight {row id} {
4577 global nhighlights commitinfo iddrawn
4579 global markingmatches
4581 if {![info exists commitinfo($id)]} {
4584 set info $commitinfo($id)
4586 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4587 foreach f $info ty $fldtypes {
4588 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4590 if {$ty eq [mc "Author"]} {
4597 if {$isbold && [info exists iddrawn($id)]} {
4598 if {![ishighlighted $id]} {
4599 bolden $id mainfontbold
4601 bolden_name $id mainfontbold
4604 if {$markingmatches} {
4605 markrowmatches $row $id
4608 set nhighlights($id) $isbold
4611 proc markrowmatches {row id} {
4612 global canv canv2 linehtag linentag commitinfo findloc
4614 set headline [lindex $commitinfo($id) 0]
4615 set author [lindex $commitinfo($id) 1]
4616 $canv delete match$row
4617 $canv2 delete match$row
4618 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4619 set m [findmatches $headline]
4621 markmatches $canv $row $headline $linehtag($id) $m \
4622 [$canv itemcget $linehtag($id) -font] $row
4625 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4626 set m [findmatches $author]
4628 markmatches $canv2 $row $author $linentag($id) $m \
4629 [$canv2 itemcget $linentag($id) -font] $row
4634 proc vrel_change {name ix op} {
4635 global highlight_related
4638 if {$highlight_related ne [mc "None"]} {
4643 # prepare for testing whether commits are descendents or ancestors of a
4644 proc rhighlight_sel {a} {
4645 global descendent desc_todo ancestor anc_todo
4646 global highlight_related
4648 catch {unset descendent}
4649 set desc_todo [list $a]
4650 catch {unset ancestor}
4651 set anc_todo [list $a]
4652 if {$highlight_related ne [mc "None"]} {
4658 proc rhighlight_none {} {
4661 catch {unset rhighlights}
4665 proc is_descendent {a} {
4666 global curview children descendent desc_todo
4669 set la [rowofcommit $a]
4673 for {set i 0} {$i < [llength $todo]} {incr i} {
4674 set do [lindex $todo $i]
4675 if {[rowofcommit $do] < $la} {
4676 lappend leftover $do
4679 foreach nk $children($v,$do) {
4680 if {![info exists descendent($nk)]} {
4681 set descendent($nk) 1
4689 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4693 set descendent($a) 0
4694 set desc_todo $leftover
4697 proc is_ancestor {a} {
4698 global curview parents ancestor anc_todo
4701 set la [rowofcommit $a]
4705 for {set i 0} {$i < [llength $todo]} {incr i} {
4706 set do [lindex $todo $i]
4707 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4708 lappend leftover $do
4711 foreach np $parents($v,$do) {
4712 if {![info exists ancestor($np)]} {
4721 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4726 set anc_todo $leftover
4729 proc askrelhighlight {row id} {
4730 global descendent highlight_related iddrawn rhighlights
4731 global selectedline ancestor
4733 if {$selectedline eq {}} return
4735 if {$highlight_related eq [mc "Descendant"] ||
4736 $highlight_related eq [mc "Not descendant"]} {
4737 if {![info exists descendent($id)]} {
4740 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4743 } elseif {$highlight_related eq [mc "Ancestor"] ||
4744 $highlight_related eq [mc "Not ancestor"]} {
4745 if {![info exists ancestor($id)]} {
4748 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4752 if {[info exists iddrawn($id)]} {
4753 if {$isbold && ![ishighlighted $id]} {
4754 bolden $id mainfontbold
4757 set rhighlights($id) $isbold
4760 # Graph layout functions
4762 proc shortids {ids} {
4765 if {[llength $id] > 1} {
4766 lappend res [shortids $id]
4767 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4768 lappend res [string range $id 0 7]
4779 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4780 if {($n & $mask) != 0} {
4781 set ret [concat $ret $o]
4783 set o [concat $o $o]
4788 proc ordertoken {id} {
4789 global ordertok curview varcid varcstart varctok curview parents children
4790 global nullid nullid2
4792 if {[info exists ordertok($id)]} {
4793 return $ordertok($id)
4798 if {[info exists varcid($curview,$id)]} {
4799 set a $varcid($curview,$id)
4800 set p [lindex $varcstart($curview) $a]
4802 set p [lindex $children($curview,$id) 0]
4804 if {[info exists ordertok($p)]} {
4805 set tok $ordertok($p)
4808 set id [first_real_child $curview,$p]
4811 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4814 if {[llength $parents($curview,$id)] == 1} {
4815 lappend todo [list $p {}]
4817 set j [lsearch -exact $parents($curview,$id) $p]
4819 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4821 lappend todo [list $p [strrep $j]]
4824 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4825 set p [lindex $todo $i 0]
4826 append tok [lindex $todo $i 1]
4827 set ordertok($p) $tok
4829 set ordertok($origid) $tok
4833 # Work out where id should go in idlist so that order-token
4834 # values increase from left to right
4835 proc idcol {idlist id {i 0}} {
4836 set t [ordertoken $id]
4840 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4841 if {$i > [llength $idlist]} {
4842 set i [llength $idlist]
4844 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4847 if {$t > [ordertoken [lindex $idlist $i]]} {
4848 while {[incr i] < [llength $idlist] &&
4849 $t >= [ordertoken [lindex $idlist $i]]} {}
4855 proc initlayout {} {
4856 global rowidlist rowisopt rowfinal displayorder parentlist
4857 global numcommits canvxmax canv
4859 global colormap rowtextx
4868 set canvxmax [$canv cget -width]
4869 catch {unset colormap}
4870 catch {unset rowtextx}
4874 proc setcanvscroll {} {
4875 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4876 global lastscrollset lastscrollrows
4878 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4879 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4880 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4881 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4882 set lastscrollset [clock clicks -milliseconds]
4883 set lastscrollrows $numcommits
4886 proc visiblerows {} {
4887 global canv numcommits linespc
4889 set ymax [lindex [$canv cget -scrollregion] 3]
4890 if {$ymax eq {} || $ymax == 0} return
4892 set y0 [expr {int([lindex $f 0] * $ymax)}]
4893 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4897 set y1 [expr {int([lindex $f 1] * $ymax)}]
4898 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4899 if {$r1 >= $numcommits} {
4900 set r1 [expr {$numcommits - 1}]
4902 return [list $r0 $r1]
4905 proc layoutmore {} {
4906 global commitidx viewcomplete curview
4907 global numcommits pending_select curview
4908 global lastscrollset lastscrollrows
4910 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4911 [clock clicks -milliseconds] - $lastscrollset > 500} {
4914 if {[info exists pending_select] &&
4915 [commitinview $pending_select $curview]} {
4917 selectline [rowofcommit $pending_select] 1
4922 # With path limiting, we mightn't get the actual HEAD commit,
4923 # so ask git rev-list what is the first ancestor of HEAD that
4924 # touches a file in the path limit.
4925 proc get_viewmainhead {view} {
4926 global viewmainheadid vfilelimit viewinstances mainheadid
4929 set rfd [open [concat | git rev-list -1 $mainheadid \
4930 -- $vfilelimit($view)] r]
4931 set j [reg_instance $rfd]
4932 lappend viewinstances($view) $j
4933 fconfigure $rfd -blocking 0
4934 filerun $rfd [list getviewhead $rfd $j $view]
4935 set viewmainheadid($curview) {}
4939 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4940 proc getviewhead {fd inst view} {
4941 global viewmainheadid commfd curview viewinstances showlocalchanges
4944 if {[gets $fd line] < 0} {
4948 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4951 set viewmainheadid($view) $id
4954 set i [lsearch -exact $viewinstances($view) $inst]
4956 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4958 if {$showlocalchanges && $id ne {} && $view == $curview} {
4964 proc doshowlocalchanges {} {
4965 global curview viewmainheadid
4967 if {$viewmainheadid($curview) eq {}} return
4968 if {[commitinview $viewmainheadid($curview) $curview]} {
4971 interestedin $viewmainheadid($curview) dodiffindex
4975 proc dohidelocalchanges {} {
4976 global nullid nullid2 lserial curview
4978 if {[commitinview $nullid $curview]} {
4979 removefakerow $nullid
4981 if {[commitinview $nullid2 $curview]} {
4982 removefakerow $nullid2
4987 # spawn off a process to do git diff-index --cached HEAD
4988 proc dodiffindex {} {
4989 global lserial showlocalchanges vfilelimit curview
4992 if {!$showlocalchanges || !$isworktree} return
4994 set cmd "|git diff-index --cached HEAD"
4995 if {$vfilelimit($curview) ne {}} {
4996 set cmd [concat $cmd -- $vfilelimit($curview)]
4998 set fd [open $cmd r]
4999 fconfigure $fd -blocking 0
5000 set i [reg_instance $fd]
5001 filerun $fd [list readdiffindex $fd $lserial $i]
5004 proc readdiffindex {fd serial inst} {
5005 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5009 if {[gets $fd line] < 0} {
5015 # we only need to see one line and we don't really care what it says...
5018 if {$serial != $lserial} {
5022 # now see if there are any local changes not checked in to the index
5023 set cmd "|git diff-files"
5024 if {$vfilelimit($curview) ne {}} {
5025 set cmd [concat $cmd -- $vfilelimit($curview)]
5027 set fd [open $cmd r]
5028 fconfigure $fd -blocking 0
5029 set i [reg_instance $fd]
5030 filerun $fd [list readdifffiles $fd $serial $i]
5032 if {$isdiff && ![commitinview $nullid2 $curview]} {
5033 # add the line for the changes in the index to the graph
5034 set hl [mc "Local changes checked in to index but not committed"]
5035 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5036 set commitdata($nullid2) "\n $hl\n"
5037 if {[commitinview $nullid $curview]} {
5038 removefakerow $nullid
5040 insertfakerow $nullid2 $viewmainheadid($curview)
5041 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5042 if {[commitinview $nullid $curview]} {
5043 removefakerow $nullid
5045 removefakerow $nullid2
5050 proc readdifffiles {fd serial inst} {
5051 global viewmainheadid nullid nullid2 curview
5052 global commitinfo commitdata lserial
5055 if {[gets $fd line] < 0} {
5061 # we only need to see one line and we don't really care what it says...
5064 if {$serial != $lserial} {
5068 if {$isdiff && ![commitinview $nullid $curview]} {
5069 # add the line for the local diff to the graph
5070 set hl [mc "Local uncommitted changes, not checked in to index"]
5071 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5072 set commitdata($nullid) "\n $hl\n"
5073 if {[commitinview $nullid2 $curview]} {
5076 set p $viewmainheadid($curview)
5078 insertfakerow $nullid $p
5079 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5080 removefakerow $nullid
5085 proc nextuse {id row} {
5086 global curview children
5088 if {[info exists children($curview,$id)]} {
5089 foreach kid $children($curview,$id) {
5090 if {![commitinview $kid $curview]} {
5093 if {[rowofcommit $kid] > $row} {
5094 return [rowofcommit $kid]
5098 if {[commitinview $id $curview]} {
5099 return [rowofcommit $id]
5104 proc prevuse {id row} {
5105 global curview children
5108 if {[info exists children($curview,$id)]} {
5109 foreach kid $children($curview,$id) {
5110 if {![commitinview $kid $curview]} break
5111 if {[rowofcommit $kid] < $row} {
5112 set ret [rowofcommit $kid]
5119 proc make_idlist {row} {
5120 global displayorder parentlist uparrowlen downarrowlen mingaplen
5121 global commitidx curview children
5123 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5127 set ra [expr {$row - $downarrowlen}]
5131 set rb [expr {$row + $uparrowlen}]
5132 if {$rb > $commitidx($curview)} {
5133 set rb $commitidx($curview)
5135 make_disporder $r [expr {$rb + 1}]
5137 for {} {$r < $ra} {incr r} {
5138 set nextid [lindex $displayorder [expr {$r + 1}]]
5139 foreach p [lindex $parentlist $r] {
5140 if {$p eq $nextid} continue
5141 set rn [nextuse $p $r]
5143 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5144 lappend ids [list [ordertoken $p] $p]
5148 for {} {$r < $row} {incr r} {
5149 set nextid [lindex $displayorder [expr {$r + 1}]]
5150 foreach p [lindex $parentlist $r] {
5151 if {$p eq $nextid} continue
5152 set rn [nextuse $p $r]
5153 if {$rn < 0 || $rn >= $row} {
5154 lappend ids [list [ordertoken $p] $p]
5158 set id [lindex $displayorder $row]
5159 lappend ids [list [ordertoken $id] $id]
5161 foreach p [lindex $parentlist $r] {
5162 set firstkid [lindex $children($curview,$p) 0]
5163 if {[rowofcommit $firstkid] < $row} {
5164 lappend ids [list [ordertoken $p] $p]
5168 set id [lindex $displayorder $r]
5170 set firstkid [lindex $children($curview,$id) 0]
5171 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5172 lappend ids [list [ordertoken $id] $id]
5177 foreach idx [lsort -unique $ids] {
5178 lappend idlist [lindex $idx 1]
5183 proc rowsequal {a b} {
5184 while {[set i [lsearch -exact $a {}]] >= 0} {
5185 set a [lreplace $a $i $i]
5187 while {[set i [lsearch -exact $b {}]] >= 0} {
5188 set b [lreplace $b $i $i]
5190 return [expr {$a eq $b}]
5193 proc makeupline {id row rend col} {
5194 global rowidlist uparrowlen downarrowlen mingaplen
5196 for {set r $rend} {1} {set r $rstart} {
5197 set rstart [prevuse $id $r]
5198 if {$rstart < 0} return
5199 if {$rstart < $row} break
5201 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5202 set rstart [expr {$rend - $uparrowlen - 1}]
5204 for {set r $rstart} {[incr r] <= $row} {} {
5205 set idlist [lindex $rowidlist $r]
5206 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5207 set col [idcol $idlist $id $col]
5208 lset rowidlist $r [linsert $idlist $col $id]
5214 proc layoutrows {row endrow} {
5215 global rowidlist rowisopt rowfinal displayorder
5216 global uparrowlen downarrowlen maxwidth mingaplen
5217 global children parentlist
5218 global commitidx viewcomplete curview
5220 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5223 set rm1 [expr {$row - 1}]
5224 foreach id [lindex $rowidlist $rm1] {
5229 set final [lindex $rowfinal $rm1]
5231 for {} {$row < $endrow} {incr row} {
5232 set rm1 [expr {$row - 1}]
5233 if {$rm1 < 0 || $idlist eq {}} {
5234 set idlist [make_idlist $row]
5237 set id [lindex $displayorder $rm1]
5238 set col [lsearch -exact $idlist $id]
5239 set idlist [lreplace $idlist $col $col]
5240 foreach p [lindex $parentlist $rm1] {
5241 if {[lsearch -exact $idlist $p] < 0} {
5242 set col [idcol $idlist $p $col]
5243 set idlist [linsert $idlist $col $p]
5244 # if not the first child, we have to insert a line going up
5245 if {$id ne [lindex $children($curview,$p) 0]} {
5246 makeupline $p $rm1 $row $col
5250 set id [lindex $displayorder $row]
5251 if {$row > $downarrowlen} {
5252 set termrow [expr {$row - $downarrowlen - 1}]
5253 foreach p [lindex $parentlist $termrow] {
5254 set i [lsearch -exact $idlist $p]
5255 if {$i < 0} continue
5256 set nr [nextuse $p $termrow]
5257 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5258 set idlist [lreplace $idlist $i $i]
5262 set col [lsearch -exact $idlist $id]
5264 set col [idcol $idlist $id]
5265 set idlist [linsert $idlist $col $id]
5266 if {$children($curview,$id) ne {}} {
5267 makeupline $id $rm1 $row $col
5270 set r [expr {$row + $uparrowlen - 1}]
5271 if {$r < $commitidx($curview)} {
5273 foreach p [lindex $parentlist $r] {
5274 if {[lsearch -exact $idlist $p] >= 0} continue
5275 set fk [lindex $children($curview,$p) 0]
5276 if {[rowofcommit $fk] < $row} {
5277 set x [idcol $idlist $p $x]
5278 set idlist [linsert $idlist $x $p]
5281 if {[incr r] < $commitidx($curview)} {
5282 set p [lindex $displayorder $r]
5283 if {[lsearch -exact $idlist $p] < 0} {
5284 set fk [lindex $children($curview,$p) 0]
5285 if {$fk ne {} && [rowofcommit $fk] < $row} {
5286 set x [idcol $idlist $p $x]
5287 set idlist [linsert $idlist $x $p]
5293 if {$final && !$viewcomplete($curview) &&
5294 $row + $uparrowlen + $mingaplen + $downarrowlen
5295 >= $commitidx($curview)} {
5298 set l [llength $rowidlist]
5300 lappend rowidlist $idlist
5302 lappend rowfinal $final
5303 } elseif {$row < $l} {
5304 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5305 lset rowidlist $row $idlist
5308 lset rowfinal $row $final
5310 set pad [ntimes [expr {$row - $l}] {}]
5311 set rowidlist [concat $rowidlist $pad]
5312 lappend rowidlist $idlist
5313 set rowfinal [concat $rowfinal $pad]
5314 lappend rowfinal $final
5315 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5321 proc changedrow {row} {
5322 global displayorder iddrawn rowisopt need_redisplay
5324 set l [llength $rowisopt]
5326 lset rowisopt $row 0
5327 if {$row + 1 < $l} {
5328 lset rowisopt [expr {$row + 1}] 0
5329 if {$row + 2 < $l} {
5330 lset rowisopt [expr {$row + 2}] 0
5334 set id [lindex $displayorder $row]
5335 if {[info exists iddrawn($id)]} {
5336 set need_redisplay 1
5340 proc insert_pad {row col npad} {
5343 set pad [ntimes $npad {}]
5344 set idlist [lindex $rowidlist $row]
5345 set bef [lrange $idlist 0 [expr {$col - 1}]]
5346 set aft [lrange $idlist $col end]
5347 set i [lsearch -exact $aft {}]
5349 set aft [lreplace $aft $i $i]
5351 lset rowidlist $row [concat $bef $pad $aft]
5355 proc optimize_rows {row col endrow} {
5356 global rowidlist rowisopt displayorder curview children
5361 for {} {$row < $endrow} {incr row; set col 0} {
5362 if {[lindex $rowisopt $row]} continue
5364 set y0 [expr {$row - 1}]
5365 set ym [expr {$row - 2}]
5366 set idlist [lindex $rowidlist $row]
5367 set previdlist [lindex $rowidlist $y0]
5368 if {$idlist eq {} || $previdlist eq {}} continue
5370 set pprevidlist [lindex $rowidlist $ym]
5371 if {$pprevidlist eq {}} continue
5377 for {} {$col < [llength $idlist]} {incr col} {
5378 set id [lindex $idlist $col]
5379 if {[lindex $previdlist $col] eq $id} continue
5384 set x0 [lsearch -exact $previdlist $id]
5385 if {$x0 < 0} continue
5386 set z [expr {$x0 - $col}]
5390 set xm [lsearch -exact $pprevidlist $id]
5392 set z0 [expr {$xm - $x0}]
5396 # if row y0 is the first child of $id then it's not an arrow
5397 if {[lindex $children($curview,$id) 0] ne
5398 [lindex $displayorder $y0]} {
5402 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5403 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5406 # Looking at lines from this row to the previous row,
5407 # make them go straight up if they end in an arrow on
5408 # the previous row; otherwise make them go straight up
5410 if {$z < -1 || ($z < 0 && $isarrow)} {
5411 # Line currently goes left too much;
5412 # insert pads in the previous row, then optimize it
5413 set npad [expr {-1 - $z + $isarrow}]
5414 insert_pad $y0 $x0 $npad
5416 optimize_rows $y0 $x0 $row
5418 set previdlist [lindex $rowidlist $y0]
5419 set x0 [lsearch -exact $previdlist $id]
5420 set z [expr {$x0 - $col}]
5422 set pprevidlist [lindex $rowidlist $ym]
5423 set xm [lsearch -exact $pprevidlist $id]
5424 set z0 [expr {$xm - $x0}]
5426 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5427 # Line currently goes right too much;
5428 # insert pads in this line
5429 set npad [expr {$z - 1 + $isarrow}]
5430 insert_pad $row $col $npad
5431 set idlist [lindex $rowidlist $row]
5433 set z [expr {$x0 - $col}]
5436 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5437 # this line links to its first child on row $row-2
5438 set id [lindex $displayorder $ym]
5439 set xc [lsearch -exact $pprevidlist $id]
5441 set z0 [expr {$xc - $x0}]
5444 # avoid lines jigging left then immediately right
5445 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5446 insert_pad $y0 $x0 1
5448 optimize_rows $y0 $x0 $row
5449 set previdlist [lindex $rowidlist $y0]
5453 # Find the first column that doesn't have a line going right
5454 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5455 set id [lindex $idlist $col]
5456 if {$id eq {}} break
5457 set x0 [lsearch -exact $previdlist $id]
5459 # check if this is the link to the first child
5460 set kid [lindex $displayorder $y0]
5461 if {[lindex $children($curview,$id) 0] eq $kid} {
5462 # it is, work out offset to child
5463 set x0 [lsearch -exact $previdlist $kid]
5466 if {$x0 <= $col} break
5468 # Insert a pad at that column as long as it has a line and
5469 # isn't the last column
5470 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5471 set idlist [linsert $idlist $col {}]
5472 lset rowidlist $row $idlist
5480 global canvx0 linespc
5481 return [expr {$canvx0 + $col * $linespc}]
5485 global canvy0 linespc
5486 return [expr {$canvy0 + $row * $linespc}]
5489 proc linewidth {id} {
5490 global thickerline lthickness
5493 if {[info exists thickerline] && $id eq $thickerline} {
5494 set wid [expr {2 * $lthickness}]
5499 proc rowranges {id} {
5500 global curview children uparrowlen downarrowlen
5503 set kids $children($curview,$id)
5509 foreach child $kids {
5510 if {![commitinview $child $curview]} break
5511 set row [rowofcommit $child]
5512 if {![info exists prev]} {
5513 lappend ret [expr {$row + 1}]
5515 if {$row <= $prevrow} {
5516 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5518 # see if the line extends the whole way from prevrow to row
5519 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5520 [lsearch -exact [lindex $rowidlist \
5521 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5522 # it doesn't, see where it ends
5523 set r [expr {$prevrow + $downarrowlen}]
5524 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5525 while {[incr r -1] > $prevrow &&
5526 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5528 while {[incr r] <= $row &&
5529 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5533 # see where it starts up again
5534 set r [expr {$row - $uparrowlen}]
5535 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5536 while {[incr r] < $row &&
5537 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5539 while {[incr r -1] >= $prevrow &&
5540 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5546 if {$child eq $id} {
5555 proc drawlineseg {id row endrow arrowlow} {
5556 global rowidlist displayorder iddrawn linesegs
5557 global canv colormap linespc curview maxlinelen parentlist
5559 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5560 set le [expr {$row + 1}]
5563 set c [lsearch -exact [lindex $rowidlist $le] $id]
5569 set x [lindex $displayorder $le]
5574 if {[info exists iddrawn($x)] || $le == $endrow} {
5575 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5591 if {[info exists linesegs($id)]} {
5592 set lines $linesegs($id)
5594 set r0 [lindex $li 0]
5596 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5606 set li [lindex $lines [expr {$i-1}]]
5607 set r1 [lindex $li 1]
5608 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5613 set x [lindex $cols [expr {$le - $row}]]
5614 set xp [lindex $cols [expr {$le - 1 - $row}]]
5615 set dir [expr {$xp - $x}]
5617 set ith [lindex $lines $i 2]
5618 set coords [$canv coords $ith]
5619 set ah [$canv itemcget $ith -arrow]
5620 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5621 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5622 if {$x2 ne {} && $x - $x2 == $dir} {
5623 set coords [lrange $coords 0 end-2]
5626 set coords [list [xc $le $x] [yc $le]]
5629 set itl [lindex $lines [expr {$i-1}] 2]
5630 set al [$canv itemcget $itl -arrow]
5631 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5632 } elseif {$arrowlow} {
5633 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5634 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5638 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5639 for {set y $le} {[incr y -1] > $row} {} {
5641 set xp [lindex $cols [expr {$y - 1 - $row}]]
5642 set ndir [expr {$xp - $x}]
5643 if {$dir != $ndir || $xp < 0} {
5644 lappend coords [xc $y $x] [yc $y]
5650 # join parent line to first child
5651 set ch [lindex $displayorder $row]
5652 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5654 puts "oops: drawlineseg: child $ch not on row $row"
5655 } elseif {$xc != $x} {
5656 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5657 set d [expr {int(0.5 * $linespc)}]
5660 set x2 [expr {$x1 - $d}]
5662 set x2 [expr {$x1 + $d}]
5665 set y1 [expr {$y2 + $d}]
5666 lappend coords $x1 $y1 $x2 $y2
5667 } elseif {$xc < $x - 1} {
5668 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5669 } elseif {$xc > $x + 1} {
5670 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5674 lappend coords [xc $row $x] [yc $row]
5676 set xn [xc $row $xp]
5678 lappend coords $xn $yn
5682 set t [$canv create line $coords -width [linewidth $id] \
5683 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5686 set lines [linsert $lines $i [list $row $le $t]]
5688 $canv coords $ith $coords
5689 if {$arrow ne $ah} {
5690 $canv itemconf $ith -arrow $arrow
5692 lset lines $i 0 $row
5695 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5696 set ndir [expr {$xo - $xp}]
5697 set clow [$canv coords $itl]
5698 if {$dir == $ndir} {
5699 set clow [lrange $clow 2 end]
5701 set coords [concat $coords $clow]
5703 lset lines [expr {$i-1}] 1 $le
5705 # coalesce two pieces
5707 set b [lindex $lines [expr {$i-1}] 0]
5708 set e [lindex $lines $i 1]
5709 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5711 $canv coords $itl $coords
5712 if {$arrow ne $al} {
5713 $canv itemconf $itl -arrow $arrow
5717 set linesegs($id) $lines
5721 proc drawparentlinks {id row} {
5722 global rowidlist canv colormap curview parentlist
5723 global idpos linespc
5725 set rowids [lindex $rowidlist $row]
5726 set col [lsearch -exact $rowids $id]
5727 if {$col < 0} return
5728 set olds [lindex $parentlist $row]
5729 set row2 [expr {$row + 1}]
5730 set x [xc $row $col]
5733 set d [expr {int(0.5 * $linespc)}]
5734 set ymid [expr {$y + $d}]
5735 set ids [lindex $rowidlist $row2]
5736 # rmx = right-most X coord used
5739 set i [lsearch -exact $ids $p]
5741 puts "oops, parent $p of $id not in list"
5744 set x2 [xc $row2 $i]
5748 set j [lsearch -exact $rowids $p]
5750 # drawlineseg will do this one for us
5754 # should handle duplicated parents here...
5755 set coords [list $x $y]
5757 # if attaching to a vertical segment, draw a smaller
5758 # slant for visual distinctness
5761 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5763 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5765 } elseif {$i < $col && $i < $j} {
5766 # segment slants towards us already
5767 lappend coords [xc $row $j] $y
5769 if {$i < $col - 1} {
5770 lappend coords [expr {$x2 + $linespc}] $y
5771 } elseif {$i > $col + 1} {
5772 lappend coords [expr {$x2 - $linespc}] $y
5774 lappend coords $x2 $y2
5777 lappend coords $x2 $y2
5779 set t [$canv create line $coords -width [linewidth $p] \
5780 -fill $colormap($p) -tags lines.$p]
5784 if {$rmx > [lindex $idpos($id) 1]} {
5785 lset idpos($id) 1 $rmx
5790 proc drawlines {id} {
5793 $canv itemconf lines.$id -width [linewidth $id]
5796 proc drawcmittext {id row col} {
5797 global linespc canv canv2 canv3 fgcolor curview
5798 global cmitlisted commitinfo rowidlist parentlist
5799 global rowtextx idpos idtags idheads idotherrefs
5800 global linehtag linentag linedtag selectedline
5801 global canvxmax boldids boldnameids fgcolor markedid
5802 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5804 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5805 set listed $cmitlisted($curview,$id)
5806 if {$id eq $nullid} {
5808 } elseif {$id eq $nullid2} {
5810 } elseif {$id eq $mainheadid} {
5813 set ofill [lindex $circlecolors $listed]
5815 set x [xc $row $col]
5817 set orad [expr {$linespc / 3}]
5819 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5820 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5821 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5822 } elseif {$listed == 3} {
5823 # triangle pointing left for left-side commits
5824 set t [$canv create polygon \
5825 [expr {$x - $orad}] $y \
5826 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5827 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5828 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5830 # triangle pointing right for right-side commits
5831 set t [$canv create polygon \
5832 [expr {$x + $orad - 1}] $y \
5833 [expr {$x - $orad}] [expr {$y - $orad}] \
5834 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5835 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5837 set circleitem($row) $t
5839 $canv bind $t <1> {selcanvline {} %x %y}
5840 set rmx [llength [lindex $rowidlist $row]]
5841 set olds [lindex $parentlist $row]
5843 set nextids [lindex $rowidlist [expr {$row + 1}]]
5845 set i [lsearch -exact $nextids $p]
5851 set xt [xc $row $rmx]
5852 set rowtextx($row) $xt
5853 set idpos($id) [list $x $xt $y]
5854 if {[info exists idtags($id)] || [info exists idheads($id)]
5855 || [info exists idotherrefs($id)]} {
5856 set xt [drawtags $id $x $xt $y]
5858 set headline [lindex $commitinfo($id) 0]
5859 set name [lindex $commitinfo($id) 1]
5860 set date [lindex $commitinfo($id) 2]
5861 set date [formatdate $date]
5864 set isbold [ishighlighted $id]
5867 set font mainfontbold
5869 lappend boldnameids $id
5870 set nfont mainfontbold
5873 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5874 -text $headline -font $font -tags text]
5875 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5876 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5877 -text $name -font $nfont -tags text]
5878 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5879 -text $date -font mainfont -tags text]
5880 if {$selectedline == $row} {
5883 if {[info exists markedid] && $markedid eq $id} {
5886 set xr [expr {$xt + [font measure $font $headline]}]
5887 if {$xr > $canvxmax} {
5893 proc drawcmitrow {row} {
5894 global displayorder rowidlist nrows_drawn
5895 global iddrawn markingmatches
5896 global commitinfo numcommits
5897 global filehighlight fhighlights findpattern nhighlights
5898 global hlview vhighlights
5899 global highlight_related rhighlights
5901 if {$row >= $numcommits} return
5903 set id [lindex $displayorder $row]
5904 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5905 askvhighlight $row $id
5907 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5908 askfilehighlight $row $id
5910 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5911 askfindhighlight $row $id
5913 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5914 askrelhighlight $row $id
5916 if {![info exists iddrawn($id)]} {
5917 set col [lsearch -exact [lindex $rowidlist $row] $id]
5919 puts "oops, row $row id $id not in list"
5922 if {![info exists commitinfo($id)]} {
5926 drawcmittext $id $row $col
5930 if {$markingmatches} {
5931 markrowmatches $row $id
5935 proc drawcommits {row {endrow {}}} {
5936 global numcommits iddrawn displayorder curview need_redisplay
5937 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5942 if {$endrow eq {}} {
5945 if {$endrow >= $numcommits} {
5946 set endrow [expr {$numcommits - 1}]
5949 set rl1 [expr {$row - $downarrowlen - 3}]
5953 set ro1 [expr {$row - 3}]
5957 set r2 [expr {$endrow + $uparrowlen + 3}]
5958 if {$r2 > $numcommits} {
5961 for {set r $rl1} {$r < $r2} {incr r} {
5962 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5966 set rl1 [expr {$r + 1}]
5972 optimize_rows $ro1 0 $r2
5973 if {$need_redisplay || $nrows_drawn > 2000} {
5977 # make the lines join to already-drawn rows either side
5978 set r [expr {$row - 1}]
5979 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5982 set er [expr {$endrow + 1}]
5983 if {$er >= $numcommits ||
5984 ![info exists iddrawn([lindex $displayorder $er])]} {
5987 for {} {$r <= $er} {incr r} {
5988 set id [lindex $displayorder $r]
5989 set wasdrawn [info exists iddrawn($id)]
5991 if {$r == $er} break
5992 set nextid [lindex $displayorder [expr {$r + 1}]]
5993 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5994 drawparentlinks $id $r
5996 set rowids [lindex $rowidlist $r]
5997 foreach lid $rowids {
5998 if {$lid eq {}} continue
5999 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6001 # see if this is the first child of any of its parents
6002 foreach p [lindex $parentlist $r] {
6003 if {[lsearch -exact $rowids $p] < 0} {
6004 # make this line extend up to the child
6005 set lineend($p) [drawlineseg $p $r $er 0]
6009 set lineend($lid) [drawlineseg $lid $r $er 1]
6015 proc undolayout {row} {
6016 global uparrowlen mingaplen downarrowlen
6017 global rowidlist rowisopt rowfinal need_redisplay
6019 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6023 if {[llength $rowidlist] > $r} {
6025 set rowidlist [lrange $rowidlist 0 $r]
6026 set rowfinal [lrange $rowfinal 0 $r]
6027 set rowisopt [lrange $rowisopt 0 $r]
6028 set need_redisplay 1
6033 proc drawvisible {} {
6034 global canv linespc curview vrowmod selectedline targetrow targetid
6035 global need_redisplay cscroll numcommits
6037 set fs [$canv yview]
6038 set ymax [lindex [$canv cget -scrollregion] 3]
6039 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6040 set f0 [lindex $fs 0]
6041 set f1 [lindex $fs 1]
6042 set y0 [expr {int($f0 * $ymax)}]
6043 set y1 [expr {int($f1 * $ymax)}]
6045 if {[info exists targetid]} {
6046 if {[commitinview $targetid $curview]} {
6047 set r [rowofcommit $targetid]
6048 if {$r != $targetrow} {
6049 # Fix up the scrollregion and change the scrolling position
6050 # now that our target row has moved.
6051 set diff [expr {($r - $targetrow) * $linespc}]
6054 set ymax [lindex [$canv cget -scrollregion] 3]
6057 set f0 [expr {$y0 / $ymax}]
6058 set f1 [expr {$y1 / $ymax}]
6059 allcanvs yview moveto $f0
6060 $cscroll set $f0 $f1
6061 set need_redisplay 1
6068 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6069 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6070 if {$endrow >= $vrowmod($curview)} {
6071 update_arcrows $curview
6073 if {$selectedline ne {} &&
6074 $row <= $selectedline && $selectedline <= $endrow} {
6075 set targetrow $selectedline
6076 } elseif {[info exists targetid]} {
6077 set targetrow [expr {int(($row + $endrow) / 2)}]
6079 if {[info exists targetrow]} {
6080 if {$targetrow >= $numcommits} {
6081 set targetrow [expr {$numcommits - 1}]
6083 set targetid [commitonrow $targetrow]
6085 drawcommits $row $endrow
6088 proc clear_display {} {
6089 global iddrawn linesegs need_redisplay nrows_drawn
6090 global vhighlights fhighlights nhighlights rhighlights
6091 global linehtag linentag linedtag boldids boldnameids
6094 catch {unset iddrawn}
6095 catch {unset linesegs}
6096 catch {unset linehtag}
6097 catch {unset linentag}
6098 catch {unset linedtag}
6101 catch {unset vhighlights}
6102 catch {unset fhighlights}
6103 catch {unset nhighlights}
6104 catch {unset rhighlights}
6105 set need_redisplay 0
6109 proc findcrossings {id} {
6110 global rowidlist parentlist numcommits displayorder
6114 foreach {s e} [rowranges $id] {
6115 if {$e >= $numcommits} {
6116 set e [expr {$numcommits - 1}]
6118 if {$e <= $s} continue
6119 for {set row $e} {[incr row -1] >= $s} {} {
6120 set x [lsearch -exact [lindex $rowidlist $row] $id]
6122 set olds [lindex $parentlist $row]
6123 set kid [lindex $displayorder $row]
6124 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6125 if {$kidx < 0} continue
6126 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6128 set px [lsearch -exact $nextrow $p]
6129 if {$px < 0} continue
6130 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6131 if {[lsearch -exact $ccross $p] >= 0} continue
6132 if {$x == $px + ($kidx < $px? -1: 1)} {
6134 } elseif {[lsearch -exact $cross $p] < 0} {
6141 return [concat $ccross {{}} $cross]
6144 proc assigncolor {id} {
6145 global colormap colors nextcolor
6146 global parents children children curview
6148 if {[info exists colormap($id)]} return
6149 set ncolors [llength $colors]
6150 if {[info exists children($curview,$id)]} {
6151 set kids $children($curview,$id)
6155 if {[llength $kids] == 1} {
6156 set child [lindex $kids 0]
6157 if {[info exists colormap($child)]
6158 && [llength $parents($curview,$child)] == 1} {
6159 set colormap($id) $colormap($child)
6165 foreach x [findcrossings $id] {
6167 # delimiter between corner crossings and other crossings
6168 if {[llength $badcolors] >= $ncolors - 1} break
6169 set origbad $badcolors
6171 if {[info exists colormap($x)]
6172 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6173 lappend badcolors $colormap($x)
6176 if {[llength $badcolors] >= $ncolors} {
6177 set badcolors $origbad
6179 set origbad $badcolors
6180 if {[llength $badcolors] < $ncolors - 1} {
6181 foreach child $kids {
6182 if {[info exists colormap($child)]
6183 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6184 lappend badcolors $colormap($child)
6186 foreach p $parents($curview,$child) {
6187 if {[info exists colormap($p)]
6188 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6189 lappend badcolors $colormap($p)
6193 if {[llength $badcolors] >= $ncolors} {
6194 set badcolors $origbad
6197 for {set i 0} {$i <= $ncolors} {incr i} {
6198 set c [lindex $colors $nextcolor]
6199 if {[incr nextcolor] >= $ncolors} {
6202 if {[lsearch -exact $badcolors $c]} break
6204 set colormap($id) $c
6207 proc bindline {t id} {
6210 $canv bind $t <Enter> "lineenter %x %y $id"
6211 $canv bind $t <Motion> "linemotion %x %y $id"
6212 $canv bind $t <Leave> "lineleave $id"
6213 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6216 proc drawtags {id x xt y1} {
6217 global idtags idheads idotherrefs mainhead
6218 global linespc lthickness
6219 global canv rowtextx curview fgcolor bgcolor ctxbut
6224 if {[info exists idtags($id)]} {
6225 set marks $idtags($id)
6226 set ntags [llength $marks]
6228 if {[info exists idheads($id)]} {
6229 set marks [concat $marks $idheads($id)]
6230 set nheads [llength $idheads($id)]
6232 if {[info exists idotherrefs($id)]} {
6233 set marks [concat $marks $idotherrefs($id)]
6239 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6240 set yt [expr {$y1 - 0.5 * $linespc}]
6241 set yb [expr {$yt + $linespc - 1}]
6245 foreach tag $marks {
6247 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6248 set wid [font measure mainfontbold $tag]
6250 set wid [font measure mainfont $tag]
6254 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6256 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6257 -width $lthickness -fill black -tags tag.$id]
6259 foreach tag $marks x $xvals wid $wvals {
6260 set xl [expr {$x + $delta}]
6261 set xr [expr {$x + $delta + $wid + $lthickness}]
6263 if {[incr ntags -1] >= 0} {
6265 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6266 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6267 -width 1 -outline black -fill yellow -tags tag.$id]
6268 $canv bind $t <1> [list showtag $tag 1]
6269 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6271 # draw a head or other ref
6272 if {[incr nheads -1] >= 0} {
6274 if {$tag eq $mainhead} {
6275 set font mainfontbold
6280 set xl [expr {$xl - $delta/2}]
6281 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6282 -width 1 -outline black -fill $col -tags tag.$id
6283 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6284 set rwid [font measure mainfont $remoteprefix]
6285 set xi [expr {$x + 1}]
6286 set yti [expr {$yt + 1}]
6287 set xri [expr {$x + $rwid}]
6288 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6289 -width 0 -fill "#ffddaa" -tags tag.$id
6292 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6293 -font $font -tags [list tag.$id text]]
6295 $canv bind $t <1> [list showtag $tag 1]
6296 } elseif {$nheads >= 0} {
6297 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6303 proc xcoord {i level ln} {
6304 global canvx0 xspc1 xspc2
6306 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6307 if {$i > 0 && $i == $level} {
6308 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6309 } elseif {$i > $level} {
6310 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6315 proc show_status {msg} {
6319 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6320 -tags text -fill $fgcolor
6323 # Don't change the text pane cursor if it is currently the hand cursor,
6324 # showing that we are over a sha1 ID link.
6325 proc settextcursor {c} {
6326 global ctext curtextcursor
6328 if {[$ctext cget -cursor] == $curtextcursor} {
6329 $ctext config -cursor $c
6331 set curtextcursor $c
6334 proc nowbusy {what {name {}}} {
6335 global isbusy busyname statusw
6337 if {[array names isbusy] eq {}} {
6338 . config -cursor watch
6342 set busyname($what) $name
6344 $statusw conf -text $name
6348 proc notbusy {what} {
6349 global isbusy maincursor textcursor busyname statusw
6353 if {$busyname($what) ne {} &&
6354 [$statusw cget -text] eq $busyname($what)} {
6355 $statusw conf -text {}
6358 if {[array names isbusy] eq {}} {
6359 . config -cursor $maincursor
6360 settextcursor $textcursor
6364 proc findmatches {f} {
6365 global findtype findstring
6366 if {$findtype == [mc "Regexp"]} {
6367 set matches [regexp -indices -all -inline $findstring $f]
6370 if {$findtype == [mc "IgnCase"]} {
6371 set f [string tolower $f]
6372 set fs [string tolower $fs]
6376 set l [string length $fs]
6377 while {[set j [string first $fs $f $i]] >= 0} {
6378 lappend matches [list $j [expr {$j+$l-1}]]
6379 set i [expr {$j + $l}]
6385 proc dofind {{dirn 1} {wrap 1}} {
6386 global findstring findstartline findcurline selectedline numcommits
6387 global gdttype filehighlight fh_serial find_dirn findallowwrap
6389 if {[info exists find_dirn]} {
6390 if {$find_dirn == $dirn} return
6394 if {$findstring eq {} || $numcommits == 0} return
6395 if {$selectedline eq {}} {
6396 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6398 set findstartline $selectedline
6400 set findcurline $findstartline
6401 nowbusy finding [mc "Searching"]
6402 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6403 after cancel do_file_hl $fh_serial
6404 do_file_hl $fh_serial
6407 set findallowwrap $wrap
6411 proc stopfinding {} {
6412 global find_dirn findcurline fprogcoord
6414 if {[info exists find_dirn]} {
6425 global commitdata commitinfo numcommits findpattern findloc
6426 global findstartline findcurline findallowwrap
6427 global find_dirn gdttype fhighlights fprogcoord
6428 global curview varcorder vrownum varccommits vrowmod
6430 if {![info exists find_dirn]} {
6433 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6436 if {$find_dirn > 0} {
6438 if {$l >= $numcommits} {
6441 if {$l <= $findstartline} {
6442 set lim [expr {$findstartline + 1}]
6445 set moretodo $findallowwrap
6452 if {$l >= $findstartline} {
6453 set lim [expr {$findstartline - 1}]
6456 set moretodo $findallowwrap
6459 set n [expr {($lim - $l) * $find_dirn}]
6464 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6465 update_arcrows $curview
6469 set ai [bsearch $vrownum($curview) $l]
6470 set a [lindex $varcorder($curview) $ai]
6471 set arow [lindex $vrownum($curview) $ai]
6472 set ids [lindex $varccommits($curview,$a)]
6473 set arowend [expr {$arow + [llength $ids]}]
6474 if {$gdttype eq [mc "containing:"]} {
6475 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6476 if {$l < $arow || $l >= $arowend} {
6478 set a [lindex $varcorder($curview) $ai]
6479 set arow [lindex $vrownum($curview) $ai]
6480 set ids [lindex $varccommits($curview,$a)]
6481 set arowend [expr {$arow + [llength $ids]}]
6483 set id [lindex $ids [expr {$l - $arow}]]
6484 # shouldn't happen unless git log doesn't give all the commits...
6485 if {![info exists commitdata($id)] ||
6486 ![doesmatch $commitdata($id)]} {
6489 if {![info exists commitinfo($id)]} {
6492 set info $commitinfo($id)
6493 foreach f $info ty $fldtypes {
6494 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6503 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6504 if {$l < $arow || $l >= $arowend} {
6506 set a [lindex $varcorder($curview) $ai]
6507 set arow [lindex $vrownum($curview) $ai]
6508 set ids [lindex $varccommits($curview,$a)]
6509 set arowend [expr {$arow + [llength $ids]}]
6511 set id [lindex $ids [expr {$l - $arow}]]
6512 if {![info exists fhighlights($id)]} {
6513 # this sets fhighlights($id) to -1
6514 askfilehighlight $l $id
6516 if {$fhighlights($id) > 0} {
6520 if {$fhighlights($id) < 0} {
6523 set findcurline [expr {$l - $find_dirn}]
6528 if {$found || ($domore && !$moretodo)} {
6544 set findcurline [expr {$l - $find_dirn}]
6546 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6550 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6555 proc findselectline {l} {
6556 global findloc commentend ctext findcurline markingmatches gdttype
6558 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6561 if {$markingmatches &&
6562 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6563 # highlight the matches in the comments
6564 set f [$ctext get 1.0 $commentend]
6565 set matches [findmatches $f]
6566 foreach match $matches {
6567 set start [lindex $match 0]
6568 set end [expr {[lindex $match 1] + 1}]
6569 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6575 # mark the bits of a headline or author that match a find string
6576 proc markmatches {canv l str tag matches font row} {
6579 set bbox [$canv bbox $tag]
6580 set x0 [lindex $bbox 0]
6581 set y0 [lindex $bbox 1]
6582 set y1 [lindex $bbox 3]
6583 foreach match $matches {
6584 set start [lindex $match 0]
6585 set end [lindex $match 1]
6586 if {$start > $end} continue
6587 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6588 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6589 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6590 [expr {$x0+$xlen+2}] $y1 \
6591 -outline {} -tags [list match$l matches] -fill yellow]
6593 if {$row == $selectedline} {
6594 $canv raise $t secsel
6599 proc unmarkmatches {} {
6600 global markingmatches
6602 allcanvs delete matches
6603 set markingmatches 0
6607 proc selcanvline {w x y} {
6608 global canv canvy0 ctext linespc
6610 set ymax [lindex [$canv cget -scrollregion] 3]
6611 if {$ymax == {}} return
6612 set yfrac [lindex [$canv yview] 0]
6613 set y [expr {$y + $yfrac * $ymax}]
6614 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6619 set xmax [lindex [$canv cget -scrollregion] 2]
6620 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6621 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6627 proc commit_descriptor {p} {
6629 if {![info exists commitinfo($p)]} {
6633 if {[llength $commitinfo($p)] > 1} {
6634 set l [lindex $commitinfo($p) 0]
6639 # append some text to the ctext widget, and make any SHA1 ID
6640 # that we know about be a clickable link.
6641 proc appendwithlinks {text tags} {
6642 global ctext linknum curview
6644 set start [$ctext index "end - 1c"]
6645 $ctext insert end $text $tags
6646 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6650 set linkid [string range $text $s $e]
6652 $ctext tag delete link$linknum
6653 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6654 setlink $linkid link$linknum
6659 proc setlink {id lk} {
6660 global curview ctext pendinglinks
6663 if {[string length $id] < 40} {
6664 set matches [longid $id]
6665 if {[llength $matches] > 0} {
6666 if {[llength $matches] > 1} return
6668 set id [lindex $matches 0]
6671 set known [commitinview $id $curview]
6674 $ctext tag conf $lk -foreground blue -underline 1
6675 $ctext tag bind $lk <1> [list selbyid $id]
6676 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6677 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6679 lappend pendinglinks($id) $lk
6680 interestedin $id {makelink %P}
6684 proc appendshortlink {id {pre {}} {post {}}} {
6685 global ctext linknum
6687 $ctext insert end $pre
6688 $ctext tag delete link$linknum
6689 $ctext insert end [string range $id 0 7] link$linknum
6690 $ctext insert end $post
6691 setlink $id link$linknum
6695 proc makelink {id} {
6698 if {![info exists pendinglinks($id)]} return
6699 foreach lk $pendinglinks($id) {
6702 unset pendinglinks($id)
6705 proc linkcursor {w inc} {
6706 global linkentercount curtextcursor
6708 if {[incr linkentercount $inc] > 0} {
6709 $w configure -cursor hand2
6711 $w configure -cursor $curtextcursor
6712 if {$linkentercount < 0} {
6713 set linkentercount 0
6718 proc viewnextline {dir} {
6722 set ymax [lindex [$canv cget -scrollregion] 3]
6723 set wnow [$canv yview]
6724 set wtop [expr {[lindex $wnow 0] * $ymax}]
6725 set newtop [expr {$wtop + $dir * $linespc}]
6728 } elseif {$newtop > $ymax} {
6731 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6734 # add a list of tag or branch names at position pos
6735 # returns the number of names inserted
6736 proc appendrefs {pos ids var} {
6737 global ctext linknum curview $var maxrefs
6739 if {[catch {$ctext index $pos}]} {
6742 $ctext conf -state normal
6743 $ctext delete $pos "$pos lineend"
6746 foreach tag [set $var\($id\)] {
6747 lappend tags [list $tag $id]
6750 if {[llength $tags] > $maxrefs} {
6751 $ctext insert $pos "[mc "many"] ([llength $tags])"
6753 set tags [lsort -index 0 -decreasing $tags]
6756 set id [lindex $ti 1]
6759 $ctext tag delete $lk
6760 $ctext insert $pos $sep
6761 $ctext insert $pos [lindex $ti 0] $lk
6766 $ctext conf -state disabled
6767 return [llength $tags]
6770 # called when we have finished computing the nearby tags
6771 proc dispneartags {delay} {
6772 global selectedline currentid showneartags tagphase
6774 if {$selectedline eq {} || !$showneartags} return
6775 after cancel dispnexttag
6777 after 200 dispnexttag
6780 after idle dispnexttag
6785 proc dispnexttag {} {
6786 global selectedline currentid showneartags tagphase ctext
6788 if {$selectedline eq {} || !$showneartags} return
6789 switch -- $tagphase {
6791 set dtags [desctags $currentid]
6793 appendrefs precedes $dtags idtags
6797 set atags [anctags $currentid]
6799 appendrefs follows $atags idtags
6803 set dheads [descheads $currentid]
6804 if {$dheads ne {}} {
6805 if {[appendrefs branch $dheads idheads] > 1
6806 && [$ctext get "branch -3c"] eq "h"} {
6807 # turn "Branch" into "Branches"
6808 $ctext conf -state normal
6809 $ctext insert "branch -2c" "es"
6810 $ctext conf -state disabled
6815 if {[incr tagphase] <= 2} {
6816 after idle dispnexttag
6820 proc make_secsel {id} {
6821 global linehtag linentag linedtag canv canv2 canv3
6823 if {![info exists linehtag($id)]} return
6825 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6826 -tags secsel -fill [$canv cget -selectbackground]]
6828 $canv2 delete secsel
6829 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6830 -tags secsel -fill [$canv2 cget -selectbackground]]
6832 $canv3 delete secsel
6833 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6834 -tags secsel -fill [$canv3 cget -selectbackground]]
6838 proc make_idmark {id} {
6839 global linehtag canv fgcolor
6841 if {![info exists linehtag($id)]} return
6843 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6844 -tags markid -outline $fgcolor]
6848 proc selectline {l isnew {desired_loc {}}} {
6849 global canv ctext commitinfo selectedline
6850 global canvy0 linespc parents children curview
6851 global currentid sha1entry
6852 global commentend idtags linknum
6853 global mergemax numcommits pending_select
6854 global cmitmode showneartags allcommits
6855 global targetrow targetid lastscrollrows
6856 global autoselect jump_to_here
6858 catch {unset pending_select}
6863 if {$l < 0 || $l >= $numcommits} return
6864 set id [commitonrow $l]
6869 if {$lastscrollrows < $numcommits} {
6873 set y [expr {$canvy0 + $l * $linespc}]
6874 set ymax [lindex [$canv cget -scrollregion] 3]
6875 set ytop [expr {$y - $linespc - 1}]
6876 set ybot [expr {$y + $linespc + 1}]
6877 set wnow [$canv yview]
6878 set wtop [expr {[lindex $wnow 0] * $ymax}]
6879 set wbot [expr {[lindex $wnow 1] * $ymax}]
6880 set wh [expr {$wbot - $wtop}]
6882 if {$ytop < $wtop} {
6883 if {$ybot < $wtop} {
6884 set newtop [expr {$y - $wh / 2.0}]
6887 if {$newtop > $wtop - $linespc} {
6888 set newtop [expr {$wtop - $linespc}]
6891 } elseif {$ybot > $wbot} {
6892 if {$ytop > $wbot} {
6893 set newtop [expr {$y - $wh / 2.0}]
6895 set newtop [expr {$ybot - $wh}]
6896 if {$newtop < $wtop + $linespc} {
6897 set newtop [expr {$wtop + $linespc}]
6901 if {$newtop != $wtop} {
6905 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6912 addtohistory [list selbyid $id 0] savecmitpos
6915 $sha1entry delete 0 end
6916 $sha1entry insert 0 $id
6918 $sha1entry selection range 0 end
6922 $ctext conf -state normal
6925 if {![info exists commitinfo($id)]} {
6928 set info $commitinfo($id)
6929 set date [formatdate [lindex $info 2]]
6930 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6931 set date [formatdate [lindex $info 4]]
6932 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6933 if {[info exists idtags($id)]} {
6934 $ctext insert end [mc "Tags:"]
6935 foreach tag $idtags($id) {
6936 $ctext insert end " $tag"
6938 $ctext insert end "\n"
6942 set olds $parents($curview,$id)
6943 if {[llength $olds] > 1} {
6946 if {$np >= $mergemax} {
6951 $ctext insert end "[mc "Parent"]: " $tag
6952 appendwithlinks [commit_descriptor $p] {}
6957 append headers "[mc "Parent"]: [commit_descriptor $p]"
6961 foreach c $children($curview,$id) {
6962 append headers "[mc "Child"]: [commit_descriptor $c]"
6965 # make anything that looks like a SHA1 ID be a clickable link
6966 appendwithlinks $headers {}
6967 if {$showneartags} {
6968 if {![info exists allcommits]} {
6971 $ctext insert end "[mc "Branch"]: "
6972 $ctext mark set branch "end -1c"
6973 $ctext mark gravity branch left
6974 $ctext insert end "\n[mc "Follows"]: "
6975 $ctext mark set follows "end -1c"
6976 $ctext mark gravity follows left
6977 $ctext insert end "\n[mc "Precedes"]: "
6978 $ctext mark set precedes "end -1c"
6979 $ctext mark gravity precedes left
6980 $ctext insert end "\n"
6983 $ctext insert end "\n"
6984 set comment [lindex $info 5]
6985 if {[string first "\r" $comment] >= 0} {
6986 set comment [string map {"\r" "\n "} $comment]
6988 appendwithlinks $comment {comment}
6990 $ctext tag remove found 1.0 end
6991 $ctext conf -state disabled
6992 set commentend [$ctext index "end - 1c"]
6994 set jump_to_here $desired_loc
6995 init_flist [mc "Comments"]
6996 if {$cmitmode eq "tree"} {
6998 } elseif {[llength $olds] <= 1} {
7005 proc selfirstline {} {
7010 proc sellastline {} {
7013 set l [expr {$numcommits - 1}]
7017 proc selnextline {dir} {
7020 if {$selectedline eq {}} return
7021 set l [expr {$selectedline + $dir}]
7026 proc selnextpage {dir} {
7027 global canv linespc selectedline numcommits
7029 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7033 allcanvs yview scroll [expr {$dir * $lpp}] units
7035 if {$selectedline eq {}} return
7036 set l [expr {$selectedline + $dir * $lpp}]
7039 } elseif {$l >= $numcommits} {
7040 set l [expr $numcommits - 1]
7046 proc unselectline {} {
7047 global selectedline currentid
7050 catch {unset currentid}
7051 allcanvs delete secsel
7055 proc reselectline {} {
7058 if {$selectedline ne {}} {
7059 selectline $selectedline 0
7063 proc addtohistory {cmd {saveproc {}}} {
7064 global history historyindex curview
7068 set elt [list $curview $cmd $saveproc {}]
7069 if {$historyindex > 0
7070 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7074 if {$historyindex < [llength $history]} {
7075 set history [lreplace $history $historyindex end $elt]
7077 lappend history $elt
7080 if {$historyindex > 1} {
7081 .tf.bar.leftbut conf -state normal
7083 .tf.bar.leftbut conf -state disabled
7085 .tf.bar.rightbut conf -state disabled
7088 # save the scrolling position of the diff display pane
7089 proc save_position {} {
7090 global historyindex history
7092 if {$historyindex < 1} return
7093 set hi [expr {$historyindex - 1}]
7094 set fn [lindex $history $hi 2]
7096 lset history $hi 3 [eval $fn]
7100 proc unset_posvars {} {
7103 if {[info exists last_posvars]} {
7104 foreach {var val} $last_posvars {
7113 global curview last_posvars
7115 set view [lindex $elt 0]
7116 set cmd [lindex $elt 1]
7117 set pv [lindex $elt 3]
7118 if {$curview != $view} {
7122 foreach {var val} $pv {
7126 set last_posvars $pv
7131 global history historyindex
7134 if {$historyindex > 1} {
7136 incr historyindex -1
7137 godo [lindex $history [expr {$historyindex - 1}]]
7138 .tf.bar.rightbut conf -state normal
7140 if {$historyindex <= 1} {
7141 .tf.bar.leftbut conf -state disabled
7146 global history historyindex
7149 if {$historyindex < [llength $history]} {
7151 set cmd [lindex $history $historyindex]
7154 .tf.bar.leftbut conf -state normal
7156 if {$historyindex >= [llength $history]} {
7157 .tf.bar.rightbut conf -state disabled
7162 global treefilelist treeidlist diffids diffmergeid treepending
7163 global nullid nullid2
7166 catch {unset diffmergeid}
7167 if {![info exists treefilelist($id)]} {
7168 if {![info exists treepending]} {
7169 if {$id eq $nullid} {
7170 set cmd [list | git ls-files]
7171 } elseif {$id eq $nullid2} {
7172 set cmd [list | git ls-files --stage -t]
7174 set cmd [list | git ls-tree -r $id]
7176 if {[catch {set gtf [open $cmd r]}]} {
7180 set treefilelist($id) {}
7181 set treeidlist($id) {}
7182 fconfigure $gtf -blocking 0 -encoding binary
7183 filerun $gtf [list gettreeline $gtf $id]
7190 proc gettreeline {gtf id} {
7191 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7194 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7195 if {$diffids eq $nullid} {
7198 set i [string first "\t" $line]
7199 if {$i < 0} continue
7200 set fname [string range $line [expr {$i+1}] end]
7201 set line [string range $line 0 [expr {$i-1}]]
7202 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7203 set sha1 [lindex $line 2]
7204 lappend treeidlist($id) $sha1
7206 if {[string index $fname 0] eq "\""} {
7207 set fname [lindex $fname 0]
7209 set fname [encoding convertfrom $fname]
7210 lappend treefilelist($id) $fname
7213 return [expr {$nl >= 1000? 2: 1}]
7217 if {$cmitmode ne "tree"} {
7218 if {![info exists diffmergeid]} {
7219 gettreediffs $diffids
7221 } elseif {$id ne $diffids} {
7230 global treefilelist treeidlist diffids nullid nullid2
7231 global ctext_file_names ctext_file_lines
7232 global ctext commentend
7234 set i [lsearch -exact $treefilelist($diffids) $f]
7236 puts "oops, $f not in list for id $diffids"
7239 if {$diffids eq $nullid} {
7240 if {[catch {set bf [open $f r]} err]} {
7241 puts "oops, can't read $f: $err"
7245 set blob [lindex $treeidlist($diffids) $i]
7246 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7247 puts "oops, error reading blob $blob: $err"
7251 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7252 filerun $bf [list getblobline $bf $diffids]
7253 $ctext config -state normal
7254 clear_ctext $commentend
7255 lappend ctext_file_names $f
7256 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7257 $ctext insert end "\n"
7258 $ctext insert end "$f\n" filesep
7259 $ctext config -state disabled
7260 $ctext yview $commentend
7264 proc getblobline {bf id} {
7265 global diffids cmitmode ctext
7267 if {$id ne $diffids || $cmitmode ne "tree"} {
7271 $ctext config -state normal
7273 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7274 $ctext insert end "$line\n"
7277 global jump_to_here ctext_file_names commentend
7279 # delete last newline
7280 $ctext delete "end - 2c" "end - 1c"
7282 if {$jump_to_here ne {} &&
7283 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7284 set lnum [expr {[lindex $jump_to_here 1] +
7285 [lindex [split $commentend .] 0]}]
7286 mark_ctext_line $lnum
7290 $ctext config -state disabled
7291 return [expr {$nl >= 1000? 2: 1}]
7294 proc mark_ctext_line {lnum} {
7295 global ctext markbgcolor
7297 $ctext tag delete omark
7298 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7299 $ctext tag conf omark -background $markbgcolor
7303 proc mergediff {id} {
7305 global diffids treediffs
7306 global parents curview
7310 set treediffs($id) {}
7311 set np [llength $parents($curview,$id)]
7316 proc startdiff {ids} {
7317 global treediffs diffids treepending diffmergeid nullid nullid2
7321 catch {unset diffmergeid}
7322 if {![info exists treediffs($ids)] ||
7323 [lsearch -exact $ids $nullid] >= 0 ||
7324 [lsearch -exact $ids $nullid2] >= 0} {
7325 if {![info exists treepending]} {
7333 proc path_filter {filter name} {
7335 set l [string length $p]
7336 if {[string index $p end] eq "/"} {
7337 if {[string compare -length $l $p $name] == 0} {
7341 if {[string compare -length $l $p $name] == 0 &&
7342 ([string length $name] == $l ||
7343 [string index $name $l] eq "/")} {
7351 proc addtocflist {ids} {
7354 add_flist $treediffs($ids)
7358 proc diffcmd {ids flags} {
7359 global nullid nullid2
7361 set i [lsearch -exact $ids $nullid]
7362 set j [lsearch -exact $ids $nullid2]
7364 if {[llength $ids] > 1 && $j < 0} {
7365 # comparing working directory with some specific revision
7366 set cmd [concat | git diff-index $flags]
7368 lappend cmd -R [lindex $ids 1]
7370 lappend cmd [lindex $ids 0]
7373 # comparing working directory with index
7374 set cmd [concat | git diff-files $flags]
7379 } elseif {$j >= 0} {
7380 set cmd [concat | git diff-index --cached $flags]
7381 if {[llength $ids] > 1} {
7382 # comparing index with specific revision
7384 lappend cmd -R [lindex $ids 1]
7386 lappend cmd [lindex $ids 0]
7389 # comparing index with HEAD
7393 set cmd [concat | git diff-tree -r $flags $ids]
7398 proc gettreediffs {ids} {
7399 global treediff treepending
7401 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7403 set treepending $ids
7405 fconfigure $gdtf -blocking 0 -encoding binary
7406 filerun $gdtf [list gettreediffline $gdtf $ids]
7409 proc gettreediffline {gdtf ids} {
7410 global treediff treediffs treepending diffids diffmergeid
7411 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7416 if {$perfile_attrs} {
7417 # cache_gitattr is slow, and even slower on win32 where we
7418 # have to invoke it for only about 30 paths at a time
7420 if {[tk windowingsystem] == "win32"} {
7424 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7425 set i [string first "\t" $line]
7427 set file [string range $line [expr {$i+1}] end]
7428 if {[string index $file 0] eq "\""} {
7429 set file [lindex $file 0]
7431 set file [encoding convertfrom $file]
7432 if {$file ne [lindex $treediff end]} {
7433 lappend treediff $file
7434 lappend sublist $file
7438 if {$perfile_attrs} {
7439 cache_gitattr encoding $sublist
7442 return [expr {$nr >= $max? 2: 1}]
7445 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7447 foreach f $treediff {
7448 if {[path_filter $vfilelimit($curview) $f]} {
7452 set treediffs($ids) $flist
7454 set treediffs($ids) $treediff
7457 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7459 } elseif {$ids != $diffids} {
7460 if {![info exists diffmergeid]} {
7461 gettreediffs $diffids
7469 # empty string or positive integer
7470 proc diffcontextvalidate {v} {
7471 return [regexp {^(|[1-9][0-9]*)$} $v]
7474 proc diffcontextchange {n1 n2 op} {
7475 global diffcontextstring diffcontext
7477 if {[string is integer -strict $diffcontextstring]} {
7478 if {$diffcontextstring >= 0} {
7479 set diffcontext $diffcontextstring
7485 proc changeignorespace {} {
7489 proc getblobdiffs {ids} {
7490 global blobdifffd diffids env
7491 global diffinhdr treediffs
7494 global limitdiffs vfilelimit curview
7495 global diffencoding targetline diffnparents
7499 if {[package vcompare $git_version "1.6.1"] >= 0} {
7500 set textconv "--textconv"
7502 set cmd [diffcmd $ids "-p $textconv -C --cc --no-commit-id -U$diffcontext"]
7506 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7507 set cmd [concat $cmd -- $vfilelimit($curview)]
7509 if {[catch {set bdf [open $cmd r]} err]} {
7510 error_popup [mc "Error getting diffs: %s" $err]
7516 set diffencoding [get_path_encoding {}]
7517 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7518 set blobdifffd($ids) $bdf
7519 filerun $bdf [list getblobdiffline $bdf $diffids]
7522 proc savecmitpos {} {
7523 global ctext cmitmode
7525 if {$cmitmode eq "tree"} {
7528 return [list target_scrollpos [$ctext index @0,0]]
7531 proc savectextpos {} {
7534 return [list target_scrollpos [$ctext index @0,0]]
7537 proc maybe_scroll_ctext {ateof} {
7538 global ctext target_scrollpos
7540 if {![info exists target_scrollpos]} return
7542 set nlines [expr {[winfo height $ctext]
7543 / [font metrics textfont -linespace]}]
7544 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7546 $ctext yview $target_scrollpos
7547 unset target_scrollpos
7550 proc setinlist {var i val} {
7553 while {[llength [set $var]] < $i} {
7556 if {[llength [set $var]] == $i} {
7563 proc makediffhdr {fname ids} {
7564 global ctext curdiffstart treediffs diffencoding
7565 global ctext_file_names jump_to_here targetline diffline
7567 set fname [encoding convertfrom $fname]
7568 set diffencoding [get_path_encoding $fname]
7569 set i [lsearch -exact $treediffs($ids) $fname]
7571 setinlist difffilestart $i $curdiffstart
7573 lset ctext_file_names end $fname
7574 set l [expr {(78 - [string length $fname]) / 2}]
7575 set pad [string range "----------------------------------------" 1 $l]
7576 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7578 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7579 set targetline [lindex $jump_to_here 1]
7584 proc getblobdiffline {bdf ids} {
7585 global diffids blobdifffd ctext curdiffstart
7586 global diffnexthead diffnextnote difffilestart
7587 global ctext_file_names ctext_file_lines
7588 global diffinhdr treediffs mergemax diffnparents
7589 global diffencoding jump_to_here targetline diffline
7592 $ctext conf -state normal
7593 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7594 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7598 if {![string compare -length 5 "diff " $line]} {
7599 if {![regexp {^diff (--cc|--git) } $line m type]} {
7600 set line [encoding convertfrom $line]
7601 $ctext insert end "$line\n" hunksep
7604 # start of a new file
7606 $ctext insert end "\n"
7607 set curdiffstart [$ctext index "end - 1c"]
7608 lappend ctext_file_names ""
7609 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7610 $ctext insert end "\n" filesep
7612 if {$type eq "--cc"} {
7613 # start of a new file in a merge diff
7614 set fname [string range $line 10 end]
7615 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7616 lappend treediffs($ids) $fname
7617 add_flist [list $fname]
7621 set line [string range $line 11 end]
7622 # If the name hasn't changed the length will be odd,
7623 # the middle char will be a space, and the two bits either
7624 # side will be a/name and b/name, or "a/name" and "b/name".
7625 # If the name has changed we'll get "rename from" and
7626 # "rename to" or "copy from" and "copy to" lines following
7627 # this, and we'll use them to get the filenames.
7628 # This complexity is necessary because spaces in the
7629 # filename(s) don't get escaped.
7630 set l [string length $line]
7631 set i [expr {$l / 2}]
7632 if {!(($l & 1) && [string index $line $i] eq " " &&
7633 [string range $line 2 [expr {$i - 1}]] eq \
7634 [string range $line [expr {$i + 3}] end])} {
7637 # unescape if quoted and chop off the a/ from the front
7638 if {[string index $line 0] eq "\""} {
7639 set fname [string range [lindex $line 0] 2 end]
7641 set fname [string range $line 2 [expr {$i - 1}]]
7644 makediffhdr $fname $ids
7646 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7647 set fname [encoding convertfrom [string range $line 16 end]]
7648 $ctext insert end "\n"
7649 set curdiffstart [$ctext index "end - 1c"]
7650 lappend ctext_file_names $fname
7651 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7652 $ctext insert end "$line\n" filesep
7653 set i [lsearch -exact $treediffs($ids) $fname]
7655 setinlist difffilestart $i $curdiffstart
7658 } elseif {![string compare -length 2 "@@" $line]} {
7659 regexp {^@@+} $line ats
7660 set line [encoding convertfrom $diffencoding $line]
7661 $ctext insert end "$line\n" hunksep
7662 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7665 set diffnparents [expr {[string length $ats] - 1}]
7668 } elseif {$diffinhdr} {
7669 if {![string compare -length 12 "rename from " $line]} {
7670 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7671 if {[string index $fname 0] eq "\""} {
7672 set fname [lindex $fname 0]
7674 set fname [encoding convertfrom $fname]
7675 set i [lsearch -exact $treediffs($ids) $fname]
7677 setinlist difffilestart $i $curdiffstart
7679 } elseif {![string compare -length 10 $line "rename to "] ||
7680 ![string compare -length 8 $line "copy to "]} {
7681 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7682 if {[string index $fname 0] eq "\""} {
7683 set fname [lindex $fname 0]
7685 makediffhdr $fname $ids
7686 } elseif {[string compare -length 3 $line "---"] == 0} {
7689 } elseif {[string compare -length 3 $line "+++"] == 0} {
7693 $ctext insert end "$line\n" filesep
7696 set line [string map {\x1A ^Z} \
7697 [encoding convertfrom $diffencoding $line]]
7698 # parse the prefix - one ' ', '-' or '+' for each parent
7699 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7700 set tag [expr {$diffnparents > 1? "m": "d"}]
7701 if {[string trim $prefix " -+"] eq {}} {
7702 # prefix only has " ", "-" and "+" in it: normal diff line
7703 set num [string first "-" $prefix]
7705 # removed line, first parent with line is $num
7706 if {$num >= $mergemax} {
7709 $ctext insert end "$line\n" $tag$num
7712 if {[string first "+" $prefix] >= 0} {
7714 lappend tags ${tag}result
7715 if {$diffnparents > 1} {
7716 set num [string first " " $prefix]
7718 if {$num >= $mergemax} {
7725 if {$targetline ne {}} {
7726 if {$diffline == $targetline} {
7727 set seehere [$ctext index "end - 1 chars"]
7733 $ctext insert end "$line\n" $tags
7736 # "\ No newline at end of file",
7737 # or something else we don't recognize
7738 $ctext insert end "$line\n" hunksep
7742 if {[info exists seehere]} {
7743 mark_ctext_line [lindex [split $seehere .] 0]
7745 maybe_scroll_ctext [eof $bdf]
7746 $ctext conf -state disabled
7751 return [expr {$nr >= 1000? 2: 1}]
7754 proc changediffdisp {} {
7755 global ctext diffelide
7757 $ctext tag conf d0 -elide [lindex $diffelide 0]
7758 $ctext tag conf dresult -elide [lindex $diffelide 1]
7761 proc highlightfile {loc cline} {
7762 global ctext cflist cflist_top
7765 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7766 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7767 $cflist see $cline.0
7768 set cflist_top $cline
7772 global difffilestart ctext cmitmode
7774 if {$cmitmode eq "tree"} return
7777 set here [$ctext index @0,0]
7778 foreach loc $difffilestart {
7779 if {[$ctext compare $loc >= $here]} {
7780 highlightfile $prev $prevline
7786 highlightfile $prev $prevline
7790 global difffilestart ctext cmitmode
7792 if {$cmitmode eq "tree"} return
7793 set here [$ctext index @0,0]
7795 foreach loc $difffilestart {
7797 if {[$ctext compare $loc > $here]} {
7798 highlightfile $loc $line
7804 proc clear_ctext {{first 1.0}} {
7805 global ctext smarktop smarkbot
7806 global ctext_file_names ctext_file_lines
7809 set l [lindex [split $first .] 0]
7810 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7813 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7816 $ctext delete $first end
7817 if {$first eq "1.0"} {
7818 catch {unset pendinglinks}
7820 set ctext_file_names {}
7821 set ctext_file_lines {}
7824 proc settabs {{firstab {}}} {
7825 global firsttabstop tabstop ctext have_tk85
7827 if {$firstab ne {} && $have_tk85} {
7828 set firsttabstop $firstab
7830 set w [font measure textfont "0"]
7831 if {$firsttabstop != 0} {
7832 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7833 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7834 } elseif {$have_tk85 || $tabstop != 8} {
7835 $ctext conf -tabs [expr {$tabstop * $w}]
7837 $ctext conf -tabs {}
7841 proc incrsearch {name ix op} {
7842 global ctext searchstring searchdirn
7844 $ctext tag remove found 1.0 end
7845 if {[catch {$ctext index anchor}]} {
7846 # no anchor set, use start of selection, or of visible area
7847 set sel [$ctext tag ranges sel]
7849 $ctext mark set anchor [lindex $sel 0]
7850 } elseif {$searchdirn eq "-forwards"} {
7851 $ctext mark set anchor @0,0
7853 $ctext mark set anchor @0,[winfo height $ctext]
7856 if {$searchstring ne {}} {
7857 set here [$ctext search $searchdirn -- $searchstring anchor]
7866 global sstring ctext searchstring searchdirn
7869 $sstring icursor end
7870 set searchdirn -forwards
7871 if {$searchstring ne {}} {
7872 set sel [$ctext tag ranges sel]
7874 set start "[lindex $sel 0] + 1c"
7875 } elseif {[catch {set start [$ctext index anchor]}]} {
7878 set match [$ctext search -count mlen -- $searchstring $start]
7879 $ctext tag remove sel 1.0 end
7885 set mend "$match + $mlen c"
7886 $ctext tag add sel $match $mend
7887 $ctext mark unset anchor
7891 proc dosearchback {} {
7892 global sstring ctext searchstring searchdirn
7895 $sstring icursor end
7896 set searchdirn -backwards
7897 if {$searchstring ne {}} {
7898 set sel [$ctext tag ranges sel]
7900 set start [lindex $sel 0]
7901 } elseif {[catch {set start [$ctext index anchor]}]} {
7902 set start @0,[winfo height $ctext]
7904 set match [$ctext search -backwards -count ml -- $searchstring $start]
7905 $ctext tag remove sel 1.0 end
7911 set mend "$match + $ml c"
7912 $ctext tag add sel $match $mend
7913 $ctext mark unset anchor
7917 proc searchmark {first last} {
7918 global ctext searchstring
7922 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7923 if {$match eq {}} break
7924 set mend "$match + $mlen c"
7925 $ctext tag add found $match $mend
7929 proc searchmarkvisible {doall} {
7930 global ctext smarktop smarkbot
7932 set topline [lindex [split [$ctext index @0,0] .] 0]
7933 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7934 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7935 # no overlap with previous
7936 searchmark $topline $botline
7937 set smarktop $topline
7938 set smarkbot $botline
7940 if {$topline < $smarktop} {
7941 searchmark $topline [expr {$smarktop-1}]
7942 set smarktop $topline
7944 if {$botline > $smarkbot} {
7945 searchmark [expr {$smarkbot+1}] $botline
7946 set smarkbot $botline
7951 proc scrolltext {f0 f1} {
7954 .bleft.bottom.sb set $f0 $f1
7955 if {$searchstring ne {}} {
7961 global linespc charspc canvx0 canvy0
7962 global xspc1 xspc2 lthickness
7964 set linespc [font metrics mainfont -linespace]
7965 set charspc [font measure mainfont "m"]
7966 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7967 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7968 set lthickness [expr {int($linespc / 9) + 1}]
7969 set xspc1(0) $linespc
7977 set ymax [lindex [$canv cget -scrollregion] 3]
7978 if {$ymax eq {} || $ymax == 0} return
7979 set span [$canv yview]
7982 allcanvs yview moveto [lindex $span 0]
7984 if {$selectedline ne {}} {
7985 selectline $selectedline 0
7986 allcanvs yview moveto [lindex $span 0]
7990 proc parsefont {f n} {
7993 set fontattr($f,family) [lindex $n 0]
7995 if {$s eq {} || $s == 0} {
7998 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8000 set fontattr($f,size) $s
8001 set fontattr($f,weight) normal
8002 set fontattr($f,slant) roman
8003 foreach style [lrange $n 2 end] {
8006 "bold" {set fontattr($f,weight) $style}
8008 "italic" {set fontattr($f,slant) $style}
8013 proc fontflags {f {isbold 0}} {
8016 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8017 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8018 -slant $fontattr($f,slant)]
8024 set n [list $fontattr($f,family) $fontattr($f,size)]
8025 if {$fontattr($f,weight) eq "bold"} {
8028 if {$fontattr($f,slant) eq "italic"} {
8034 proc incrfont {inc} {
8035 global mainfont textfont ctext canv cflist showrefstop
8036 global stopped entries fontattr
8039 set s $fontattr(mainfont,size)
8044 set fontattr(mainfont,size) $s
8045 font config mainfont -size $s
8046 font config mainfontbold -size $s
8047 set mainfont [fontname mainfont]
8048 set s $fontattr(textfont,size)
8053 set fontattr(textfont,size) $s
8054 font config textfont -size $s
8055 font config textfontbold -size $s
8056 set textfont [fontname textfont]
8063 global sha1entry sha1string
8064 if {[string length $sha1string] == 40} {
8065 $sha1entry delete 0 end
8069 proc sha1change {n1 n2 op} {
8070 global sha1string currentid sha1but
8071 if {$sha1string == {}
8072 || ([info exists currentid] && $sha1string == $currentid)} {
8077 if {[$sha1but cget -state] == $state} return
8078 if {$state == "normal"} {
8079 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8081 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8085 proc gotocommit {} {
8086 global sha1string tagids headids curview varcid
8088 if {$sha1string == {}
8089 || ([info exists currentid] && $sha1string == $currentid)} return
8090 if {[info exists tagids($sha1string)]} {
8091 set id $tagids($sha1string)
8092 } elseif {[info exists headids($sha1string)]} {
8093 set id $headids($sha1string)
8095 set id [string tolower $sha1string]
8096 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8097 set matches [longid $id]
8098 if {$matches ne {}} {
8099 if {[llength $matches] > 1} {
8100 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8103 set id [lindex $matches 0]
8106 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8107 error_popup [mc "Revision %s is not known" $sha1string]
8112 if {[commitinview $id $curview]} {
8113 selectline [rowofcommit $id] 1
8116 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8117 set msg [mc "SHA1 id %s is not known" $sha1string]
8119 set msg [mc "Revision %s is not in the current view" $sha1string]
8124 proc lineenter {x y id} {
8125 global hoverx hovery hoverid hovertimer
8126 global commitinfo canv
8128 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8132 if {[info exists hovertimer]} {
8133 after cancel $hovertimer
8135 set hovertimer [after 500 linehover]
8139 proc linemotion {x y id} {
8140 global hoverx hovery hoverid hovertimer
8142 if {[info exists hoverid] && $id == $hoverid} {
8145 if {[info exists hovertimer]} {
8146 after cancel $hovertimer
8148 set hovertimer [after 500 linehover]
8152 proc lineleave {id} {
8153 global hoverid hovertimer canv
8155 if {[info exists hoverid] && $id == $hoverid} {
8157 if {[info exists hovertimer]} {
8158 after cancel $hovertimer
8166 global hoverx hovery hoverid hovertimer
8167 global canv linespc lthickness
8170 set text [lindex $commitinfo($hoverid) 0]
8171 set ymax [lindex [$canv cget -scrollregion] 3]
8172 if {$ymax == {}} return
8173 set yfrac [lindex [$canv yview] 0]
8174 set x [expr {$hoverx + 2 * $linespc}]
8175 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8176 set x0 [expr {$x - 2 * $lthickness}]
8177 set y0 [expr {$y - 2 * $lthickness}]
8178 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8179 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8180 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8181 -fill \#ffff80 -outline black -width 1 -tags hover]
8183 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8188 proc clickisonarrow {id y} {
8191 set ranges [rowranges $id]
8192 set thresh [expr {2 * $lthickness + 6}]
8193 set n [expr {[llength $ranges] - 1}]
8194 for {set i 1} {$i < $n} {incr i} {
8195 set row [lindex $ranges $i]
8196 if {abs([yc $row] - $y) < $thresh} {
8203 proc arrowjump {id n y} {
8206 # 1 <-> 2, 3 <-> 4, etc...
8207 set n [expr {(($n - 1) ^ 1) + 1}]
8208 set row [lindex [rowranges $id] $n]
8210 set ymax [lindex [$canv cget -scrollregion] 3]
8211 if {$ymax eq {} || $ymax <= 0} return
8212 set view [$canv yview]
8213 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8214 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8218 allcanvs yview moveto $yfrac
8221 proc lineclick {x y id isnew} {
8222 global ctext commitinfo children canv thickerline curview
8224 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8229 # draw this line thicker than normal
8233 set ymax [lindex [$canv cget -scrollregion] 3]
8234 if {$ymax eq {}} return
8235 set yfrac [lindex [$canv yview] 0]
8236 set y [expr {$y + $yfrac * $ymax}]
8238 set dirn [clickisonarrow $id $y]
8240 arrowjump $id $dirn $y
8245 addtohistory [list lineclick $x $y $id 0] savectextpos
8247 # fill the details pane with info about this line
8248 $ctext conf -state normal
8251 $ctext insert end "[mc "Parent"]:\t"
8252 $ctext insert end $id link0
8254 set info $commitinfo($id)
8255 $ctext insert end "\n\t[lindex $info 0]\n"
8256 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8257 set date [formatdate [lindex $info 2]]
8258 $ctext insert end "\t[mc "Date"]:\t$date\n"
8259 set kids $children($curview,$id)
8261 $ctext insert end "\n[mc "Children"]:"
8263 foreach child $kids {
8265 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8266 set info $commitinfo($child)
8267 $ctext insert end "\n\t"
8268 $ctext insert end $child link$i
8269 setlink $child link$i
8270 $ctext insert end "\n\t[lindex $info 0]"
8271 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8272 set date [formatdate [lindex $info 2]]
8273 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8276 maybe_scroll_ctext 1
8277 $ctext conf -state disabled
8281 proc normalline {} {
8283 if {[info exists thickerline]} {
8290 proc selbyid {id {isnew 1}} {
8292 if {[commitinview $id $curview]} {
8293 selectline [rowofcommit $id] $isnew
8299 if {![info exists startmstime]} {
8300 set startmstime [clock clicks -milliseconds]
8302 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8305 proc rowmenu {x y id} {
8306 global rowctxmenu selectedline rowmenuid curview
8307 global nullid nullid2 fakerowmenu mainhead markedid
8311 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8316 if {$id ne $nullid && $id ne $nullid2} {
8317 set menu $rowctxmenu
8318 if {$mainhead ne {}} {
8319 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8321 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8323 if {[info exists markedid] && $markedid ne $id} {
8324 $menu entryconfigure 9 -state normal
8325 $menu entryconfigure 10 -state normal
8326 $menu entryconfigure 11 -state normal
8328 $menu entryconfigure 9 -state disabled
8329 $menu entryconfigure 10 -state disabled
8330 $menu entryconfigure 11 -state disabled
8333 set menu $fakerowmenu
8335 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8336 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8337 $menu entryconfigure [mca "Make patch"] -state $state
8338 tk_popup $menu $x $y
8342 global rowmenuid markedid canv
8344 set markedid $rowmenuid
8345 make_idmark $markedid
8351 if {[info exists markedid]} {
8356 proc replace_by_kids {l r} {
8357 global curview children
8359 set id [commitonrow $r]
8360 set l [lreplace $l 0 0]
8361 foreach kid $children($curview,$id) {
8362 lappend l [rowofcommit $kid]
8364 return [lsort -integer -decreasing -unique $l]
8367 proc find_common_desc {} {
8368 global markedid rowmenuid curview children
8370 if {![info exists markedid]} return
8371 if {![commitinview $markedid $curview] ||
8372 ![commitinview $rowmenuid $curview]} return
8373 #set t1 [clock clicks -milliseconds]
8374 set l1 [list [rowofcommit $markedid]]
8375 set l2 [list [rowofcommit $rowmenuid]]
8377 set r1 [lindex $l1 0]
8378 set r2 [lindex $l2 0]
8379 if {$r1 eq {} || $r2 eq {}} break
8385 set l1 [replace_by_kids $l1 $r1]
8387 set l2 [replace_by_kids $l2 $r2]
8390 #set t2 [clock clicks -milliseconds]
8391 #puts "took [expr {$t2-$t1}]ms"
8394 proc compare_commits {} {
8395 global markedid rowmenuid curview children
8397 if {![info exists markedid]} return
8398 if {![commitinview $markedid $curview]} return
8399 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8400 do_cmp_commits $markedid $rowmenuid
8403 proc getpatchid {id} {
8406 if {![info exists patchids($id)]} {
8407 set cmd [diffcmd [list $id] {-p --root}]
8408 # trim off the initial "|"
8409 set cmd [lrange $cmd 1 end]
8411 set x [eval exec $cmd | git patch-id]
8412 set patchids($id) [lindex $x 0]
8414 set patchids($id) "error"
8417 return $patchids($id)
8420 proc do_cmp_commits {a b} {
8421 global ctext curview parents children patchids commitinfo
8423 $ctext conf -state normal
8426 for {set i 0} {$i < 100} {incr i} {
8429 if {[llength $parents($curview,$a)] > 1} {
8430 appendshortlink $a [mc "Skipping merge commit "] "\n"
8433 set patcha [getpatchid $a]
8435 if {[llength $parents($curview,$b)] > 1} {
8436 appendshortlink $b [mc "Skipping merge commit "] "\n"
8439 set patchb [getpatchid $b]
8441 if {!$skipa && !$skipb} {
8442 set heada [lindex $commitinfo($a) 0]
8443 set headb [lindex $commitinfo($b) 0]
8444 if {$patcha eq "error"} {
8445 appendshortlink $a [mc "Error getting patch ID for "] \
8446 [mc " - stopping\n"]
8449 if {$patchb eq "error"} {
8450 appendshortlink $b [mc "Error getting patch ID for "] \
8451 [mc " - stopping\n"]
8454 if {$patcha eq $patchb} {
8455 if {$heada eq $headb} {
8456 appendshortlink $a [mc "Commit "]
8457 appendshortlink $b " == " " $heada\n"
8459 appendshortlink $a [mc "Commit "] " $heada\n"
8460 appendshortlink $b [mc " is the same patch as\n "] \
8466 $ctext insert end "\n"
8467 appendshortlink $a [mc "Commit "] " $heada\n"
8468 appendshortlink $b [mc " differs from\n "] \
8470 $ctext insert end [mc "Diff of commits:\n\n"]
8471 $ctext conf -state disabled
8478 set kids [real_children $curview,$a]
8479 if {[llength $kids] != 1} {
8480 $ctext insert end "\n"
8481 appendshortlink $a [mc "Commit "] \
8482 [mc " has %s children - stopping\n" [llength $kids]]
8485 set a [lindex $kids 0]
8488 set kids [real_children $curview,$b]
8489 if {[llength $kids] != 1} {
8490 appendshortlink $b [mc "Commit "] \
8491 [mc " has %s children - stopping\n" [llength $kids]]
8494 set b [lindex $kids 0]
8497 $ctext conf -state disabled
8500 proc diffcommits {a b} {
8501 global diffcontext diffids blobdifffd diffinhdr
8503 set tmpdir [gitknewtmpdir]
8504 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8505 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8507 exec git diff-tree -p --pretty $a >$fna
8508 exec git diff-tree -p --pretty $b >$fnb
8510 error_popup [mc "Error writing commit to file: %s" $err]
8514 set fd [open "| diff -U$diffcontext $fna $fnb" r]
8516 error_popup [mc "Error diffing commits: %s" $err]
8519 set diffids [list commits $a $b]
8520 set blobdifffd($diffids) $fd
8522 filerun $fd [list getblobdiffline $fd $diffids]
8525 proc diffvssel {dirn} {
8526 global rowmenuid selectedline
8528 if {$selectedline eq {}} return
8530 set oldid [commitonrow $selectedline]
8531 set newid $rowmenuid
8533 set oldid $rowmenuid
8534 set newid [commitonrow $selectedline]
8536 addtohistory [list doseldiff $oldid $newid] savectextpos
8537 doseldiff $oldid $newid
8540 proc doseldiff {oldid newid} {
8544 $ctext conf -state normal
8546 init_flist [mc "Top"]
8547 $ctext insert end "[mc "From"] "
8548 $ctext insert end $oldid link0
8549 setlink $oldid link0
8550 $ctext insert end "\n "
8551 $ctext insert end [lindex $commitinfo($oldid) 0]
8552 $ctext insert end "\n\n[mc "To"] "
8553 $ctext insert end $newid link1
8554 setlink $newid link1
8555 $ctext insert end "\n "
8556 $ctext insert end [lindex $commitinfo($newid) 0]
8557 $ctext insert end "\n"
8558 $ctext conf -state disabled
8559 $ctext tag remove found 1.0 end
8560 startdiff [list $oldid $newid]
8564 global rowmenuid currentid commitinfo patchtop patchnum NS
8566 if {![info exists currentid]} return
8567 set oldid $currentid
8568 set oldhead [lindex $commitinfo($oldid) 0]
8569 set newid $rowmenuid
8570 set newhead [lindex $commitinfo($newid) 0]
8573 catch {destroy $top}
8575 make_transient $top .
8576 ${NS}::label $top.title -text [mc "Generate patch"]
8577 grid $top.title - -pady 10
8578 ${NS}::label $top.from -text [mc "From:"]
8579 ${NS}::entry $top.fromsha1 -width 40
8580 $top.fromsha1 insert 0 $oldid
8581 $top.fromsha1 conf -state readonly
8582 grid $top.from $top.fromsha1 -sticky w
8583 ${NS}::entry $top.fromhead -width 60
8584 $top.fromhead insert 0 $oldhead
8585 $top.fromhead conf -state readonly
8586 grid x $top.fromhead -sticky w
8587 ${NS}::label $top.to -text [mc "To:"]
8588 ${NS}::entry $top.tosha1 -width 40
8589 $top.tosha1 insert 0 $newid
8590 $top.tosha1 conf -state readonly
8591 grid $top.to $top.tosha1 -sticky w
8592 ${NS}::entry $top.tohead -width 60
8593 $top.tohead insert 0 $newhead
8594 $top.tohead conf -state readonly
8595 grid x $top.tohead -sticky w
8596 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8597 grid $top.rev x -pady 10 -padx 5
8598 ${NS}::label $top.flab -text [mc "Output file:"]
8599 ${NS}::entry $top.fname -width 60
8600 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8602 grid $top.flab $top.fname -sticky w
8603 ${NS}::frame $top.buts
8604 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8605 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8606 bind $top <Key-Return> mkpatchgo
8607 bind $top <Key-Escape> mkpatchcan
8608 grid $top.buts.gen $top.buts.can
8609 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8610 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8611 grid $top.buts - -pady 10 -sticky ew
8615 proc mkpatchrev {} {
8618 set oldid [$patchtop.fromsha1 get]
8619 set oldhead [$patchtop.fromhead get]
8620 set newid [$patchtop.tosha1 get]
8621 set newhead [$patchtop.tohead get]
8622 foreach e [list fromsha1 fromhead tosha1 tohead] \
8623 v [list $newid $newhead $oldid $oldhead] {
8624 $patchtop.$e conf -state normal
8625 $patchtop.$e delete 0 end
8626 $patchtop.$e insert 0 $v
8627 $patchtop.$e conf -state readonly
8632 global patchtop nullid nullid2
8634 set oldid [$patchtop.fromsha1 get]
8635 set newid [$patchtop.tosha1 get]
8636 set fname [$patchtop.fname get]
8637 set cmd [diffcmd [list $oldid $newid] -p]
8638 # trim off the initial "|"
8639 set cmd [lrange $cmd 1 end]
8640 lappend cmd >$fname &
8641 if {[catch {eval exec $cmd} err]} {
8642 error_popup "[mc "Error creating patch:"] $err" $patchtop
8644 catch {destroy $patchtop}
8648 proc mkpatchcan {} {
8651 catch {destroy $patchtop}
8656 global rowmenuid mktagtop commitinfo NS
8660 catch {destroy $top}
8662 make_transient $top .
8663 ${NS}::label $top.title -text [mc "Create tag"]
8664 grid $top.title - -pady 10
8665 ${NS}::label $top.id -text [mc "ID:"]
8666 ${NS}::entry $top.sha1 -width 40
8667 $top.sha1 insert 0 $rowmenuid
8668 $top.sha1 conf -state readonly
8669 grid $top.id $top.sha1 -sticky w
8670 ${NS}::entry $top.head -width 60
8671 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8672 $top.head conf -state readonly
8673 grid x $top.head -sticky w
8674 ${NS}::label $top.tlab -text [mc "Tag name:"]
8675 ${NS}::entry $top.tag -width 60
8676 grid $top.tlab $top.tag -sticky w
8677 ${NS}::frame $top.buts
8678 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8679 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8680 bind $top <Key-Return> mktaggo
8681 bind $top <Key-Escape> mktagcan
8682 grid $top.buts.gen $top.buts.can
8683 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8684 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8685 grid $top.buts - -pady 10 -sticky ew
8690 global mktagtop env tagids idtags
8692 set id [$mktagtop.sha1 get]
8693 set tag [$mktagtop.tag get]
8695 error_popup [mc "No tag name specified"] $mktagtop
8698 if {[info exists tagids($tag)]} {
8699 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8703 exec git tag $tag $id
8705 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8709 set tagids($tag) $id
8710 lappend idtags($id) $tag
8718 proc redrawtags {id} {
8719 global canv linehtag idpos currentid curview cmitlisted markedid
8720 global canvxmax iddrawn circleitem mainheadid circlecolors
8722 if {![commitinview $id $curview]} return
8723 if {![info exists iddrawn($id)]} return
8724 set row [rowofcommit $id]
8725 if {$id eq $mainheadid} {
8728 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8730 $canv itemconf $circleitem($row) -fill $ofill
8731 $canv delete tag.$id
8732 set xt [eval drawtags $id $idpos($id)]
8733 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8734 set text [$canv itemcget $linehtag($id) -text]
8735 set font [$canv itemcget $linehtag($id) -font]
8736 set xr [expr {$xt + [font measure $font $text]}]
8737 if {$xr > $canvxmax} {
8741 if {[info exists currentid] && $currentid == $id} {
8744 if {[info exists markedid] && $markedid eq $id} {
8752 catch {destroy $mktagtop}
8757 if {![domktag]} return
8761 proc writecommit {} {
8762 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8764 set top .writecommit
8766 catch {destroy $top}
8768 make_transient $top .
8769 ${NS}::label $top.title -text [mc "Write commit to file"]
8770 grid $top.title - -pady 10
8771 ${NS}::label $top.id -text [mc "ID:"]
8772 ${NS}::entry $top.sha1 -width 40
8773 $top.sha1 insert 0 $rowmenuid
8774 $top.sha1 conf -state readonly
8775 grid $top.id $top.sha1 -sticky w
8776 ${NS}::entry $top.head -width 60
8777 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8778 $top.head conf -state readonly
8779 grid x $top.head -sticky w
8780 ${NS}::label $top.clab -text [mc "Command:"]
8781 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8782 grid $top.clab $top.cmd -sticky w -pady 10
8783 ${NS}::label $top.flab -text [mc "Output file:"]
8784 ${NS}::entry $top.fname -width 60
8785 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8786 grid $top.flab $top.fname -sticky w
8787 ${NS}::frame $top.buts
8788 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8789 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8790 bind $top <Key-Return> wrcomgo
8791 bind $top <Key-Escape> wrcomcan
8792 grid $top.buts.gen $top.buts.can
8793 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8794 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8795 grid $top.buts - -pady 10 -sticky ew
8802 set id [$wrcomtop.sha1 get]
8803 set cmd "echo $id | [$wrcomtop.cmd get]"
8804 set fname [$wrcomtop.fname get]
8805 if {[catch {exec sh -c $cmd >$fname &} err]} {
8806 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8808 catch {destroy $wrcomtop}
8815 catch {destroy $wrcomtop}
8820 global rowmenuid mkbrtop NS
8823 catch {destroy $top}
8825 make_transient $top .
8826 ${NS}::label $top.title -text [mc "Create new branch"]
8827 grid $top.title - -pady 10
8828 ${NS}::label $top.id -text [mc "ID:"]
8829 ${NS}::entry $top.sha1 -width 40
8830 $top.sha1 insert 0 $rowmenuid
8831 $top.sha1 conf -state readonly
8832 grid $top.id $top.sha1 -sticky w
8833 ${NS}::label $top.nlab -text [mc "Name:"]
8834 ${NS}::entry $top.name -width 40
8835 grid $top.nlab $top.name -sticky w
8836 ${NS}::frame $top.buts
8837 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8838 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8839 bind $top <Key-Return> [list mkbrgo $top]
8840 bind $top <Key-Escape> "catch {destroy $top}"
8841 grid $top.buts.go $top.buts.can
8842 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8843 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8844 grid $top.buts - -pady 10 -sticky ew
8849 global headids idheads
8851 set name [$top.name get]
8852 set id [$top.sha1 get]
8856 error_popup [mc "Please specify a name for the new branch"] $top
8859 if {[info exists headids($name)]} {
8860 if {![confirm_popup [mc \
8861 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8864 set old_id $headids($name)
8867 catch {destroy $top}
8868 lappend cmdargs $name $id
8872 eval exec git branch $cmdargs
8878 if {$old_id ne {}} {
8884 set headids($name) $id
8885 lappend idheads($id) $name
8894 proc exec_citool {tool_args {baseid {}}} {
8895 global commitinfo env
8897 set save_env [array get env GIT_AUTHOR_*]
8899 if {$baseid ne {}} {
8900 if {![info exists commitinfo($baseid)]} {
8903 set author [lindex $commitinfo($baseid) 1]
8904 set date [lindex $commitinfo($baseid) 2]
8905 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8906 $author author name email]
8908 set env(GIT_AUTHOR_NAME) $name
8909 set env(GIT_AUTHOR_EMAIL) $email
8910 set env(GIT_AUTHOR_DATE) $date
8914 eval exec git citool $tool_args &
8916 array unset env GIT_AUTHOR_*
8917 array set env $save_env
8920 proc cherrypick {} {
8921 global rowmenuid curview
8922 global mainhead mainheadid
8924 set oldhead [exec git rev-parse HEAD]
8925 set dheads [descheads $rowmenuid]
8926 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8927 set ok [confirm_popup [mc "Commit %s is already\
8928 included in branch %s -- really re-apply it?" \
8929 [string range $rowmenuid 0 7] $mainhead]]
8932 nowbusy cherrypick [mc "Cherry-picking"]
8934 # Unfortunately git-cherry-pick writes stuff to stderr even when
8935 # no error occurs, and exec takes that as an indication of error...
8936 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8939 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8941 error_popup [mc "Cherry-pick failed because of local changes\
8942 to file '%s'.\nPlease commit, reset or stash\
8943 your changes and try again." $fname]
8944 } elseif {[regexp -line \
8945 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8947 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8948 conflict.\nDo you wish to run git citool to\
8950 # Force citool to read MERGE_MSG
8951 file delete [file join [gitdir] "GITGUI_MSG"]
8952 exec_citool {} $rowmenuid
8960 set newhead [exec git rev-parse HEAD]
8961 if {$newhead eq $oldhead} {
8963 error_popup [mc "No changes committed"]
8966 addnewchild $newhead $oldhead
8967 if {[commitinview $oldhead $curview]} {
8968 # XXX this isn't right if we have a path limit...
8969 insertrow $newhead $oldhead $curview
8970 if {$mainhead ne {}} {
8971 movehead $newhead $mainhead
8972 movedhead $newhead $mainhead
8974 set mainheadid $newhead
8983 global mainhead rowmenuid confirm_ok resettype NS
8986 set w ".confirmreset"
8989 wm title $w [mc "Confirm reset"]
8990 ${NS}::label $w.m -text \
8991 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
8992 pack $w.m -side top -fill x -padx 20 -pady 20
8993 ${NS}::labelframe $w.f -text [mc "Reset type:"]
8995 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
8996 -text [mc "Soft: Leave working tree and index untouched"]
8997 grid $w.f.soft -sticky w
8998 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
8999 -text [mc "Mixed: Leave working tree untouched, reset index"]
9000 grid $w.f.mixed -sticky w
9001 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9002 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9003 grid $w.f.hard -sticky w
9004 pack $w.f -side top -fill x -padx 4
9005 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9006 pack $w.ok -side left -fill x -padx 20 -pady 20
9007 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9008 bind $w <Key-Escape> [list destroy $w]
9009 pack $w.cancel -side right -fill x -padx 20 -pady 20
9010 bind $w <Visibility> "grab $w; focus $w"
9012 if {!$confirm_ok} return
9013 if {[catch {set fd [open \
9014 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9018 filerun $fd [list readresetstat $fd]
9019 nowbusy reset [mc "Resetting"]
9024 proc readresetstat {fd} {
9025 global mainhead mainheadid showlocalchanges rprogcoord
9027 if {[gets $fd line] >= 0} {
9028 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9029 set rprogcoord [expr {1.0 * $m / $n}]
9037 if {[catch {close $fd} err]} {
9040 set oldhead $mainheadid
9041 set newhead [exec git rev-parse HEAD]
9042 if {$newhead ne $oldhead} {
9043 movehead $newhead $mainhead
9044 movedhead $newhead $mainhead
9045 set mainheadid $newhead
9049 if {$showlocalchanges} {
9055 # context menu for a head
9056 proc headmenu {x y id head} {
9057 global headmenuid headmenuhead headctxmenu mainhead
9061 set headmenuhead $head
9063 if {$head eq $mainhead} {
9066 $headctxmenu entryconfigure 0 -state $state
9067 $headctxmenu entryconfigure 1 -state $state
9068 tk_popup $headctxmenu $x $y
9072 global headmenuid headmenuhead headids
9073 global showlocalchanges
9075 # check the tree is clean first??
9076 nowbusy checkout [mc "Checking out"]
9080 set fd [open [list | git checkout $headmenuhead 2>@1] r]
9084 if {$showlocalchanges} {
9088 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9092 proc readcheckoutstat {fd newhead newheadid} {
9093 global mainhead mainheadid headids showlocalchanges progresscoords
9094 global viewmainheadid curview
9096 if {[gets $fd line] >= 0} {
9097 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9098 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9103 set progresscoords {0 0}
9106 if {[catch {close $fd} err]} {
9109 set oldmainid $mainheadid
9110 set mainhead $newhead
9111 set mainheadid $newheadid
9112 set viewmainheadid($curview) $newheadid
9113 redrawtags $oldmainid
9114 redrawtags $newheadid
9116 if {$showlocalchanges} {
9122 global headmenuid headmenuhead mainhead
9125 set head $headmenuhead
9127 # this check shouldn't be needed any more...
9128 if {$head eq $mainhead} {
9129 error_popup [mc "Cannot delete the currently checked-out branch"]
9132 set dheads [descheads $id]
9133 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9134 # the stuff on this branch isn't on any other branch
9135 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9136 branch.\nReally delete branch %s?" $head $head]]} return
9140 if {[catch {exec git branch -D $head} err]} {
9145 removehead $id $head
9146 removedhead $id $head
9153 # Display a list of tags and heads
9155 global showrefstop bgcolor fgcolor selectbgcolor NS
9156 global bglist fglist reflistfilter reflist maincursor
9159 set showrefstop $top
9160 if {[winfo exists $top]} {
9166 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9167 make_transient $top .
9168 text $top.list -background $bgcolor -foreground $fgcolor \
9169 -selectbackground $selectbgcolor -font mainfont \
9170 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9171 -width 30 -height 20 -cursor $maincursor \
9172 -spacing1 1 -spacing3 1 -state disabled
9173 $top.list tag configure highlight -background $selectbgcolor
9174 lappend bglist $top.list
9175 lappend fglist $top.list
9176 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9177 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9178 grid $top.list $top.ysb -sticky nsew
9179 grid $top.xsb x -sticky ew
9181 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9182 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9183 set reflistfilter "*"
9184 trace add variable reflistfilter write reflistfilter_change
9185 pack $top.f.e -side right -fill x -expand 1
9186 pack $top.f.l -side left
9187 grid $top.f - -sticky ew -pady 2
9188 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9189 bind $top <Key-Escape> [list destroy $top]
9191 grid columnconfigure $top 0 -weight 1
9192 grid rowconfigure $top 0 -weight 1
9193 bind $top.list <1> {break}
9194 bind $top.list <B1-Motion> {break}
9195 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9200 proc sel_reflist {w x y} {
9201 global showrefstop reflist headids tagids otherrefids
9203 if {![winfo exists $showrefstop]} return
9204 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9205 set ref [lindex $reflist [expr {$l-1}]]
9206 set n [lindex $ref 0]
9207 switch -- [lindex $ref 1] {
9208 "H" {selbyid $headids($n)}
9209 "T" {selbyid $tagids($n)}
9210 "o" {selbyid $otherrefids($n)}
9212 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9215 proc unsel_reflist {} {
9218 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9219 $showrefstop.list tag remove highlight 0.0 end
9222 proc reflistfilter_change {n1 n2 op} {
9223 global reflistfilter
9225 after cancel refill_reflist
9226 after 200 refill_reflist
9229 proc refill_reflist {} {
9230 global reflist reflistfilter showrefstop headids tagids otherrefids
9233 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9235 foreach n [array names headids] {
9236 if {[string match $reflistfilter $n]} {
9237 if {[commitinview $headids($n) $curview]} {
9238 lappend refs [list $n H]
9240 interestedin $headids($n) {run refill_reflist}
9244 foreach n [array names tagids] {
9245 if {[string match $reflistfilter $n]} {
9246 if {[commitinview $tagids($n) $curview]} {
9247 lappend refs [list $n T]
9249 interestedin $tagids($n) {run refill_reflist}
9253 foreach n [array names otherrefids] {
9254 if {[string match $reflistfilter $n]} {
9255 if {[commitinview $otherrefids($n) $curview]} {
9256 lappend refs [list $n o]
9258 interestedin $otherrefids($n) {run refill_reflist}
9262 set refs [lsort -index 0 $refs]
9263 if {$refs eq $reflist} return
9265 # Update the contents of $showrefstop.list according to the
9266 # differences between $reflist (old) and $refs (new)
9267 $showrefstop.list conf -state normal
9268 $showrefstop.list insert end "\n"
9271 while {$i < [llength $reflist] || $j < [llength $refs]} {
9272 if {$i < [llength $reflist]} {
9273 if {$j < [llength $refs]} {
9274 set cmp [string compare [lindex $reflist $i 0] \
9275 [lindex $refs $j 0]]
9277 set cmp [string compare [lindex $reflist $i 1] \
9278 [lindex $refs $j 1]]
9288 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9296 set l [expr {$j + 1}]
9297 $showrefstop.list image create $l.0 -align baseline \
9298 -image reficon-[lindex $refs $j 1] -padx 2
9299 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9305 # delete last newline
9306 $showrefstop.list delete end-2c end-1c
9307 $showrefstop.list conf -state disabled
9310 # Stuff for finding nearby tags
9311 proc getallcommits {} {
9312 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9313 global idheads idtags idotherrefs allparents tagobjid
9315 if {![info exists allcommits]} {
9321 set allccache [file join [gitdir] "gitk.cache"]
9323 set f [open $allccache r]
9332 set cmd [list | git rev-list --parents]
9333 set allcupdate [expr {$seeds ne {}}]
9337 set refs [concat [array names idheads] [array names idtags] \
9338 [array names idotherrefs]]
9341 foreach name [array names tagobjid] {
9342 lappend tagobjs $tagobjid($name)
9344 foreach id [lsort -unique $refs] {
9345 if {![info exists allparents($id)] &&
9346 [lsearch -exact $tagobjs $id] < 0} {
9357 set fd [open [concat $cmd $ids] r]
9358 fconfigure $fd -blocking 0
9361 filerun $fd [list getallclines $fd]
9367 # Since most commits have 1 parent and 1 child, we group strings of
9368 # such commits into "arcs" joining branch/merge points (BMPs), which
9369 # are commits that either don't have 1 parent or don't have 1 child.
9371 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9372 # arcout(id) - outgoing arcs for BMP
9373 # arcids(a) - list of IDs on arc including end but not start
9374 # arcstart(a) - BMP ID at start of arc
9375 # arcend(a) - BMP ID at end of arc
9376 # growing(a) - arc a is still growing
9377 # arctags(a) - IDs out of arcids (excluding end) that have tags
9378 # archeads(a) - IDs out of arcids (excluding end) that have heads
9379 # The start of an arc is at the descendent end, so "incoming" means
9380 # coming from descendents, and "outgoing" means going towards ancestors.
9382 proc getallclines {fd} {
9383 global allparents allchildren idtags idheads nextarc
9384 global arcnos arcids arctags arcout arcend arcstart archeads growing
9385 global seeds allcommits cachedarcs allcupdate
9388 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9389 set id [lindex $line 0]
9390 if {[info exists allparents($id)]} {
9395 set olds [lrange $line 1 end]
9396 set allparents($id) $olds
9397 if {![info exists allchildren($id)]} {
9398 set allchildren($id) {}
9403 if {[llength $olds] == 1 && [llength $a] == 1} {
9404 lappend arcids($a) $id
9405 if {[info exists idtags($id)]} {
9406 lappend arctags($a) $id
9408 if {[info exists idheads($id)]} {
9409 lappend archeads($a) $id
9411 if {[info exists allparents($olds)]} {
9412 # seen parent already
9413 if {![info exists arcout($olds)]} {
9416 lappend arcids($a) $olds
9417 set arcend($a) $olds
9420 lappend allchildren($olds) $id
9421 lappend arcnos($olds) $a
9425 foreach a $arcnos($id) {
9426 lappend arcids($a) $id
9433 lappend allchildren($p) $id
9434 set a [incr nextarc]
9435 set arcstart($a) $id
9442 if {[info exists allparents($p)]} {
9443 # seen it already, may need to make a new branch
9444 if {![info exists arcout($p)]} {
9447 lappend arcids($a) $p
9451 lappend arcnos($p) $a
9456 global cached_dheads cached_dtags cached_atags
9457 catch {unset cached_dheads}
9458 catch {unset cached_dtags}
9459 catch {unset cached_atags}
9462 return [expr {$nid >= 1000? 2: 1}]
9466 fconfigure $fd -blocking 1
9469 # got an error reading the list of commits
9470 # if we were updating, try rereading the whole thing again
9476 error_popup "[mc "Error reading commit topology information;\
9477 branch and preceding/following tag information\
9478 will be incomplete."]\n($err)"
9481 if {[incr allcommits -1] == 0} {
9491 proc recalcarc {a} {
9492 global arctags archeads arcids idtags idheads
9496 foreach id [lrange $arcids($a) 0 end-1] {
9497 if {[info exists idtags($id)]} {
9500 if {[info exists idheads($id)]} {
9505 set archeads($a) $ah
9509 global arcnos arcids nextarc arctags archeads idtags idheads
9510 global arcstart arcend arcout allparents growing
9513 if {[llength $a] != 1} {
9514 puts "oops splitarc called but [llength $a] arcs already"
9518 set i [lsearch -exact $arcids($a) $p]
9520 puts "oops splitarc $p not in arc $a"
9523 set na [incr nextarc]
9524 if {[info exists arcend($a)]} {
9525 set arcend($na) $arcend($a)
9527 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9528 set j [lsearch -exact $arcnos($l) $a]
9529 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9531 set tail [lrange $arcids($a) [expr {$i+1}] end]
9532 set arcids($a) [lrange $arcids($a) 0 $i]
9534 set arcstart($na) $p
9536 set arcids($na) $tail
9537 if {[info exists growing($a)]} {
9543 if {[llength $arcnos($id)] == 1} {
9546 set j [lsearch -exact $arcnos($id) $a]
9547 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9551 # reconstruct tags and heads lists
9552 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9557 set archeads($na) {}
9561 # Update things for a new commit added that is a child of one
9562 # existing commit. Used when cherry-picking.
9563 proc addnewchild {id p} {
9564 global allparents allchildren idtags nextarc
9565 global arcnos arcids arctags arcout arcend arcstart archeads growing
9566 global seeds allcommits
9568 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9569 set allparents($id) [list $p]
9570 set allchildren($id) {}
9573 lappend allchildren($p) $id
9574 set a [incr nextarc]
9575 set arcstart($a) $id
9578 set arcids($a) [list $p]
9580 if {![info exists arcout($p)]} {
9583 lappend arcnos($p) $a
9584 set arcout($id) [list $a]
9587 # This implements a cache for the topology information.
9588 # The cache saves, for each arc, the start and end of the arc,
9589 # the ids on the arc, and the outgoing arcs from the end.
9590 proc readcache {f} {
9591 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9592 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9597 if {$lim - $a > 500} {
9598 set lim [expr {$a + 500}]
9602 # finish reading the cache and setting up arctags, etc.
9604 if {$line ne "1"} {error "bad final version"}
9606 foreach id [array names idtags] {
9607 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9608 [llength $allparents($id)] == 1} {
9609 set a [lindex $arcnos($id) 0]
9610 if {$arctags($a) eq {}} {
9615 foreach id [array names idheads] {
9616 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9617 [llength $allparents($id)] == 1} {
9618 set a [lindex $arcnos($id) 0]
9619 if {$archeads($a) eq {}} {
9624 foreach id [lsort -unique $possible_seeds] {
9625 if {$arcnos($id) eq {}} {
9631 while {[incr a] <= $lim} {
9633 if {[llength $line] != 3} {error "bad line"}
9634 set s [lindex $line 0]
9636 lappend arcout($s) $a
9637 if {![info exists arcnos($s)]} {
9638 lappend possible_seeds $s
9641 set e [lindex $line 1]
9646 if {![info exists arcout($e)]} {
9650 set arcids($a) [lindex $line 2]
9651 foreach id $arcids($a) {
9652 lappend allparents($s) $id
9654 lappend arcnos($id) $a
9656 if {![info exists allparents($s)]} {
9657 set allparents($s) {}
9662 set nextarc [expr {$a - 1}]
9675 global nextarc cachedarcs possible_seeds
9679 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9680 # make sure it's an integer
9681 set cachedarcs [expr {int([lindex $line 1])}]
9682 if {$cachedarcs < 0} {error "bad number of arcs"}
9684 set possible_seeds {}
9692 proc dropcache {err} {
9693 global allcwait nextarc cachedarcs seeds
9695 #puts "dropping cache ($err)"
9696 foreach v {arcnos arcout arcids arcstart arcend growing \
9697 arctags archeads allparents allchildren} {
9708 proc writecache {f} {
9709 global cachearc cachedarcs allccache
9710 global arcstart arcend arcnos arcids arcout
9714 if {$lim - $a > 1000} {
9715 set lim [expr {$a + 1000}]
9718 while {[incr a] <= $lim} {
9719 if {[info exists arcend($a)]} {
9720 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9722 puts $f [list $arcstart($a) {} $arcids($a)]
9727 catch {file delete $allccache}
9728 #puts "writing cache failed ($err)"
9731 set cachearc [expr {$a - 1}]
9732 if {$a > $cachedarcs} {
9741 global nextarc cachedarcs cachearc allccache
9743 if {$nextarc == $cachedarcs} return
9745 set cachedarcs $nextarc
9747 set f [open $allccache w]
9748 puts $f [list 1 $cachedarcs]
9753 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9754 # or 0 if neither is true.
9755 proc anc_or_desc {a b} {
9756 global arcout arcstart arcend arcnos cached_isanc
9758 if {$arcnos($a) eq $arcnos($b)} {
9759 # Both are on the same arc(s); either both are the same BMP,
9760 # or if one is not a BMP, the other is also not a BMP or is
9761 # the BMP at end of the arc (and it only has 1 incoming arc).
9762 # Or both can be BMPs with no incoming arcs.
9763 if {$a eq $b || $arcnos($a) eq {}} {
9766 # assert {[llength $arcnos($a)] == 1}
9767 set arc [lindex $arcnos($a) 0]
9768 set i [lsearch -exact $arcids($arc) $a]
9769 set j [lsearch -exact $arcids($arc) $b]
9770 if {$i < 0 || $i > $j} {
9777 if {![info exists arcout($a)]} {
9778 set arc [lindex $arcnos($a) 0]
9779 if {[info exists arcend($arc)]} {
9780 set aend $arcend($arc)
9784 set a $arcstart($arc)
9788 if {![info exists arcout($b)]} {
9789 set arc [lindex $arcnos($b) 0]
9790 if {[info exists arcend($arc)]} {
9791 set bend $arcend($arc)
9795 set b $arcstart($arc)
9805 if {[info exists cached_isanc($a,$bend)]} {
9806 if {$cached_isanc($a,$bend)} {
9810 if {[info exists cached_isanc($b,$aend)]} {
9811 if {$cached_isanc($b,$aend)} {
9814 if {[info exists cached_isanc($a,$bend)]} {
9819 set todo [list $a $b]
9822 for {set i 0} {$i < [llength $todo]} {incr i} {
9823 set x [lindex $todo $i]
9824 if {$anc($x) eq {}} {
9827 foreach arc $arcnos($x) {
9828 set xd $arcstart($arc)
9830 set cached_isanc($a,$bend) 1
9831 set cached_isanc($b,$aend) 0
9833 } elseif {$xd eq $aend} {
9834 set cached_isanc($b,$aend) 1
9835 set cached_isanc($a,$bend) 0
9838 if {![info exists anc($xd)]} {
9839 set anc($xd) $anc($x)
9841 } elseif {$anc($xd) ne $anc($x)} {
9846 set cached_isanc($a,$bend) 0
9847 set cached_isanc($b,$aend) 0
9851 # This identifies whether $desc has an ancestor that is
9852 # a growing tip of the graph and which is not an ancestor of $anc
9853 # and returns 0 if so and 1 if not.
9854 # If we subsequently discover a tag on such a growing tip, and that
9855 # turns out to be a descendent of $anc (which it could, since we
9856 # don't necessarily see children before parents), then $desc
9857 # isn't a good choice to display as a descendent tag of
9858 # $anc (since it is the descendent of another tag which is
9859 # a descendent of $anc). Similarly, $anc isn't a good choice to
9860 # display as a ancestor tag of $desc.
9862 proc is_certain {desc anc} {
9863 global arcnos arcout arcstart arcend growing problems
9866 if {[llength $arcnos($anc)] == 1} {
9867 # tags on the same arc are certain
9868 if {$arcnos($desc) eq $arcnos($anc)} {
9871 if {![info exists arcout($anc)]} {
9872 # if $anc is partway along an arc, use the start of the arc instead
9873 set a [lindex $arcnos($anc) 0]
9874 set anc $arcstart($a)
9877 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9880 set a [lindex $arcnos($desc) 0]
9886 set anclist [list $x]
9890 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9891 set x [lindex $anclist $i]
9896 foreach a $arcout($x) {
9897 if {[info exists growing($a)]} {
9898 if {![info exists growanc($x)] && $dl($x)} {
9904 if {[info exists dl($y)]} {
9908 if {![info exists done($y)]} {
9911 if {[info exists growanc($x)]} {
9915 for {set k 0} {$k < [llength $xl]} {incr k} {
9916 set z [lindex $xl $k]
9917 foreach c $arcout($z) {
9918 if {[info exists arcend($c)]} {
9920 if {[info exists dl($v)] && $dl($v)} {
9922 if {![info exists done($v)]} {
9925 if {[info exists growanc($v)]} {
9935 } elseif {$y eq $anc || !$dl($x)} {
9946 foreach x [array names growanc] {
9955 proc validate_arctags {a} {
9956 global arctags idtags
9960 foreach id $arctags($a) {
9962 if {![info exists idtags($id)]} {
9963 set na [lreplace $na $i $i]
9970 proc validate_archeads {a} {
9971 global archeads idheads
9974 set na $archeads($a)
9975 foreach id $archeads($a) {
9977 if {![info exists idheads($id)]} {
9978 set na [lreplace $na $i $i]
9982 set archeads($a) $na
9985 # Return the list of IDs that have tags that are descendents of id,
9986 # ignoring IDs that are descendents of IDs already reported.
9987 proc desctags {id} {
9988 global arcnos arcstart arcids arctags idtags allparents
9989 global growing cached_dtags
9991 if {![info exists allparents($id)]} {
9994 set t1 [clock clicks -milliseconds]
9996 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9997 # part-way along an arc; check that arc first
9998 set a [lindex $arcnos($id) 0]
9999 if {$arctags($a) ne {}} {
10000 validate_arctags $a
10001 set i [lsearch -exact $arcids($a) $id]
10003 foreach t $arctags($a) {
10004 set j [lsearch -exact $arcids($a) $t]
10005 if {$j >= $i} break
10012 set id $arcstart($a)
10013 if {[info exists idtags($id)]} {
10017 if {[info exists cached_dtags($id)]} {
10018 return $cached_dtags($id)
10022 set todo [list $id]
10025 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10026 set id [lindex $todo $i]
10028 set ta [info exists hastaggedancestor($id)]
10032 # ignore tags on starting node
10033 if {!$ta && $i > 0} {
10034 if {[info exists idtags($id)]} {
10035 set tagloc($id) $id
10037 } elseif {[info exists cached_dtags($id)]} {
10038 set tagloc($id) $cached_dtags($id)
10042 foreach a $arcnos($id) {
10043 set d $arcstart($a)
10044 if {!$ta && $arctags($a) ne {}} {
10045 validate_arctags $a
10046 if {$arctags($a) ne {}} {
10047 lappend tagloc($id) [lindex $arctags($a) end]
10050 if {$ta || $arctags($a) ne {}} {
10051 set tomark [list $d]
10052 for {set j 0} {$j < [llength $tomark]} {incr j} {
10053 set dd [lindex $tomark $j]
10054 if {![info exists hastaggedancestor($dd)]} {
10055 if {[info exists done($dd)]} {
10056 foreach b $arcnos($dd) {
10057 lappend tomark $arcstart($b)
10059 if {[info exists tagloc($dd)]} {
10062 } elseif {[info exists queued($dd)]} {
10065 set hastaggedancestor($dd) 1
10069 if {![info exists queued($d)]} {
10072 if {![info exists hastaggedancestor($d)]} {
10079 foreach id [array names tagloc] {
10080 if {![info exists hastaggedancestor($id)]} {
10081 foreach t $tagloc($id) {
10082 if {[lsearch -exact $tags $t] < 0} {
10088 set t2 [clock clicks -milliseconds]
10091 # remove tags that are descendents of other tags
10092 for {set i 0} {$i < [llength $tags]} {incr i} {
10093 set a [lindex $tags $i]
10094 for {set j 0} {$j < $i} {incr j} {
10095 set b [lindex $tags $j]
10096 set r [anc_or_desc $a $b]
10098 set tags [lreplace $tags $j $j]
10101 } elseif {$r == -1} {
10102 set tags [lreplace $tags $i $i]
10109 if {[array names growing] ne {}} {
10110 # graph isn't finished, need to check if any tag could get
10111 # eclipsed by another tag coming later. Simply ignore any
10112 # tags that could later get eclipsed.
10115 if {[is_certain $t $origid]} {
10119 if {$tags eq $ctags} {
10120 set cached_dtags($origid) $tags
10125 set cached_dtags($origid) $tags
10127 set t3 [clock clicks -milliseconds]
10128 if {0 && $t3 - $t1 >= 100} {
10129 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10130 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10135 proc anctags {id} {
10136 global arcnos arcids arcout arcend arctags idtags allparents
10137 global growing cached_atags
10139 if {![info exists allparents($id)]} {
10142 set t1 [clock clicks -milliseconds]
10144 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10145 # part-way along an arc; check that arc first
10146 set a [lindex $arcnos($id) 0]
10147 if {$arctags($a) ne {}} {
10148 validate_arctags $a
10149 set i [lsearch -exact $arcids($a) $id]
10150 foreach t $arctags($a) {
10151 set j [lsearch -exact $arcids($a) $t]
10157 if {![info exists arcend($a)]} {
10161 if {[info exists idtags($id)]} {
10165 if {[info exists cached_atags($id)]} {
10166 return $cached_atags($id)
10170 set todo [list $id]
10174 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10175 set id [lindex $todo $i]
10177 set td [info exists hastaggeddescendent($id)]
10181 # ignore tags on starting node
10182 if {!$td && $i > 0} {
10183 if {[info exists idtags($id)]} {
10184 set tagloc($id) $id
10186 } elseif {[info exists cached_atags($id)]} {
10187 set tagloc($id) $cached_atags($id)
10191 foreach a $arcout($id) {
10192 if {!$td && $arctags($a) ne {}} {
10193 validate_arctags $a
10194 if {$arctags($a) ne {}} {
10195 lappend tagloc($id) [lindex $arctags($a) 0]
10198 if {![info exists arcend($a)]} continue
10200 if {$td || $arctags($a) ne {}} {
10201 set tomark [list $d]
10202 for {set j 0} {$j < [llength $tomark]} {incr j} {
10203 set dd [lindex $tomark $j]
10204 if {![info exists hastaggeddescendent($dd)]} {
10205 if {[info exists done($dd)]} {
10206 foreach b $arcout($dd) {
10207 if {[info exists arcend($b)]} {
10208 lappend tomark $arcend($b)
10211 if {[info exists tagloc($dd)]} {
10214 } elseif {[info exists queued($dd)]} {
10217 set hastaggeddescendent($dd) 1
10221 if {![info exists queued($d)]} {
10224 if {![info exists hastaggeddescendent($d)]} {
10230 set t2 [clock clicks -milliseconds]
10233 foreach id [array names tagloc] {
10234 if {![info exists hastaggeddescendent($id)]} {
10235 foreach t $tagloc($id) {
10236 if {[lsearch -exact $tags $t] < 0} {
10243 # remove tags that are ancestors of other tags
10244 for {set i 0} {$i < [llength $tags]} {incr i} {
10245 set a [lindex $tags $i]
10246 for {set j 0} {$j < $i} {incr j} {
10247 set b [lindex $tags $j]
10248 set r [anc_or_desc $a $b]
10250 set tags [lreplace $tags $j $j]
10253 } elseif {$r == 1} {
10254 set tags [lreplace $tags $i $i]
10261 if {[array names growing] ne {}} {
10262 # graph isn't finished, need to check if any tag could get
10263 # eclipsed by another tag coming later. Simply ignore any
10264 # tags that could later get eclipsed.
10267 if {[is_certain $origid $t]} {
10271 if {$tags eq $ctags} {
10272 set cached_atags($origid) $tags
10277 set cached_atags($origid) $tags
10279 set t3 [clock clicks -milliseconds]
10280 if {0 && $t3 - $t1 >= 100} {
10281 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10282 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10287 # Return the list of IDs that have heads that are descendents of id,
10288 # including id itself if it has a head.
10289 proc descheads {id} {
10290 global arcnos arcstart arcids archeads idheads cached_dheads
10293 if {![info exists allparents($id)]} {
10297 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10298 # part-way along an arc; check it first
10299 set a [lindex $arcnos($id) 0]
10300 if {$archeads($a) ne {}} {
10301 validate_archeads $a
10302 set i [lsearch -exact $arcids($a) $id]
10303 foreach t $archeads($a) {
10304 set j [lsearch -exact $arcids($a) $t]
10309 set id $arcstart($a)
10312 set todo [list $id]
10315 for {set i 0} {$i < [llength $todo]} {incr i} {
10316 set id [lindex $todo $i]
10317 if {[info exists cached_dheads($id)]} {
10318 set ret [concat $ret $cached_dheads($id)]
10320 if {[info exists idheads($id)]} {
10323 foreach a $arcnos($id) {
10324 if {$archeads($a) ne {}} {
10325 validate_archeads $a
10326 if {$archeads($a) ne {}} {
10327 set ret [concat $ret $archeads($a)]
10330 set d $arcstart($a)
10331 if {![info exists seen($d)]} {
10338 set ret [lsort -unique $ret]
10339 set cached_dheads($origid) $ret
10340 return [concat $ret $aret]
10343 proc addedtag {id} {
10344 global arcnos arcout cached_dtags cached_atags
10346 if {![info exists arcnos($id)]} return
10347 if {![info exists arcout($id)]} {
10348 recalcarc [lindex $arcnos($id) 0]
10350 catch {unset cached_dtags}
10351 catch {unset cached_atags}
10354 proc addedhead {hid head} {
10355 global arcnos arcout cached_dheads
10357 if {![info exists arcnos($hid)]} return
10358 if {![info exists arcout($hid)]} {
10359 recalcarc [lindex $arcnos($hid) 0]
10361 catch {unset cached_dheads}
10364 proc removedhead {hid head} {
10365 global cached_dheads
10367 catch {unset cached_dheads}
10370 proc movedhead {hid head} {
10371 global arcnos arcout cached_dheads
10373 if {![info exists arcnos($hid)]} return
10374 if {![info exists arcout($hid)]} {
10375 recalcarc [lindex $arcnos($hid) 0]
10377 catch {unset cached_dheads}
10380 proc changedrefs {} {
10381 global cached_dheads cached_dtags cached_atags
10382 global arctags archeads arcnos arcout idheads idtags
10384 foreach id [concat [array names idheads] [array names idtags]] {
10385 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10386 set a [lindex $arcnos($id) 0]
10387 if {![info exists donearc($a)]} {
10393 catch {unset cached_dtags}
10394 catch {unset cached_atags}
10395 catch {unset cached_dheads}
10398 proc rereadrefs {} {
10399 global idtags idheads idotherrefs mainheadid
10401 set refids [concat [array names idtags] \
10402 [array names idheads] [array names idotherrefs]]
10403 foreach id $refids {
10404 if {![info exists ref($id)]} {
10405 set ref($id) [listrefs $id]
10408 set oldmainhead $mainheadid
10411 set refids [lsort -unique [concat $refids [array names idtags] \
10412 [array names idheads] [array names idotherrefs]]]
10413 foreach id $refids {
10414 set v [listrefs $id]
10415 if {![info exists ref($id)] || $ref($id) != $v} {
10419 if {$oldmainhead ne $mainheadid} {
10420 redrawtags $oldmainhead
10421 redrawtags $mainheadid
10426 proc listrefs {id} {
10427 global idtags idheads idotherrefs
10430 if {[info exists idtags($id)]} {
10434 if {[info exists idheads($id)]} {
10435 set y $idheads($id)
10438 if {[info exists idotherrefs($id)]} {
10439 set z $idotherrefs($id)
10441 return [list $x $y $z]
10444 proc showtag {tag isnew} {
10445 global ctext tagcontents tagids linknum tagobjid
10448 addtohistory [list showtag $tag 0] savectextpos
10450 $ctext conf -state normal
10454 if {![info exists tagcontents($tag)]} {
10456 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
10459 if {[info exists tagcontents($tag)]} {
10460 set text $tagcontents($tag)
10462 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10464 appendwithlinks $text {}
10466 $ctext conf -state disabled
10478 if {[info exists gitktmpdir]} {
10479 catch {file delete -force $gitktmpdir}
10483 proc mkfontdisp {font top which} {
10484 global fontattr fontpref $font NS use_ttk
10486 set fontpref($font) [set $font]
10487 ${NS}::button $top.${font}but -text $which \
10488 -command [list choosefont $font $which]
10489 if {!$use_ttk} {$top.${font}but configure -font optionfont}
10490 ${NS}::label $top.$font -relief flat -font $font \
10491 -text $fontattr($font,family) -justify left
10492 grid x $top.${font}but $top.$font -sticky w
10495 proc choosefont {font which} {
10496 global fontparam fontlist fonttop fontattr
10499 set fontparam(which) $which
10500 set fontparam(font) $font
10501 set fontparam(family) [font actual $font -family]
10502 set fontparam(size) $fontattr($font,size)
10503 set fontparam(weight) $fontattr($font,weight)
10504 set fontparam(slant) $fontattr($font,slant)
10507 if {![winfo exists $top]} {
10509 eval font config sample [font actual $font]
10511 make_transient $top $prefstop
10512 wm title $top [mc "Gitk font chooser"]
10513 ${NS}::label $top.l -textvariable fontparam(which)
10514 pack $top.l -side top
10515 set fontlist [lsort [font families]]
10516 ${NS}::frame $top.f
10517 listbox $top.f.fam -listvariable fontlist \
10518 -yscrollcommand [list $top.f.sb set]
10519 bind $top.f.fam <<ListboxSelect>> selfontfam
10520 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10521 pack $top.f.sb -side right -fill y
10522 pack $top.f.fam -side left -fill both -expand 1
10523 pack $top.f -side top -fill both -expand 1
10524 ${NS}::frame $top.g
10525 spinbox $top.g.size -from 4 -to 40 -width 4 \
10526 -textvariable fontparam(size) \
10527 -validatecommand {string is integer -strict %s}
10528 checkbutton $top.g.bold -padx 5 \
10529 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10530 -variable fontparam(weight) -onvalue bold -offvalue normal
10531 checkbutton $top.g.ital -padx 5 \
10532 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10533 -variable fontparam(slant) -onvalue italic -offvalue roman
10534 pack $top.g.size $top.g.bold $top.g.ital -side left
10535 pack $top.g -side top
10536 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10538 $top.c create text 100 25 -anchor center -text $which -font sample \
10539 -fill black -tags text
10540 bind $top.c <Configure> [list centertext $top.c]
10541 pack $top.c -side top -fill x
10542 ${NS}::frame $top.buts
10543 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10544 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10545 bind $top <Key-Return> fontok
10546 bind $top <Key-Escape> fontcan
10547 grid $top.buts.ok $top.buts.can
10548 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10549 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10550 pack $top.buts -side bottom -fill x
10551 trace add variable fontparam write chg_fontparam
10554 $top.c itemconf text -text $which
10556 set i [lsearch -exact $fontlist $fontparam(family)]
10558 $top.f.fam selection set $i
10563 proc centertext {w} {
10564 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10568 global fontparam fontpref prefstop
10570 set f $fontparam(font)
10571 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10572 if {$fontparam(weight) eq "bold"} {
10573 lappend fontpref($f) "bold"
10575 if {$fontparam(slant) eq "italic"} {
10576 lappend fontpref($f) "italic"
10579 $w conf -text $fontparam(family) -font $fontpref($f)
10585 global fonttop fontparam
10587 if {[info exists fonttop]} {
10588 catch {destroy $fonttop}
10589 catch {font delete sample}
10595 if {[package vsatisfies [package provide Tk] 8.6]} {
10596 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10597 # function to make use of it.
10598 proc choosefont {font which} {
10599 tk fontchooser configure -title $which -font $font \
10600 -command [list on_choosefont $font $which]
10601 tk fontchooser show
10603 proc on_choosefont {font which newfont} {
10605 puts stderr "$font $newfont"
10606 array set f [font actual $newfont]
10607 set fontparam(which) $which
10608 set fontparam(font) $font
10609 set fontparam(family) $f(-family)
10610 set fontparam(size) $f(-size)
10611 set fontparam(weight) $f(-weight)
10612 set fontparam(slant) $f(-slant)
10617 proc selfontfam {} {
10618 global fonttop fontparam
10620 set i [$fonttop.f.fam curselection]
10622 set fontparam(family) [$fonttop.f.fam get $i]
10626 proc chg_fontparam {v sub op} {
10629 font config sample -$sub $fontparam($sub)
10633 global maxwidth maxgraphpct use_ttk NS
10634 global oldprefs prefstop showneartags showlocalchanges
10635 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10636 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10637 global hideremotes want_ttk have_ttk
10641 if {[winfo exists $top]} {
10645 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10646 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10647 set oldprefs($v) [set $v]
10650 wm title $top [mc "Gitk preferences"]
10651 make_transient $top .
10652 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10653 grid $top.ldisp - -sticky w -pady 10
10654 ${NS}::label $top.spacer -text " "
10655 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10656 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10657 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10658 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10659 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10660 grid x $top.maxpctl $top.maxpct -sticky w
10661 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10662 -variable showlocalchanges
10663 grid x $top.showlocal -sticky w
10664 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10665 -variable autoselect
10666 grid x $top.autoselect -sticky w
10667 ${NS}::checkbutton $top.hideremotes -text [mc "Hide remote refs"] \
10668 -variable hideremotes
10669 grid x $top.hideremotes -sticky w
10671 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10672 grid $top.ddisp - -sticky w -pady 10
10673 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10674 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10675 grid x $top.tabstopl $top.tabstop -sticky w
10676 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10677 -variable showneartags
10678 grid x $top.ntag -sticky w
10679 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10680 -variable limitdiffs
10681 grid x $top.ldiff -sticky w
10682 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10683 -variable perfile_attrs
10684 grid x $top.lattr -sticky w
10686 ${NS}::entry $top.extdifft -textvariable extdifftool
10687 ${NS}::frame $top.extdifff
10688 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10689 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10690 pack $top.extdifff.l $top.extdifff.b -side left
10691 pack configure $top.extdifff.l -padx 10
10692 grid x $top.extdifff $top.extdifft -sticky ew
10694 ${NS}::label $top.lgen -text [mc "General options"]
10695 grid $top.lgen - -sticky w -pady 10
10696 ${NS}::checkbutton $top.want_ttk -variable want_ttk \
10697 -text [mc "Use themed widgets"]
10699 ${NS}::label $top.ttk_note -text [mc "(change requires restart)"]
10701 ${NS}::label $top.ttk_note -text [mc "(currently unavailable)"]
10703 grid x $top.want_ttk $top.ttk_note -sticky w
10705 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10706 grid $top.cdisp - -sticky w -pady 10
10707 label $top.bg -padx 40 -relief sunk -background $bgcolor
10708 ${NS}::button $top.bgbut -text [mc "Background"] \
10709 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10710 grid x $top.bgbut $top.bg -sticky w
10711 label $top.fg -padx 40 -relief sunk -background $fgcolor
10712 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10713 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10714 grid x $top.fgbut $top.fg -sticky w
10715 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10716 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10717 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10718 [list $ctext tag conf d0 -foreground]]
10719 grid x $top.diffoldbut $top.diffold -sticky w
10720 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10721 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10722 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10723 [list $ctext tag conf dresult -foreground]]
10724 grid x $top.diffnewbut $top.diffnew -sticky w
10725 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10726 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10727 -command [list choosecolor diffcolors 2 $top.hunksep \
10728 [mc "diff hunk header"] \
10729 [list $ctext tag conf hunksep -foreground]]
10730 grid x $top.hunksepbut $top.hunksep -sticky w
10731 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10732 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10733 -command [list choosecolor markbgcolor {} $top.markbgsep \
10734 [mc "marked line background"] \
10735 [list $ctext tag conf omark -background]]
10736 grid x $top.markbgbut $top.markbgsep -sticky w
10737 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10738 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10739 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10740 grid x $top.selbgbut $top.selbgsep -sticky w
10742 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10743 grid $top.cfont - -sticky w -pady 10
10744 mkfontdisp mainfont $top [mc "Main font"]
10745 mkfontdisp textfont $top [mc "Diff display font"]
10746 mkfontdisp uifont $top [mc "User interface font"]
10749 foreach w {maxpctl maxwidthl showlocal autoselect tabstopl ntag
10750 ldiff lattr extdifff.l extdifff.b bgbut fgbut
10751 diffoldbut diffnewbut hunksepbut markbgbut selbgbut
10752 want_ttk ttk_note} {
10753 $top.$w configure -font optionfont
10757 ${NS}::frame $top.buts
10758 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10759 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10760 bind $top <Key-Return> prefsok
10761 bind $top <Key-Escape> prefscan
10762 grid $top.buts.ok $top.buts.can
10763 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10764 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10765 grid $top.buts - - -pady 10 -sticky ew
10766 grid columnconfigure $top 2 -weight 1
10767 bind $top <Visibility> "focus $top.buts.ok"
10770 proc choose_extdiff {} {
10773 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10775 set extdifftool $prog
10779 proc choosecolor {v vi w x cmd} {
10782 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10783 -title [mc "Gitk: choose color for %s" $x]]
10784 if {$c eq {}} return
10785 $w conf -background $c
10790 proc setselbg {c} {
10791 global bglist cflist
10792 foreach w $bglist {
10793 $w configure -selectbackground $c
10795 $cflist tag configure highlight \
10796 -background [$cflist cget -selectbackground]
10797 allcanvs itemconf secsel -fill $c
10803 foreach w $bglist {
10804 $w conf -background $c
10811 foreach w $fglist {
10812 $w conf -foreground $c
10814 allcanvs itemconf text -fill $c
10815 $canv itemconf circle -outline $c
10816 $canv itemconf markid -outline $c
10820 global oldprefs prefstop
10822 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10823 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
10825 set $v $oldprefs($v)
10827 catch {destroy $prefstop}
10833 global maxwidth maxgraphpct
10834 global oldprefs prefstop showneartags showlocalchanges
10835 global fontpref mainfont textfont uifont
10836 global limitdiffs treediffs perfile_attrs
10839 catch {destroy $prefstop}
10843 if {$mainfont ne $fontpref(mainfont)} {
10844 set mainfont $fontpref(mainfont)
10845 parsefont mainfont $mainfont
10846 eval font configure mainfont [fontflags mainfont]
10847 eval font configure mainfontbold [fontflags mainfont 1]
10851 if {$textfont ne $fontpref(textfont)} {
10852 set textfont $fontpref(textfont)
10853 parsefont textfont $textfont
10854 eval font configure textfont [fontflags textfont]
10855 eval font configure textfontbold [fontflags textfont 1]
10857 if {$uifont ne $fontpref(uifont)} {
10858 set uifont $fontpref(uifont)
10859 parsefont uifont $uifont
10860 eval font configure uifont [fontflags uifont]
10863 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10864 if {$showlocalchanges} {
10870 if {$limitdiffs != $oldprefs(limitdiffs) ||
10871 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10872 # treediffs elements are limited by path;
10873 # won't have encodings cached if perfile_attrs was just turned on
10874 catch {unset treediffs}
10876 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10877 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10879 } elseif {$showneartags != $oldprefs(showneartags) ||
10880 $limitdiffs != $oldprefs(limitdiffs)} {
10883 if {$hideremotes != $oldprefs(hideremotes)} {
10888 proc formatdate {d} {
10889 global datetimeformat
10891 set d [clock format $d -format $datetimeformat]
10896 # This list of encoding names and aliases is distilled from
10897 # http://www.iana.org/assignments/character-sets.
10898 # Not all of them are supported by Tcl.
10899 set encoding_aliases {
10900 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10901 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10902 { ISO-10646-UTF-1 csISO10646UTF1 }
10903 { ISO_646.basic:1983 ref csISO646basic1983 }
10904 { INVARIANT csINVARIANT }
10905 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10906 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10907 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10908 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10909 { NATS-DANO iso-ir-9-1 csNATSDANO }
10910 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10911 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10912 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10913 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10914 { ISO-2022-KR csISO2022KR }
10916 { ISO-2022-JP csISO2022JP }
10917 { ISO-2022-JP-2 csISO2022JP2 }
10918 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10919 csISO13JISC6220jp }
10920 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10921 { IT iso-ir-15 ISO646-IT csISO15Italian }
10922 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10923 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10924 { greek7-old iso-ir-18 csISO18Greek7Old }
10925 { latin-greek iso-ir-19 csISO19LatinGreek }
10926 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10927 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10928 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10929 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10930 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10931 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10932 { INIS iso-ir-49 csISO49INIS }
10933 { INIS-8 iso-ir-50 csISO50INIS8 }
10934 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10935 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10936 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10937 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10938 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10939 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10940 csISO60Norwegian1 }
10941 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10942 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10943 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10944 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10945 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10946 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10947 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10948 { greek7 iso-ir-88 csISO88Greek7 }
10949 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10950 { iso-ir-90 csISO90 }
10951 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10952 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10953 csISO92JISC62991984b }
10954 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10955 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10956 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10957 csISO95JIS62291984handadd }
10958 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10959 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10960 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10961 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10962 CP819 csISOLatin1 }
10963 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10964 { T.61-7bit iso-ir-102 csISO102T617bit }
10965 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10966 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10967 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10968 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10969 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10970 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10971 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10972 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10973 arabic csISOLatinArabic }
10974 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10975 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10976 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10977 greek greek8 csISOLatinGreek }
10978 { T.101-G2 iso-ir-128 csISO128T101G2 }
10979 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10981 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10982 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10983 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10984 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10985 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10986 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10987 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10988 csISOLatinCyrillic }
10989 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10990 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10991 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10992 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10993 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10994 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10995 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10996 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10997 { ISO_10367-box iso-ir-155 csISO10367Box }
10998 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10999 { latin-lap lap iso-ir-158 csISO158Lap }
11000 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11001 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11004 { JIS_X0201 X0201 csHalfWidthKatakana }
11005 { KSC5636 ISO646-KR csKSC5636 }
11006 { ISO-10646-UCS-2 csUnicode }
11007 { ISO-10646-UCS-4 csUCS4 }
11008 { DEC-MCS dec csDECMCS }
11009 { hp-roman8 roman8 r8 csHPRoman8 }
11010 { macintosh mac csMacintosh }
11011 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11013 { IBM038 EBCDIC-INT cp038 csIBM038 }
11014 { IBM273 CP273 csIBM273 }
11015 { IBM274 EBCDIC-BE CP274 csIBM274 }
11016 { IBM275 EBCDIC-BR cp275 csIBM275 }
11017 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11018 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11019 { IBM280 CP280 ebcdic-cp-it csIBM280 }
11020 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11021 { IBM284 CP284 ebcdic-cp-es csIBM284 }
11022 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11023 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11024 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11025 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11026 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11027 { IBM424 cp424 ebcdic-cp-he csIBM424 }
11028 { IBM437 cp437 437 csPC8CodePage437 }
11029 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11030 { IBM775 cp775 csPC775Baltic }
11031 { IBM850 cp850 850 csPC850Multilingual }
11032 { IBM851 cp851 851 csIBM851 }
11033 { IBM852 cp852 852 csPCp852 }
11034 { IBM855 cp855 855 csIBM855 }
11035 { IBM857 cp857 857 csIBM857 }
11036 { IBM860 cp860 860 csIBM860 }
11037 { IBM861 cp861 861 cp-is csIBM861 }
11038 { IBM862 cp862 862 csPC862LatinHebrew }
11039 { IBM863 cp863 863 csIBM863 }
11040 { IBM864 cp864 csIBM864 }
11041 { IBM865 cp865 865 csIBM865 }
11042 { IBM866 cp866 866 csIBM866 }
11043 { IBM868 CP868 cp-ar csIBM868 }
11044 { IBM869 cp869 869 cp-gr csIBM869 }
11045 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11046 { IBM871 CP871 ebcdic-cp-is csIBM871 }
11047 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11048 { IBM891 cp891 csIBM891 }
11049 { IBM903 cp903 csIBM903 }
11050 { IBM904 cp904 904 csIBBM904 }
11051 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11052 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11053 { IBM1026 CP1026 csIBM1026 }
11054 { EBCDIC-AT-DE csIBMEBCDICATDE }
11055 { EBCDIC-AT-DE-A csEBCDICATDEA }
11056 { EBCDIC-CA-FR csEBCDICCAFR }
11057 { EBCDIC-DK-NO csEBCDICDKNO }
11058 { EBCDIC-DK-NO-A csEBCDICDKNOA }
11059 { EBCDIC-FI-SE csEBCDICFISE }
11060 { EBCDIC-FI-SE-A csEBCDICFISEA }
11061 { EBCDIC-FR csEBCDICFR }
11062 { EBCDIC-IT csEBCDICIT }
11063 { EBCDIC-PT csEBCDICPT }
11064 { EBCDIC-ES csEBCDICES }
11065 { EBCDIC-ES-A csEBCDICESA }
11066 { EBCDIC-ES-S csEBCDICESS }
11067 { EBCDIC-UK csEBCDICUK }
11068 { EBCDIC-US csEBCDICUS }
11069 { UNKNOWN-8BIT csUnknown8BiT }
11070 { MNEMONIC csMnemonic }
11072 { VISCII csVISCII }
11075 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11076 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11077 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11078 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11079 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11080 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11081 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11082 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11083 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11084 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11085 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11086 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11087 { IBM1047 IBM-1047 }
11088 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11089 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11090 { UNICODE-1-1 csUnicode11 }
11091 { CESU-8 csCESU-8 }
11092 { BOCU-1 csBOCU-1 }
11093 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11094 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11096 { ISO-8859-15 ISO_8859-15 Latin-9 }
11097 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11098 { GBK CP936 MS936 windows-936 }
11099 { JIS_Encoding csJISEncoding }
11100 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11101 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11103 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11104 { ISO-10646-UCS-Basic csUnicodeASCII }
11105 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11106 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11107 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11108 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11109 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11110 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11111 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11112 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11113 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11114 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11115 { Adobe-Standard-Encoding csAdobeStandardEncoding }
11116 { Ventura-US csVenturaUS }
11117 { Ventura-International csVenturaInternational }
11118 { PC8-Danish-Norwegian csPC8DanishNorwegian }
11119 { PC8-Turkish csPC8Turkish }
11120 { IBM-Symbols csIBMSymbols }
11121 { IBM-Thai csIBMThai }
11122 { HP-Legal csHPLegal }
11123 { HP-Pi-font csHPPiFont }
11124 { HP-Math8 csHPMath8 }
11125 { Adobe-Symbol-Encoding csHPPSMath }
11126 { HP-DeskTop csHPDesktop }
11127 { Ventura-Math csVenturaMath }
11128 { Microsoft-Publishing csMicrosoftPublishing }
11129 { Windows-31J csWindows31J }
11130 { GB2312 csGB2312 }
11134 proc tcl_encoding {enc} {
11135 global encoding_aliases tcl_encoding_cache
11136 if {[info exists tcl_encoding_cache($enc)]} {
11137 return $tcl_encoding_cache($enc)
11139 set names [encoding names]
11140 set lcnames [string tolower $names]
11141 set enc [string tolower $enc]
11142 set i [lsearch -exact $lcnames $enc]
11144 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11145 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11146 set i [lsearch -exact $lcnames $encx]
11150 foreach l $encoding_aliases {
11151 set ll [string tolower $l]
11152 if {[lsearch -exact $ll $enc] < 0} continue
11153 # look through the aliases for one that tcl knows about
11155 set i [lsearch -exact $lcnames $e]
11157 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11158 set i [lsearch -exact $lcnames $ex]
11168 set tclenc [lindex $names $i]
11170 set tcl_encoding_cache($enc) $tclenc
11174 proc gitattr {path attr default} {
11175 global path_attr_cache
11176 if {[info exists path_attr_cache($attr,$path)]} {
11177 set r $path_attr_cache($attr,$path)
11179 set r "unspecified"
11180 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11181 regexp "(.*): $attr: (.*)" $line m f r
11183 set path_attr_cache($attr,$path) $r
11185 if {$r eq "unspecified"} {
11191 proc cache_gitattr {attr pathlist} {
11192 global path_attr_cache
11194 foreach path $pathlist {
11195 if {![info exists path_attr_cache($attr,$path)]} {
11196 lappend newlist $path
11200 if {[tk windowingsystem] == "win32"} {
11201 # windows has a 32k limit on the arguments to a command...
11204 while {$newlist ne {}} {
11205 set head [lrange $newlist 0 [expr {$lim - 1}]]
11206 set newlist [lrange $newlist $lim end]
11207 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11208 foreach row [split $rlist "\n"] {
11209 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11210 if {[string index $path 0] eq "\""} {
11211 set path [encoding convertfrom [lindex $path 0]]
11213 set path_attr_cache($attr,$path) $value
11220 proc get_path_encoding {path} {
11221 global gui_encoding perfile_attrs
11222 set tcl_enc $gui_encoding
11223 if {$path ne {} && $perfile_attrs} {
11224 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11232 # First check that Tcl/Tk is recent enough
11233 if {[catch {package require Tk 8.4} err]} {
11234 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11235 Gitk requires at least Tcl/Tk 8.4."]
11240 set wrcomcmd "git diff-tree --stdin -p --pretty"
11244 set gitencoding [exec git config --get i18n.commitencoding]
11247 set gitencoding [exec git config --get i18n.logoutputencoding]
11249 if {$gitencoding == ""} {
11250 set gitencoding "utf-8"
11252 set tclencoding [tcl_encoding $gitencoding]
11253 if {$tclencoding == {}} {
11254 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11257 set gui_encoding [encoding system]
11259 set enc [exec git config --get gui.encoding]
11261 set tclenc [tcl_encoding $enc]
11262 if {$tclenc ne {}} {
11263 set gui_encoding $tclenc
11265 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11270 if {[tk windowingsystem] eq "aqua"} {
11271 set mainfont {{Lucida Grande} 9}
11272 set textfont {Monaco 9}
11273 set uifont {{Lucida Grande} 9 bold}
11275 set mainfont {Helvetica 9}
11276 set textfont {Courier 9}
11277 set uifont {Helvetica 9 bold}
11280 set findmergefiles 0
11288 set cmitmode "patch"
11289 set wrapcomment "none"
11294 set showlocalchanges 1
11296 set datetimeformat "%Y-%m-%d %H:%M:%S"
11298 set perfile_attrs 0
11301 if {[tk windowingsystem] eq "aqua"} {
11302 set extdifftool "opendiff"
11304 set extdifftool "meld"
11307 set colors {green red blue magenta darkgrey brown orange}
11310 set diffcolors {red "#00a000" blue}
11313 set selectbgcolor gray85
11314 set markbgcolor "#e0e0ff"
11316 set circlecolors {white blue gray blue blue}
11318 # button for popping up context menus
11319 if {[tk windowingsystem] eq "aqua"} {
11320 set ctxbut <Button-2>
11322 set ctxbut <Button-3>
11325 ## For msgcat loading, first locate the installation location.
11326 if { [info exists ::env(GITK_MSGSDIR)] } {
11327 ## Msgsdir was manually set in the environment.
11328 set gitk_msgsdir $::env(GITK_MSGSDIR)
11330 ## Let's guess the prefix from argv0.
11331 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11332 set gitk_libdir [file join $gitk_prefix share gitk lib]
11333 set gitk_msgsdir [file join $gitk_libdir msgs]
11337 ## Internationalization (i18n) through msgcat and gettext. See
11338 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11339 package require msgcat
11340 namespace import ::msgcat::mc
11341 ## And eventually load the actual message catalog
11342 ::msgcat::mcload $gitk_msgsdir
11344 catch {source ~/.gitk}
11346 font create optionfont -family sans-serif -size -12
11348 parsefont mainfont $mainfont
11349 eval font create mainfont [fontflags mainfont]
11350 eval font create mainfontbold [fontflags mainfont 1]
11352 parsefont textfont $textfont
11353 eval font create textfont [fontflags textfont]
11354 eval font create textfontbold [fontflags textfont 1]
11356 parsefont uifont $uifont
11357 eval font create uifont [fontflags uifont]
11361 # check that we can find a .git directory somewhere...
11362 if {[catch {set gitdir [gitdir]}]} {
11363 show_error {} . [mc "Cannot find a git repository here."]
11366 if {![file isdirectory $gitdir]} {
11367 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11372 set selectheadid {}
11375 set cmdline_files {}
11377 set revtreeargscmd {}
11378 foreach arg $argv {
11379 switch -glob -- $arg {
11382 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11385 "--select-commit=*" {
11386 set selecthead [string range $arg 16 end]
11389 set revtreeargscmd [string range $arg 10 end]
11392 lappend revtreeargs $arg
11398 if {$selecthead eq "HEAD"} {
11402 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11403 # no -- on command line, but some arguments (other than --argscmd)
11405 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11406 set cmdline_files [split $f "\n"]
11407 set n [llength $cmdline_files]
11408 set revtreeargs [lrange $revtreeargs 0 end-$n]
11409 # Unfortunately git rev-parse doesn't produce an error when
11410 # something is both a revision and a filename. To be consistent
11411 # with git log and git rev-list, check revtreeargs for filenames.
11412 foreach arg $revtreeargs {
11413 if {[file exists $arg]} {
11414 show_error {} . [mc "Ambiguous argument '%s': both revision\
11415 and filename" $arg]
11420 # unfortunately we get both stdout and stderr in $err,
11421 # so look for "fatal:".
11422 set i [string first "fatal:" $err]
11424 set err [string range $err [expr {$i + 6}] end]
11426 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11431 set nullid "0000000000000000000000000000000000000000"
11432 set nullid2 "0000000000000000000000000000000000000001"
11433 set nullfile "/dev/null"
11435 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11436 if {![info exists have_ttk]} {
11437 set have_ttk [llength [info commands ::ttk::style]]
11439 set use_ttk [expr {$have_ttk && $want_ttk}]
11440 set NS [expr {$use_ttk ? "ttk" : ""}]
11442 set git_version [join [lrange [split [lindex [exec git version] end] .] 0 2] .]
11449 set highlight_paths {}
11451 set searchdirn -forwards
11454 set diffelide {0 0}
11455 set markingmatches 0
11456 set linkentercount 0
11457 set need_redisplay 0
11464 set selectedhlview [mc "None"]
11465 set highlight_related [mc "None"]
11466 set highlight_files {}
11467 set viewfiles(0) {}
11470 set viewargscmd(0) {}
11472 set selectedline {}
11480 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11484 image create photo gitlogo -width 16 -height 16
11486 image create photo gitlogominus -width 4 -height 2
11487 gitlogominus put #C00000 -to 0 0 4 2
11488 gitlogo copy gitlogominus -to 1 5
11489 gitlogo copy gitlogominus -to 6 5
11490 gitlogo copy gitlogominus -to 11 5
11491 image delete gitlogominus
11493 image create photo gitlogoplus -width 4 -height 4
11494 gitlogoplus put #008000 -to 1 0 3 4
11495 gitlogoplus put #008000 -to 0 1 4 3
11496 gitlogo copy gitlogoplus -to 1 9
11497 gitlogo copy gitlogoplus -to 6 9
11498 gitlogo copy gitlogoplus -to 11 9
11499 image delete gitlogoplus
11501 image create photo gitlogo32 -width 32 -height 32
11502 gitlogo32 copy gitlogo -zoom 2 2
11504 wm iconphoto . -default gitlogo gitlogo32
11506 # wait for the window to become visible
11507 tkwait visibility .
11508 wm title . "[file tail $argv0]: [file tail [pwd]]"
11512 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11513 # create a view for the files/dirs specified on the command line
11517 set viewname(1) [mc "Command line"]
11518 set viewfiles(1) $cmdline_files
11519 set viewargs(1) $revtreeargs
11520 set viewargscmd(1) $revtreeargscmd
11524 .bar.view entryconf [mca "Edit view..."] -state normal
11525 .bar.view entryconf [mca "Delete view"] -state normal
11528 if {[info exists permviews]} {
11529 foreach v $permviews {
11532 set viewname($n) [lindex $v 0]
11533 set viewfiles($n) [lindex $v 1]
11534 set viewargs($n) [lindex $v 2]
11535 set viewargscmd($n) [lindex $v 3]
11541 if {[tk windowingsystem] eq "win32"} {