2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright © 2005-2008 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
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 # These mean that we get a subset of the commits
198 # This appears to be the only one that has a value as a
199 # separate word following it
209 # git rev-parse doesn't understand --merge
210 lappend revargs
--gitk-symmetric-diff-marker MERGE_HEAD...HEAD
213 # Other flag arguments including -<n>
214 if {[string is digit
-strict [string range
$arg 1 end
]]} {
217 # a flag argument that we don't recognize;
218 # that means we can't optimize
224 # Non-flag arguments specify commits or ranges of commits
225 if {[string match
"*...*" $arg]} {
226 lappend revargs
--gitk-symmetric-diff-marker
232 set vdflags
($n) $diffargs
233 set vflags
($n) $glflags
234 set vrevs
($n) $revargs
235 set vfiltered
($n) $filtered
236 set vorigargs
($n) $origargs
240 proc parseviewrevs
{view revs
} {
241 global vposids vnegids
246 if {[catch
{set ids
[eval exec git rev-parse
$revs]} err
]} {
247 # we get stdout followed by stderr in $err
248 # for an unknown rev, git rev-parse echoes it and then errors out
249 set errlines
[split $err "\n"]
251 for {set l
0} {$l < [llength
$errlines]} {incr l
} {
252 set line
[lindex
$errlines $l]
253 if {!([string length
$line] == 40 && [string is xdigit
$line])} {
254 if {[string match
"fatal:*" $line]} {
255 if {[string match
"fatal: ambiguous argument*" $line]
257 if {[llength
$badrev] == 1} {
258 set err
"unknown revision $badrev"
260 set err
"unknown revisions: [join $badrev ", "]"
263 set err
[join [lrange
$errlines $l end
] "\n"]
270 error_popup
"[mc "Error parsing revisions
:"] $err"
277 foreach id
[split $ids "\n"] {
278 if {$id eq
"--gitk-symmetric-diff-marker"} {
280 } elseif
{[string match
"^*" $id]} {
287 lappend neg
[string range
$id 1 end
]
292 lset ret end
[lindex
$ret end
]...
$id
298 set vposids
($view) $pos
299 set vnegids
($view) $neg
303 # Start off a git log process and arrange to read its output
304 proc start_rev_list
{view
} {
305 global startmsecs commitidx viewcomplete curview
307 global viewargs viewargscmd viewfiles vfilelimit
308 global showlocalchanges
309 global viewactive viewinstances vmergeonly
310 global mainheadid viewmainheadid viewmainheadid_orig
311 global vcanopt vflags vrevs vorigargs
313 set startmsecs
[clock clicks
-milliseconds]
314 set commitidx
($view) 0
315 # these are set this way for the error exits
316 set viewcomplete
($view) 1
317 set viewactive
($view) 0
320 set args
$viewargs($view)
321 if {$viewargscmd($view) ne
{}} {
323 set str
[exec sh
-c $viewargscmd($view)]
325 error_popup
"[mc "Error executing
--argscmd command:"] $err"
328 set args
[concat
$args [split $str "\n"]]
330 set vcanopt
($view) [parseviewargs
$view $args]
332 set files
$viewfiles($view)
333 if {$vmergeonly($view)} {
334 set files
[unmerged_files
$files]
337 if {$nr_unmerged == 0} {
338 error_popup
[mc
"No files selected: --merge specified but\
339 no files are unmerged."]
341 error_popup
[mc
"No files selected: --merge specified but\
342 no unmerged files are within file limit."]
347 set vfilelimit
($view) $files
349 if {$vcanopt($view)} {
350 set revs
[parseviewrevs
$view $vrevs($view)]
354 set args
[concat
$vflags($view) $revs]
356 set args
$vorigargs($view)
360 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
361 --boundary $args "--" $files] r
]
363 error_popup
"[mc "Error executing git log
:"] $err"
366 set i
[reg_instance
$fd]
367 set viewinstances
($view) [list
$i]
368 set viewmainheadid
($view) $mainheadid
369 set viewmainheadid_orig
($view) $mainheadid
370 if {$files ne
{} && $mainheadid ne
{}} {
371 get_viewmainhead
$view
373 if {$showlocalchanges && $viewmainheadid($view) ne
{}} {
374 interestedin
$viewmainheadid($view) dodiffindex
376 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
377 if {$tclencoding != {}} {
378 fconfigure
$fd -encoding $tclencoding
380 filerun
$fd [list getcommitlines
$fd $i $view 0]
381 nowbusy
$view [mc
"Reading"]
382 set viewcomplete
($view) 0
383 set viewactive
($view) 1
387 proc stop_instance
{inst
} {
388 global commfd leftover
390 set fd
$commfd($inst)
394 if {$
::tcl_platform
(platform
) eq
{windows
}} {
403 unset leftover
($inst)
406 proc stop_backends
{} {
409 foreach inst
[array names commfd
] {
414 proc stop_rev_list
{view
} {
417 foreach inst
$viewinstances($view) {
420 set viewinstances
($view) {}
423 proc reset_pending_select
{selid
} {
424 global pending_select mainheadid selectheadid
427 set pending_select
$selid
428 } elseif
{$selectheadid ne
{}} {
429 set pending_select
$selectheadid
431 set pending_select
$mainheadid
435 proc getcommits
{selid
} {
436 global canv curview need_redisplay viewactive
439 if {[start_rev_list
$curview]} {
440 reset_pending_select
$selid
441 show_status
[mc
"Reading commits..."]
444 show_status
[mc
"No commits selected"]
448 proc updatecommits
{} {
449 global curview vcanopt vorigargs vfilelimit viewinstances
450 global viewactive viewcomplete tclencoding
451 global startmsecs showneartags showlocalchanges
452 global mainheadid viewmainheadid viewmainheadid_orig pending_select
454 global varcid vposids vnegids vflags vrevs
456 set isworktree
[expr {[exec git rev-parse
--is-inside-work-tree] == "true"}]
459 if {$mainheadid ne
$viewmainheadid_orig($view)} {
460 if {$showlocalchanges} {
463 set viewmainheadid
($view) $mainheadid
464 set viewmainheadid_orig
($view) $mainheadid
465 if {$vfilelimit($view) ne
{}} {
466 get_viewmainhead
$view
469 if {$showlocalchanges} {
472 if {$vcanopt($view)} {
473 set oldpos
$vposids($view)
474 set oldneg
$vnegids($view)
475 set revs
[parseviewrevs
$view $vrevs($view)]
479 # note: getting the delta when negative refs change is hard,
480 # and could require multiple git log invocations, so in that
481 # case we ask git log for all the commits (not just the delta)
482 if {$oldneg eq
$vnegids($view)} {
485 # take out positive refs that we asked for before or
486 # that we have already seen
488 if {[string length
$rev] == 40} {
489 if {[lsearch
-exact $oldpos $rev] < 0
490 && ![info exists varcid
($view,$rev)]} {
495 lappend
$newrevs $rev
498 if {$npos == 0} return
500 set vposids
($view) [lsort
-unique [concat
$oldpos $vposids($view)]]
502 set args
[concat
$vflags($view) $revs --not $oldpos]
504 set args
$vorigargs($view)
507 set fd
[open
[concat | git log
--no-color -z --pretty=raw
--parents \
508 --boundary $args "--" $vfilelimit($view)] r
]
510 error_popup
"[mc "Error executing git log
:"] $err"
513 if {$viewactive($view) == 0} {
514 set startmsecs
[clock clicks
-milliseconds]
516 set i
[reg_instance
$fd]
517 lappend viewinstances
($view) $i
518 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
519 if {$tclencoding != {}} {
520 fconfigure
$fd -encoding $tclencoding
522 filerun
$fd [list getcommitlines
$fd $i $view 1]
523 incr viewactive
($view)
524 set viewcomplete
($view) 0
525 reset_pending_select
{}
526 nowbusy
$view [mc
"Reading"]
532 proc reloadcommits
{} {
533 global curview viewcomplete selectedline currentid thickerline
534 global showneartags treediffs commitinterest cached_commitrow
538 if {$selectedline ne
{}} {
542 if {!$viewcomplete($curview)} {
543 stop_rev_list
$curview
547 catch
{unset currentid
}
548 catch
{unset thickerline
}
549 catch
{unset treediffs
}
556 catch
{unset commitinterest
}
557 catch
{unset cached_commitrow
}
558 catch
{unset targetid
}
564 # This makes a string representation of a positive integer which
565 # sorts as a string in numerical order
568 return [format
"%x" $n]
569 } elseif
{$n < 256} {
570 return [format
"x%.2x" $n]
571 } elseif
{$n < 65536} {
572 return [format
"y%.4x" $n]
574 return [format
"z%.8x" $n]
577 # Procedures used in reordering commits from git log (without
578 # --topo-order) into the order for display.
580 proc varcinit
{view
} {
581 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
582 global vtokmod varcmod vrowmod varcix vlastins
584 set varcstart
($view) {{}}
585 set vupptr
($view) {0}
586 set vdownptr
($view) {0}
587 set vleftptr
($view) {0}
588 set vbackptr
($view) {0}
589 set varctok
($view) {{}}
590 set varcrow
($view) {{}}
591 set vtokmod
($view) {}
594 set varcix
($view) {{}}
595 set vlastins
($view) {0}
598 proc resetvarcs
{view
} {
599 global varcid varccommits parents children vseedcount ordertok
601 foreach vid
[array names varcid
$view,*] {
606 # some commits might have children but haven't been seen yet
607 foreach vid
[array names children
$view,*] {
610 foreach va
[array names varccommits
$view,*] {
611 unset varccommits
($va)
613 foreach vd
[array names vseedcount
$view,*] {
614 unset vseedcount
($vd)
616 catch
{unset ordertok
}
619 # returns a list of the commits with no children
621 global vdownptr vleftptr varcstart
624 set a
[lindex
$vdownptr($v) 0]
626 lappend ret
[lindex
$varcstart($v) $a]
627 set a
[lindex
$vleftptr($v) $a]
632 proc newvarc
{view id
} {
633 global varcid varctok parents children vdatemode
634 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
635 global commitdata commitinfo vseedcount varccommits vlastins
637 set a
[llength
$varctok($view)]
639 if {[llength
$children($vid)] == 0 ||
$vdatemode($view)} {
640 if {![info exists commitinfo
($id)]} {
641 parsecommit
$id $commitdata($id) 1
643 set cdate
[lindex
$commitinfo($id) 4]
644 if {![string is integer
-strict $cdate]} {
647 if {![info exists vseedcount
($view,$cdate)]} {
648 set vseedcount
($view,$cdate) -1
650 set c
[incr vseedcount
($view,$cdate)]
651 set cdate
[expr {$cdate ^
0xffffffff}]
652 set tok
"s[strrep $cdate][strrep $c]"
657 if {[llength
$children($vid)] > 0} {
658 set kid
[lindex
$children($vid) end
]
659 set k
$varcid($view,$kid)
660 if {[string compare
[lindex
$varctok($view) $k] $tok] > 0} {
663 set tok
[lindex
$varctok($view) $k]
667 set i
[lsearch
-exact $parents($view,$ki) $id]
668 set j
[expr {[llength
$parents($view,$ki)] - 1 - $i}]
669 append tok
[strrep
$j]
671 set c
[lindex
$vlastins($view) $ka]
672 if {$c == 0 ||
[string compare
$tok [lindex
$varctok($view) $c]] < 0} {
674 set b
[lindex
$vdownptr($view) $ka]
676 set b
[lindex
$vleftptr($view) $c]
678 while {$b != 0 && [string compare
$tok [lindex
$varctok($view) $b]] >= 0} {
680 set b
[lindex
$vleftptr($view) $c]
683 lset vdownptr
($view) $ka $a
684 lappend vbackptr
($view) 0
686 lset vleftptr
($view) $c $a
687 lappend vbackptr
($view) $c
689 lset vlastins
($view) $ka $a
690 lappend vupptr
($view) $ka
691 lappend vleftptr
($view) $b
693 lset vbackptr
($view) $b $a
695 lappend varctok
($view) $tok
696 lappend varcstart
($view) $id
697 lappend vdownptr
($view) 0
698 lappend varcrow
($view) {}
699 lappend varcix
($view) {}
700 set varccommits
($view,$a) {}
701 lappend vlastins
($view) 0
705 proc splitvarc
{p v
} {
706 global varcid varcstart varccommits varctok vtokmod
707 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
709 set oa
$varcid($v,$p)
710 set otok
[lindex
$varctok($v) $oa]
711 set ac
$varccommits($v,$oa)
712 set i
[lsearch
-exact $varccommits($v,$oa) $p]
714 set na
[llength
$varctok($v)]
715 # "%" sorts before "0"...
716 set tok
"$otok%[strrep $i]"
717 lappend varctok
($v) $tok
718 lappend varcrow
($v) {}
719 lappend varcix
($v) {}
720 set varccommits
($v,$oa) [lrange
$ac 0 [expr {$i - 1}]]
721 set varccommits
($v,$na) [lrange
$ac $i end
]
722 lappend varcstart
($v) $p
723 foreach id
$varccommits($v,$na) {
724 set varcid
($v,$id) $na
726 lappend vdownptr
($v) [lindex
$vdownptr($v) $oa]
727 lappend vlastins
($v) [lindex
$vlastins($v) $oa]
728 lset vdownptr
($v) $oa $na
729 lset vlastins
($v) $oa 0
730 lappend vupptr
($v) $oa
731 lappend vleftptr
($v) 0
732 lappend vbackptr
($v) 0
733 for {set b
[lindex
$vdownptr($v) $na]} {$b != 0} {set b
[lindex
$vleftptr($v) $b]} {
734 lset vupptr
($v) $b $na
736 if {[string compare
$otok $vtokmod($v)] <= 0} {
741 proc renumbervarc
{a v
} {
742 global parents children varctok varcstart varccommits
743 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
745 set t1
[clock clicks
-milliseconds]
751 if {[info exists isrelated
($a)]} {
753 set id
[lindex
$varccommits($v,$a) end
]
754 foreach p
$parents($v,$id) {
755 if {[info exists varcid
($v,$p)]} {
756 set isrelated
($varcid($v,$p)) 1
761 set b
[lindex
$vdownptr($v) $a]
764 set b
[lindex
$vleftptr($v) $a]
766 set a
[lindex
$vupptr($v) $a]
772 if {![info exists kidchanged
($a)]} continue
773 set id
[lindex
$varcstart($v) $a]
774 if {[llength
$children($v,$id)] > 1} {
775 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
778 set oldtok
[lindex
$varctok($v) $a]
779 if {!$vdatemode($v)} {
785 set kid
[last_real_child
$v,$id]
787 set k
$varcid($v,$kid)
788 if {[string compare
[lindex
$varctok($v) $k] $tok] > 0} {
791 set tok
[lindex
$varctok($v) $k]
795 set i
[lsearch
-exact $parents($v,$ki) $id]
796 set j
[expr {[llength
$parents($v,$ki)] - 1 - $i}]
797 append tok
[strrep
$j]
799 if {$tok eq
$oldtok} {
802 set id
[lindex
$varccommits($v,$a) end
]
803 foreach p
$parents($v,$id) {
804 if {[info exists varcid
($v,$p)]} {
805 set kidchanged
($varcid($v,$p)) 1
810 lset varctok
($v) $a $tok
811 set b
[lindex
$vupptr($v) $a]
813 if {[string compare
[lindex
$varctok($v) $ka] $vtokmod($v)] < 0} {
816 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
819 set c
[lindex
$vbackptr($v) $a]
820 set d
[lindex
$vleftptr($v) $a]
822 lset vdownptr
($v) $b $d
824 lset vleftptr
($v) $c $d
827 lset vbackptr
($v) $d $c
829 if {[lindex
$vlastins($v) $b] == $a} {
830 lset vlastins
($v) $b $c
832 lset vupptr
($v) $a $ka
833 set c
[lindex
$vlastins($v) $ka]
835 [string compare
$tok [lindex
$varctok($v) $c]] < 0} {
837 set b
[lindex
$vdownptr($v) $ka]
839 set b
[lindex
$vleftptr($v) $c]
842 [string compare
$tok [lindex
$varctok($v) $b]] >= 0} {
844 set b
[lindex
$vleftptr($v) $c]
847 lset vdownptr
($v) $ka $a
848 lset vbackptr
($v) $a 0
850 lset vleftptr
($v) $c $a
851 lset vbackptr
($v) $a $c
853 lset vleftptr
($v) $a $b
855 lset vbackptr
($v) $b $a
857 lset vlastins
($v) $ka $a
860 foreach id
[array names sortkids
] {
861 if {[llength
$children($v,$id)] > 1} {
862 set children
($v,$id) [lsort
-command [list vtokcmp
$v] \
866 set t2
[clock clicks
-milliseconds]
867 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
870 # Fix up the graph after we have found out that in view $v,
871 # $p (a commit that we have already seen) is actually the parent
872 # of the last commit in arc $a.
873 proc fix_reversal
{p a v
} {
874 global varcid varcstart varctok vupptr
876 set pa
$varcid($v,$p)
877 if {$p ne
[lindex
$varcstart($v) $pa]} {
879 set pa
$varcid($v,$p)
881 # seeds always need to be renumbered
882 if {[lindex
$vupptr($v) $pa] == 0 ||
883 [string compare
[lindex
$varctok($v) $a] \
884 [lindex
$varctok($v) $pa]] > 0} {
889 proc insertrow
{id p v
} {
890 global cmitlisted children parents varcid varctok vtokmod
891 global varccommits ordertok commitidx numcommits curview
892 global targetid targetrow
896 set cmitlisted
($vid) 1
897 set children
($vid) {}
898 set parents
($vid) [list
$p]
899 set a
[newvarc
$v $id]
901 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] < 0} {
904 lappend varccommits
($v,$a) $id
906 if {[llength
[lappend children
($vp) $id]] > 1} {
907 set children
($vp) [lsort
-command [list vtokcmp
$v] $children($vp)]
908 catch
{unset ordertok
}
910 fix_reversal
$p $a $v
912 if {$v == $curview} {
913 set numcommits
$commitidx($v)
915 if {[info exists targetid
]} {
916 if {![comes_before
$targetid $p]} {
923 proc insertfakerow
{id p
} {
924 global varcid varccommits parents children cmitlisted
925 global commitidx varctok vtokmod targetid targetrow curview numcommits
929 set i
[lsearch
-exact $varccommits($v,$a) $p]
931 puts
"oops: insertfakerow can't find [shortids $p] on arc $a"
934 set children
($v,$id) {}
935 set parents
($v,$id) [list
$p]
936 set varcid
($v,$id) $a
937 lappend children
($v,$p) $id
938 set cmitlisted
($v,$id) 1
939 set numcommits
[incr commitidx
($v)]
940 # note we deliberately don't update varcstart($v) even if $i == 0
941 set varccommits
($v,$a) [linsert
$varccommits($v,$a) $i $id]
943 if {[info exists targetid
]} {
944 if {![comes_before
$targetid $p]} {
952 proc removefakerow
{id
} {
953 global varcid varccommits parents children commitidx
954 global varctok vtokmod cmitlisted currentid selectedline
955 global targetid curview numcommits
958 if {[llength
$parents($v,$id)] != 1} {
959 puts
"oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
962 set p
[lindex
$parents($v,$id) 0]
963 set a
$varcid($v,$id)
964 set i
[lsearch
-exact $varccommits($v,$a) $id]
966 puts
"oops: removefakerow can't find [shortids $id] on arc $a"
970 set varccommits
($v,$a) [lreplace
$varccommits($v,$a) $i $i]
971 unset parents
($v,$id)
972 unset children
($v,$id)
973 unset cmitlisted
($v,$id)
974 set numcommits
[incr commitidx
($v) -1]
975 set j
[lsearch
-exact $children($v,$p) $id]
977 set children
($v,$p) [lreplace
$children($v,$p) $j $j]
980 if {[info exist currentid
] && $id eq
$currentid} {
984 if {[info exists targetid
] && $targetid eq
$id} {
991 proc first_real_child
{vp
} {
992 global children nullid nullid2
994 foreach id
$children($vp) {
995 if {$id ne
$nullid && $id ne
$nullid2} {
1002 proc last_real_child
{vp
} {
1003 global children nullid nullid2
1005 set kids
$children($vp)
1006 for {set i
[llength
$kids]} {[incr i
-1] >= 0} {} {
1007 set id
[lindex
$kids $i]
1008 if {$id ne
$nullid && $id ne
$nullid2} {
1015 proc vtokcmp
{v a b
} {
1016 global varctok varcid
1018 return [string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1019 [lindex
$varctok($v) $varcid($v,$b)]]
1022 # This assumes that if lim is not given, the caller has checked that
1023 # arc a's token is less than $vtokmod($v)
1024 proc modify_arc
{v a
{lim
{}}} {
1025 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1028 set c
[string compare
[lindex
$varctok($v) $a] $vtokmod($v)]
1031 set r
[lindex
$varcrow($v) $a]
1032 if {$r ne
{} && $vrowmod($v) <= $r + $lim} return
1035 set vtokmod
($v) [lindex
$varctok($v) $a]
1037 if {$v == $curview} {
1038 while {$a != 0 && [lindex
$varcrow($v) $a] eq
{}} {
1039 set a
[lindex
$vupptr($v) $a]
1045 set lim
[llength
$varccommits($v,$a)]
1047 set r
[expr {[lindex
$varcrow($v) $a] + $lim}]
1054 proc update_arcrows
{v
} {
1055 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1056 global varcid vrownum varcorder varcix varccommits
1057 global vupptr vdownptr vleftptr varctok
1058 global displayorder parentlist curview cached_commitrow
1060 if {$vrowmod($v) == $commitidx($v)} return
1061 if {$v == $curview} {
1062 if {[llength
$displayorder] > $vrowmod($v)} {
1063 set displayorder
[lrange
$displayorder 0 [expr {$vrowmod($v) - 1}]]
1064 set parentlist
[lrange
$parentlist 0 [expr {$vrowmod($v) - 1}]]
1066 catch
{unset cached_commitrow
}
1068 set narctot
[expr {[llength
$varctok($v)] - 1}]
1070 while {$a != 0 && [lindex
$varcix($v) $a] eq
{}} {
1071 # go up the tree until we find something that has a row number,
1072 # or we get to a seed
1073 set a
[lindex
$vupptr($v) $a]
1076 set a
[lindex
$vdownptr($v) 0]
1079 set varcorder
($v) [list
$a]
1080 lset varcix
($v) $a 0
1081 lset varcrow
($v) $a 0
1085 set arcn
[lindex
$varcix($v) $a]
1086 if {[llength
$vrownum($v)] > $arcn + 1} {
1087 set vrownum
($v) [lrange
$vrownum($v) 0 $arcn]
1088 set varcorder
($v) [lrange
$varcorder($v) 0 $arcn]
1090 set row
[lindex
$varcrow($v) $a]
1094 incr row
[llength
$varccommits($v,$a)]
1095 # go down if possible
1096 set b
[lindex
$vdownptr($v) $a]
1098 # if not, go left, or go up until we can go left
1100 set b
[lindex
$vleftptr($v) $a]
1102 set a
[lindex
$vupptr($v) $a]
1108 lappend vrownum
($v) $row
1109 lappend varcorder
($v) $a
1110 lset varcix
($v) $a $arcn
1111 lset varcrow
($v) $a $row
1113 set vtokmod
($v) [lindex
$varctok($v) $p]
1115 set vrowmod
($v) $row
1116 if {[info exists currentid
]} {
1117 set selectedline
[rowofcommit
$currentid]
1121 # Test whether view $v contains commit $id
1122 proc commitinview
{id v
} {
1125 return [info exists varcid
($v,$id)]
1128 # Return the row number for commit $id in the current view
1129 proc rowofcommit
{id
} {
1130 global varcid varccommits varcrow curview cached_commitrow
1131 global varctok vtokmod
1134 if {![info exists varcid
($v,$id)]} {
1135 puts
"oops rowofcommit no arc for [shortids $id]"
1138 set a
$varcid($v,$id)
1139 if {[string compare
[lindex
$varctok($v) $a] $vtokmod($v)] >= 0} {
1142 if {[info exists cached_commitrow
($id)]} {
1143 return $cached_commitrow($id)
1145 set i
[lsearch
-exact $varccommits($v,$a) $id]
1147 puts
"oops didn't find commit [shortids $id] in arc $a"
1150 incr i
[lindex
$varcrow($v) $a]
1151 set cached_commitrow
($id) $i
1155 # Returns 1 if a is on an earlier row than b, otherwise 0
1156 proc comes_before
{a b
} {
1157 global varcid varctok curview
1160 if {$a eq
$b ||
![info exists varcid
($v,$a)] || \
1161 ![info exists varcid
($v,$b)]} {
1164 if {$varcid($v,$a) != $varcid($v,$b)} {
1165 return [expr {[string compare
[lindex
$varctok($v) $varcid($v,$a)] \
1166 [lindex
$varctok($v) $varcid($v,$b)]] < 0}]
1168 return [expr {[rowofcommit
$a] < [rowofcommit
$b]}]
1171 proc bsearch
{l elt
} {
1172 if {[llength
$l] == 0 ||
$elt <= [lindex
$l 0]} {
1177 while {$hi - $lo > 1} {
1178 set mid
[expr {int
(($lo + $hi) / 2)}]
1179 set t
[lindex
$l $mid]
1182 } elseif
{$elt > $t} {
1191 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1192 proc make_disporder
{start end
} {
1193 global vrownum curview commitidx displayorder parentlist
1194 global varccommits varcorder parents vrowmod varcrow
1195 global d_valid_start d_valid_end
1197 if {$end > $vrowmod($curview)} {
1198 update_arcrows
$curview
1200 set ai
[bsearch
$vrownum($curview) $start]
1201 set start
[lindex
$vrownum($curview) $ai]
1202 set narc
[llength
$vrownum($curview)]
1203 for {set r
$start} {$ai < $narc && $r < $end} {incr ai
} {
1204 set a
[lindex
$varcorder($curview) $ai]
1205 set l
[llength
$displayorder]
1206 set al
[llength
$varccommits($curview,$a)]
1207 if {$l < $r + $al} {
1209 set pad
[ntimes
[expr {$r - $l}] {}]
1210 set displayorder
[concat
$displayorder $pad]
1211 set parentlist
[concat
$parentlist $pad]
1212 } elseif
{$l > $r} {
1213 set displayorder
[lrange
$displayorder 0 [expr {$r - 1}]]
1214 set parentlist
[lrange
$parentlist 0 [expr {$r - 1}]]
1216 foreach id
$varccommits($curview,$a) {
1217 lappend displayorder
$id
1218 lappend parentlist
$parents($curview,$id)
1220 } elseif
{[lindex
$displayorder [expr {$r + $al - 1}]] eq
{}} {
1222 foreach id
$varccommits($curview,$a) {
1223 lset displayorder
$i $id
1224 lset parentlist
$i $parents($curview,$id)
1232 proc commitonrow
{row
} {
1235 set id
[lindex
$displayorder $row]
1237 make_disporder
$row [expr {$row + 1}]
1238 set id
[lindex
$displayorder $row]
1243 proc closevarcs
{v
} {
1244 global varctok varccommits varcid parents children
1245 global cmitlisted commitidx vtokmod
1247 set missing_parents
0
1249 set narcs
[llength
$varctok($v)]
1250 for {set a
1} {$a < $narcs} {incr a
} {
1251 set id
[lindex
$varccommits($v,$a) end
]
1252 foreach p
$parents($v,$id) {
1253 if {[info exists varcid
($v,$p)]} continue
1254 # add p as a new commit
1255 incr missing_parents
1256 set cmitlisted
($v,$p) 0
1257 set parents
($v,$p) {}
1258 if {[llength
$children($v,$p)] == 1 &&
1259 [llength
$parents($v,$id)] == 1} {
1262 set b
[newvarc
$v $p]
1264 set varcid
($v,$p) $b
1265 if {[string compare
[lindex
$varctok($v) $b] $vtokmod($v)] < 0} {
1268 lappend varccommits
($v,$b) $p
1270 set scripts
[check_interest
$p $scripts]
1273 if {$missing_parents > 0} {
1274 foreach s
$scripts {
1280 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1281 # Assumes we already have an arc for $rwid.
1282 proc rewrite_commit
{v id rwid
} {
1283 global children parents varcid varctok vtokmod varccommits
1285 foreach ch
$children($v,$id) {
1286 # make $rwid be $ch's parent in place of $id
1287 set i
[lsearch
-exact $parents($v,$ch) $id]
1289 puts
"oops rewrite_commit didn't find $id in parent list for $ch"
1291 set parents
($v,$ch) [lreplace
$parents($v,$ch) $i $i $rwid]
1292 # add $ch to $rwid's children and sort the list if necessary
1293 if {[llength
[lappend children
($v,$rwid) $ch]] > 1} {
1294 set children
($v,$rwid) [lsort
-command [list vtokcmp
$v] \
1295 $children($v,$rwid)]
1297 # fix the graph after joining $id to $rwid
1298 set a
$varcid($v,$ch)
1299 fix_reversal
$rwid $a $v
1300 # parentlist is wrong for the last element of arc $a
1301 # even if displayorder is right, hence the 3rd arg here
1302 modify_arc
$v $a [expr {[llength
$varccommits($v,$a)] - 1}]
1306 # Mechanism for registering a command to be executed when we come
1307 # across a particular commit. To handle the case when only the
1308 # prefix of the commit is known, the commitinterest array is now
1309 # indexed by the first 4 characters of the ID. Each element is a
1310 # list of id, cmd pairs.
1311 proc interestedin
{id cmd
} {
1312 global commitinterest
1314 lappend commitinterest
([string range
$id 0 3]) $id $cmd
1317 proc check_interest
{id scripts
} {
1318 global commitinterest
1320 set prefix
[string range
$id 0 3]
1321 if {[info exists commitinterest
($prefix)]} {
1323 foreach
{i
script} $commitinterest($prefix) {
1324 if {[string match
"$i*" $id]} {
1325 lappend scripts
[string map
[list
"%I" $id "%P" $i] $script]
1327 lappend newlist
$i $script
1330 if {$newlist ne
{}} {
1331 set commitinterest
($prefix) $newlist
1333 unset commitinterest
($prefix)
1339 proc getcommitlines
{fd inst view updating
} {
1340 global cmitlisted leftover
1341 global commitidx commitdata vdatemode
1342 global parents children curview hlview
1343 global idpending ordertok
1344 global varccommits varcid varctok vtokmod vfilelimit
1346 set stuff
[read $fd 500000]
1347 # git log doesn't terminate the last commit with a null...
1348 if {$stuff == {} && $leftover($inst) ne
{} && [eof
$fd]} {
1355 global commfd viewcomplete viewactive viewname
1356 global viewinstances
1358 set i
[lsearch
-exact $viewinstances($view) $inst]
1360 set viewinstances
($view) [lreplace
$viewinstances($view) $i $i]
1362 # set it blocking so we wait for the process to terminate
1363 fconfigure
$fd -blocking 1
1364 if {[catch
{close
$fd} err
]} {
1366 if {$view != $curview} {
1367 set fv
" for the \"$viewname($view)\" view"
1369 if {[string range
$err 0 4] == "usage"} {
1370 set err
"Gitk: error reading commits$fv:\
1371 bad arguments to git log."
1372 if {$viewname($view) eq
"Command line"} {
1374 " (Note: arguments to gitk are passed to git log\
1375 to allow selection of commits to be displayed.)"
1378 set err
"Error reading commits$fv: $err"
1382 if {[incr viewactive
($view) -1] <= 0} {
1383 set viewcomplete
($view) 1
1384 # Check if we have seen any ids listed as parents that haven't
1385 # appeared in the list
1389 if {$view == $curview} {
1398 set i
[string first
"\0" $stuff $start]
1400 append leftover
($inst) [string range
$stuff $start end
]
1404 set cmit
$leftover($inst)
1405 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
1406 set leftover
($inst) {}
1408 set cmit
[string range
$stuff $start [expr {$i - 1}]]
1410 set start
[expr {$i + 1}]
1411 set j
[string first
"\n" $cmit]
1414 if {$j >= 0 && [string match
"commit *" $cmit]} {
1415 set ids
[string range
$cmit 7 [expr {$j - 1}]]
1416 if {[string match
{[-^
<>]*} $ids]} {
1417 switch
-- [string index
$ids 0] {
1423 set ids
[string range
$ids 1 end
]
1427 if {[string length
$id] != 40} {
1435 if {[string length
$shortcmit] > 80} {
1436 set shortcmit
"[string range $shortcmit 0 80]..."
1438 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
1441 set id [lindex $ids 0]
1444 if {!$listed && $updating && ![info exists varcid($vid)] &&
1445 $vfilelimit($view) ne {}} {
1446 # git log doesn't rewrite parents
for unlisted commits
1447 # when doing path limiting, so work around that here
1448 # by working out the rewritten parent with git rev-list
1449 # and if we already know about it, using the rewritten
1450 # parent as a substitute parent for $id's children.
1452 set rwid
[exec git rev-list
--first-parent --max-count=1 \
1453 $id -- $vfilelimit($view)]
1455 if {$rwid ne
{} && [info exists varcid
($view,$rwid)]} {
1456 # use $rwid in place of $id
1457 rewrite_commit
$view $id $rwid
1464 if {[info exists varcid
($vid)]} {
1465 if {$cmitlisted($vid) ||
!$listed} continue
1469 set olds
[lrange
$ids 1 end
]
1473 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
1474 set cmitlisted
($vid) $listed
1475 set parents
($vid) $olds
1476 if {![info exists children
($vid)]} {
1477 set children
($vid) {}
1478 } elseif
{$a == 0 && [llength
$children($vid)] == 1} {
1479 set k
[lindex
$children($vid) 0]
1480 if {[llength
$parents($view,$k)] == 1 &&
1481 (!$vdatemode($view) ||
1482 $varcid($view,$k) == [llength
$varctok($view)] - 1)} {
1483 set a
$varcid($view,$k)
1488 set a
[newvarc
$view $id]
1490 if {[string compare
[lindex
$varctok($view) $a] $vtokmod($view)] < 0} {
1493 if {![info exists varcid
($vid)]} {
1495 lappend varccommits
($view,$a) $id
1496 incr commitidx
($view)
1501 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
1503 if {[llength
[lappend children
($vp) $id]] > 1 &&
1504 [vtokcmp
$view [lindex
$children($vp) end-1
] $id] > 0} {
1505 set children
($vp) [lsort
-command [list vtokcmp
$view] \
1507 catch
{unset ordertok
}
1509 if {[info exists varcid
($view,$p)]} {
1510 fix_reversal
$p $a $view
1516 set scripts
[check_interest
$id $scripts]
1520 global numcommits hlview
1522 if {$view == $curview} {
1523 set numcommits
$commitidx($view)
1526 if {[info exists hlview
] && $view == $hlview} {
1527 # we never actually get here...
1530 foreach s
$scripts {
1537 proc chewcommits
{} {
1538 global curview hlview viewcomplete
1539 global pending_select
1542 if {$viewcomplete($curview)} {
1543 global commitidx varctok
1544 global numcommits startmsecs
1546 if {[info exists pending_select
]} {
1548 reset_pending_select
{}
1550 if {[commitinview
$pending_select $curview]} {
1551 selectline
[rowofcommit
$pending_select] 1
1553 set row
[first_real_row
]
1557 if {$commitidx($curview) > 0} {
1558 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1559 #puts "overall $ms ms for $numcommits commits"
1560 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1562 show_status
[mc
"No commits selected"]
1569 proc do_readcommit
{id
} {
1572 # Invoke git-log to handle automatic encoding conversion
1573 set fd
[open
[concat | git log
--no-color --pretty=raw
-1 $id] r
]
1574 # Read the results using i18n.logoutputencoding
1575 fconfigure
$fd -translation lf
-eofchar {}
1576 if {$tclencoding != {}} {
1577 fconfigure
$fd -encoding $tclencoding
1579 set contents
[read $fd]
1581 # Remove the heading line
1582 regsub
{^commit
[0-9a-f]+\n} $contents {} contents
1587 proc readcommit
{id
} {
1588 if {[catch
{set contents
[do_readcommit
$id]}]} return
1589 parsecommit
$id $contents 1
1592 proc parsecommit
{id contents listed
} {
1593 global commitinfo cdate
1602 set hdrend
[string first
"\n\n" $contents]
1604 # should never happen...
1605 set hdrend
[string length
$contents]
1607 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
1608 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
1609 foreach line
[split $header "\n"] {
1610 set line
[split $line " "]
1611 set tag
[lindex
$line 0]
1612 if {$tag == "author"} {
1613 set audate
[lindex
$line end-1
]
1614 set auname
[join [lrange
$line 1 end-2
] " "]
1615 } elseif
{$tag == "committer"} {
1616 set comdate
[lindex
$line end-1
]
1617 set comname
[join [lrange
$line 1 end-2
] " "]
1621 # take the first non-blank line of the comment as the headline
1622 set headline
[string trimleft
$comment]
1623 set i
[string first
"\n" $headline]
1625 set headline
[string range
$headline 0 $i]
1627 set headline
[string trimright
$headline]
1628 set i
[string first
"\r" $headline]
1630 set headline
[string trimright
[string range
$headline 0 $i]]
1633 # git log indents the comment by 4 spaces;
1634 # if we got this via git cat-file, add the indentation
1636 foreach line
[split $comment "\n"] {
1637 append newcomment
" "
1638 append newcomment
$line
1639 append newcomment
"\n"
1641 set comment
$newcomment
1643 if {$comdate != {}} {
1644 set cdate
($id) $comdate
1646 set commitinfo
($id) [list
$headline $auname $audate \
1647 $comname $comdate $comment]
1650 proc getcommit
{id
} {
1651 global commitdata commitinfo
1653 if {[info exists commitdata
($id)]} {
1654 parsecommit
$id $commitdata($id) 1
1657 if {![info exists commitinfo
($id)]} {
1658 set commitinfo
($id) [list
[mc
"No commit information available"]]
1664 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1665 # and are present in the current view.
1666 # This is fairly slow...
1667 proc longid
{prefix
} {
1668 global varcid curview
1671 foreach match
[array names varcid
"$curview,$prefix*"] {
1672 lappend ids
[lindex
[split $match ","] 1]
1678 global tagids idtags headids idheads tagobjid
1679 global otherrefids idotherrefs mainhead mainheadid
1680 global selecthead selectheadid
1682 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
1685 set refd
[open
[list | git show-ref
-d] r
]
1686 while {[gets
$refd line
] >= 0} {
1687 if {[string index
$line 40] ne
" "} continue
1688 set id
[string range
$line 0 39]
1689 set ref
[string range
$line 41 end
]
1690 if {![string match
"refs/*" $ref]} continue
1691 set name
[string range
$ref 5 end
]
1692 if {[string match
"remotes/*" $name]} {
1693 if {![string match
"*/HEAD" $name]} {
1694 set headids
($name) $id
1695 lappend idheads
($id) $name
1697 } elseif
{[string match
"heads/*" $name]} {
1698 set name
[string range
$name 6 end
]
1699 set headids
($name) $id
1700 lappend idheads
($id) $name
1701 } elseif
{[string match
"tags/*" $name]} {
1702 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1703 # which is what we want since the former is the commit ID
1704 set name
[string range
$name 5 end
]
1705 if {[string match
"*^{}" $name]} {
1706 set name
[string range
$name 0 end-3
]
1708 set tagobjid
($name) $id
1710 set tagids
($name) $id
1711 lappend idtags
($id) $name
1713 set otherrefids
($name) $id
1714 lappend idotherrefs
($id) $name
1721 set mainheadid
[exec git rev-parse HEAD
]
1722 set thehead
[exec git symbolic-ref HEAD
]
1723 if {[string match
"refs/heads/*" $thehead]} {
1724 set mainhead
[string range
$thehead 11 end
]
1728 if {$selecthead ne
{}} {
1730 set selectheadid
[exec git rev-parse
--verify $selecthead]
1735 # skip over fake commits
1736 proc first_real_row
{} {
1737 global nullid nullid2 numcommits
1739 for {set row
0} {$row < $numcommits} {incr row
} {
1740 set id
[commitonrow
$row]
1741 if {$id ne
$nullid && $id ne
$nullid2} {
1748 # update things for a head moved to a child of its previous location
1749 proc movehead
{id name
} {
1750 global headids idheads
1752 removehead
$headids($name) $name
1753 set headids
($name) $id
1754 lappend idheads
($id) $name
1757 # update things when a head has been removed
1758 proc removehead
{id name
} {
1759 global headids idheads
1761 if {$idheads($id) eq
$name} {
1764 set i
[lsearch
-exact $idheads($id) $name]
1766 set idheads
($id) [lreplace
$idheads($id) $i $i]
1769 unset headids
($name)
1772 proc ttk_toplevel
{w args
} {
1774 eval [linsert
$args 0 ::toplevel
$w]
1776 place
[ttk
::frame
$w._toplevel_background
] -x 0 -y 0 -relwidth 1 -relheight 1
1781 proc make_transient
{window origin
} {
1784 # In MacOS Tk 8.4 transient appears to work by setting
1785 # overrideredirect, which is utterly useless, since the
1786 # windows get no border, and are not even kept above
1788 if {!$have_tk85 && [tk windowingsystem
] eq
{aqua
}} return
1790 wm transient
$window $origin
1792 # Windows fails to place transient windows normally, so
1793 # schedule a callback to center them on the parent.
1794 if {[tk windowingsystem
] eq
{win32
}} {
1795 after idle
[list tk
::PlaceWindow
$window widget
$origin]
1799 proc show_error
{w top msg
} {
1801 if {![info exists NS
]} {set NS
""}
1802 if {[wm state
$top] eq
"withdrawn"} { wm deiconify
$top }
1803 message
$w.m
-text $msg -justify center
-aspect 400
1804 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1805 ${NS}::button
$w.ok
-default active
-text [mc OK
] -command "destroy $top"
1806 pack
$w.ok
-side bottom
-fill x
1807 bind $top <Visibility
> "grab $top; focus $top"
1808 bind $top <Key-Return
> "destroy $top"
1809 bind $top <Key-space
> "destroy $top"
1810 bind $top <Key-Escape
> "destroy $top"
1814 proc error_popup
{msg
{owner .
}} {
1815 if {[tk windowingsystem
] eq
"win32"} {
1816 tk_messageBox
-icon error
-type ok
-title [wm title .
] \
1817 -parent $owner -message $msg
1821 make_transient
$w $owner
1822 show_error
$w $w $msg
1826 proc confirm_popup
{msg
{owner .
}} {
1827 global confirm_ok NS
1831 make_transient
$w $owner
1832 message
$w.m
-text $msg -justify center
-aspect 400
1833 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
1834 ${NS}::button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
1835 pack
$w.ok
-side left
-fill x
1836 ${NS}::button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
1837 pack
$w.cancel
-side right
-fill x
1838 bind $w <Visibility
> "grab $w; focus $w"
1839 bind $w <Key-Return
> "set confirm_ok 1; destroy $w"
1840 bind $w <Key-space
> "set confirm_ok 1; destroy $w"
1841 bind $w <Key-Escape
> "destroy $w"
1842 tk
::PlaceWindow
$w widget
$owner
1847 proc setoptions
{} {
1848 if {[tk windowingsystem
] ne
"win32"} {
1849 option add
*Panedwindow.showHandle
1 startupFile
1850 option add
*Panedwindow.sashRelief raised startupFile
1851 if {[tk windowingsystem
] ne
"aqua"} {
1852 option add
*Menu.font uifont startupFile
1855 option add
*Menu.TearOff
0 startupFile
1857 option add
*Button.font uifont startupFile
1858 option add
*Checkbutton.font uifont startupFile
1859 option add
*Radiobutton.font uifont startupFile
1860 option add
*Menubutton.font uifont startupFile
1861 option add
*Label.font uifont startupFile
1862 option add
*Message.font uifont startupFile
1863 option add
*Entry.font uifont startupFile
1864 option add
*Labelframe.font uifont startupFile
1867 # Make a menu and submenus.
1868 # m is the window name for the menu, items is the list of menu items to add.
1869 # Each item is a list {mc label type description options...}
1870 # mc is ignored; it's so we can put mc there to alert xgettext
1871 # label is the string that appears in the menu
1872 # type is cascade, command or radiobutton (should add checkbutton)
1873 # description depends on type; it's the sublist for cascade, the
1874 # command to invoke for command, or {variable value} for radiobutton
1875 proc makemenu
{m items
} {
1877 if {[tk windowingsystem
] eq
{aqua
}} {
1883 set name
[mc
[lindex
$i 1]]
1884 set type [lindex
$i 2]
1885 set thing
[lindex
$i 3]
1886 set params
[list
$type]
1888 set u
[string first
"&" [string map
{&& x
} $name]]
1889 lappend params
-label [string map
{&& & & {}} $name]
1891 lappend params
-underline $u
1896 set submenu
[string tolower
[string map
{& ""} [lindex
$i 1]]]
1897 lappend params
-menu $m.
$submenu
1900 lappend params
-command $thing
1903 lappend params
-variable [lindex
$thing 0] \
1904 -value [lindex
$thing 1]
1907 set tail [lrange
$i 4 end
]
1908 regsub
-all {\yMeta1\y
} $tail $Meta1 tail
1909 eval $m add
$params $tail
1910 if {$type eq
"cascade"} {
1911 makemenu
$m.
$submenu $thing
1916 # translate string and remove ampersands
1918 return [string map
{&& & & {}} [mc
$str]]
1921 proc makedroplist
{w varname args
} {
1925 foreach label
$args {
1926 set cx
[string length
$label]
1927 if {$cx > $width} {set width
$cx}
1929 set gm
[ttk
::combobox
$w -width $width -state readonly\
1930 -textvariable $varname -values $args]
1932 set gm
[eval [linsert
$args 0 tk_optionMenu
$w $varname]]
1937 proc makewindow
{} {
1938 global canv canv2 canv3 linespc charspc ctext cflist cscroll
1940 global findtype findtypemenu findloc findstring fstring geometry
1941 global entries sha1entry sha1string sha1but
1942 global diffcontextstring diffcontext
1944 global maincursor textcursor curtextcursor
1945 global rowctxmenu fakerowmenu mergemax wrapcomment
1946 global highlight_files gdttype
1947 global searchstring sstring
1948 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1949 global headctxmenu progresscanv progressitem progresscoords statusw
1950 global fprogitem fprogcoord lastprogupdate progupdatepending
1951 global rprogitem rprogcoord rownumsel numcommits
1952 global have_tk85 use_ttk NS
1954 # The "mc" arguments here are purely so that xgettext
1955 # sees the following string as needing to be translated
1958 {mc
"Update" command updatecommits
-accelerator F5
}
1959 {mc
"Reload" command reloadcommits
-accelerator Meta1-F5
}
1960 {mc
"Reread references" command rereadrefs
}
1961 {mc
"List references" command showrefs
-accelerator F2
}
1963 {mc
"Start git gui" command {exec git gui
&}}
1965 {mc
"Quit" command doquit
-accelerator Meta1-Q
}
1969 {mc
"Preferences" command doprefs
}
1973 {mc
"New view..." command {newview
0} -accelerator Shift-F4
}
1974 {mc
"Edit view..." command editview
-state disabled
-accelerator F4
}
1975 {mc
"Delete view" command delview
-state disabled
}
1977 {mc
"All files" radiobutton
{selectedview
0} -command {showview
0}}
1979 if {[tk windowingsystem
] ne
"aqua"} {
1982 {mc
"About gitk" command about
}
1983 {mc
"Key bindings" command keys
}
1985 set bar
[list
$file $edit $view $help]
1987 proc
::tk
::mac
::ShowPreferences
{} {doprefs
}
1988 proc
::tk
::mac
::Quit
{} {doquit
}
1989 lset
file end
[lreplace
[lindex
$file end
] end-1 end
]
1991 xx
"Apple" cascade
{
1992 {mc
"About gitk" command about
}
1997 {mc
"Key bindings" command keys
}
1999 set bar
[list
$apple $file $view $help]
2002 . configure
-menu .bar
2005 # cover the non-themed toplevel with a themed frame.
2006 place
[ttk
::frame ._main_background
] -x 0 -y 0 -relwidth 1 -relheight 1
2009 # the gui has upper and lower half, parts of a paned window.
2010 ${NS}::panedwindow .ctop
-orient vertical
2012 # possibly use assumed geometry
2013 if {![info exists geometry
(pwsash0
)]} {
2014 set geometry
(topheight
) [expr {15 * $linespc}]
2015 set geometry
(topwidth
) [expr {80 * $charspc}]
2016 set geometry
(botheight
) [expr {15 * $linespc}]
2017 set geometry
(botwidth
) [expr {50 * $charspc}]
2018 set geometry
(pwsash0
) [list
[expr {40 * $charspc}] 2]
2019 set geometry
(pwsash1
) [list
[expr {60 * $charspc}] 2]
2022 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2023 ${NS}::frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
2024 ${NS}::frame .tf.histframe
2025 ${NS}::panedwindow .tf.histframe.pwclist
-orient horizontal
2027 .tf.histframe.pwclist configure
-sashpad 0 -handlesize 4
2030 # create three canvases
2031 set cscroll .tf.histframe.csb
2032 set canv .tf.histframe.pwclist.canv
2034 -selectbackground $selectbgcolor \
2035 -background $bgcolor -bd 0 \
2036 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2037 .tf.histframe.pwclist add
$canv
2038 set canv2 .tf.histframe.pwclist.canv2
2040 -selectbackground $selectbgcolor \
2041 -background $bgcolor -bd 0 -yscrollincr $linespc
2042 .tf.histframe.pwclist add
$canv2
2043 set canv3 .tf.histframe.pwclist.canv3
2045 -selectbackground $selectbgcolor \
2046 -background $bgcolor -bd 0 -yscrollincr $linespc
2047 .tf.histframe.pwclist add
$canv3
2049 bind .tf.histframe.pwclist
<Map
> {
2051 .tf.histframe.pwclist sashpos
1 [lindex $
::geometry
(pwsash1
) 0]
2052 .tf.histframe.pwclist sashpos
0 [lindex $
::geometry
(pwsash0
) 0]
2055 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
2056 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
2059 # a scroll bar to rule them
2060 ${NS}::scrollbar
$cscroll -command {allcanvs yview
}
2061 if {!$use_ttk} {$cscroll configure
-highlightthickness 0}
2062 pack
$cscroll -side right
-fill y
2063 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
2064 lappend bglist
$canv $canv2 $canv3
2065 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
2067 # we have two button bars at bottom of top frame. Bar 1
2068 ${NS}::frame .tf.bar
2069 ${NS}::frame .tf.lbar
-height 15
2071 set sha1entry .tf.bar.sha1
2072 set entries
$sha1entry
2073 set sha1but .tf.bar.sha1label
2074 button
$sha1but -text [mc
"SHA1 ID: "] -state disabled
-relief flat \
2075 -command gotocommit
-width 8
2076 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
2077 pack .tf.bar.sha1label
-side left
2078 ${NS}::entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
2079 trace add variable sha1string
write sha1change
2080 pack
$sha1entry -side left
-pady 2
2082 image create bitmap bm-left
-data {
2083 #define left_width 16
2084 #define left_height 16
2085 static unsigned char left_bits
[] = {
2086 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2087 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2088 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2090 image create bitmap bm-right
-data {
2091 #define right_width 16
2092 #define right_height 16
2093 static unsigned char right_bits
[] = {
2094 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2095 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2096 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2098 ${NS}::button .tf.bar.leftbut
-image bm-left
-command goback \
2099 -state disabled
-width 26
2100 pack .tf.bar.leftbut
-side left
-fill y
2101 ${NS}::button .tf.bar.rightbut
-image bm-right
-command goforw \
2102 -state disabled
-width 26
2103 pack .tf.bar.rightbut
-side left
-fill y
2105 ${NS}::label .tf.bar.rowlabel
-text [mc
"Row"]
2107 ${NS}::label .tf.bar.rownum
-width 7 -textvariable rownumsel \
2108 -relief sunken
-anchor e
2109 ${NS}::label .tf.bar.rowlabel2
-text "/"
2110 ${NS}::label .tf.bar.numcommits
-width 7 -textvariable numcommits \
2111 -relief sunken
-anchor e
2112 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2115 foreach w
{rownum numcommits
} {.tf.bar.
$w configure
-font textfont
}
2118 trace add variable selectedline
write selectedline_change
2120 # Status label and progress bar
2121 set statusw .tf.bar.status
2122 ${NS}::label
$statusw -width 15 -relief sunken
2123 pack
$statusw -side left
-padx 5
2125 set progresscanv
[ttk
::progressbar .tf.bar.progress
]
2127 set h
[expr {[font metrics uifont
-linespace] + 2}]
2128 set progresscanv .tf.bar.progress
2129 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
2130 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
2131 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
2132 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
2134 pack
$progresscanv -side right
-expand 1 -fill x
-padx {0 2}
2135 set progresscoords
{0 0}
2138 bind $progresscanv <Configure
> adjustprogress
2139 set lastprogupdate
[clock clicks
-milliseconds]
2140 set progupdatepending
0
2142 # build up the bottom bar of upper window
2143 ${NS}::label .tf.lbar.flabel
-text "[mc "Find
"] "
2144 ${NS}::button .tf.lbar.fnext
-text [mc
"next"] -command {dofind
1 1}
2145 ${NS}::button .tf.lbar.fprev
-text [mc
"prev"] -command {dofind
-1 1}
2146 ${NS}::label .tf.lbar.flab2
-text " [mc "commit
"] "
2147 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2149 set gdttype
[mc
"containing:"]
2150 set gm
[makedroplist .tf.lbar.gdttype gdttype \
2151 [mc
"containing:"] \
2152 [mc
"touching paths:"] \
2153 [mc
"adding/removing string:"]]
2154 trace add variable gdttype
write gdttype_change
2155 pack .tf.lbar.gdttype
-side left
-fill y
2158 set fstring .tf.lbar.findstring
2159 lappend entries
$fstring
2160 ${NS}::entry
$fstring -width 30 -font textfont
-textvariable findstring
2161 trace add variable findstring
write find_change
2162 set findtype
[mc
"Exact"]
2163 set findtypemenu
[makedroplist .tf.lbar.findtype \
2164 findtype
[mc
"Exact"] [mc
"IgnCase"] [mc
"Regexp"]]
2165 trace add variable findtype
write findcom_change
2166 set findloc
[mc
"All fields"]
2167 makedroplist .tf.lbar.findloc findloc
[mc
"All fields"] [mc
"Headline"] \
2168 [mc
"Comments"] [mc
"Author"] [mc
"Committer"]
2169 trace add variable findloc
write find_change
2170 pack .tf.lbar.findloc
-side right
2171 pack .tf.lbar.findtype
-side right
2172 pack
$fstring -side left
-expand 1 -fill x
2174 # Finish putting the upper half of the viewer together
2175 pack .tf.lbar
-in .tf
-side bottom
-fill x
2176 pack .tf.bar
-in .tf
-side bottom
-fill x
2177 pack .tf.histframe
-fill both
-side top
-expand 1
2180 .ctop paneconfigure .tf
-height $geometry(topheight
)
2181 .ctop paneconfigure .tf
-width $geometry(topwidth
)
2184 # now build up the bottom
2185 ${NS}::panedwindow .pwbottom
-orient horizontal
2187 # lower left, a text box over search bar, scroll bar to the right
2188 # if we know window height, then that will set the lower text height, otherwise
2189 # we set lower text height which will drive window height
2190 if {[info exists geometry
(main
)]} {
2191 ${NS}::frame .bleft
-width $geometry(botwidth
)
2193 ${NS}::frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
2195 ${NS}::frame .bleft.top
2196 ${NS}::frame .bleft.mid
2197 ${NS}::frame .bleft.bottom
2199 ${NS}::button .bleft.top.search
-text [mc
"Search"] -command dosearch
2200 pack .bleft.top.search
-side left
-padx 5
2201 set sstring .bleft.top.sstring
2203 ${NS}::entry
$sstring -width 20 -font textfont
-textvariable searchstring
2204 lappend entries
$sstring
2205 trace add variable searchstring
write incrsearch
2206 pack
$sstring -side left
-expand 1 -fill x
2207 ${NS}::radiobutton .bleft.mid.
diff -text [mc
"Diff"] \
2208 -command changediffdisp
-variable diffelide
-value {0 0}
2209 ${NS}::radiobutton .bleft.mid.old
-text [mc
"Old version"] \
2210 -command changediffdisp
-variable diffelide
-value {0 1}
2211 ${NS}::radiobutton .bleft.mid.new
-text [mc
"New version"] \
2212 -command changediffdisp
-variable diffelide
-value {1 0}
2213 ${NS}::label .bleft.mid.labeldiffcontext
-text " [mc "Lines of context
"]: "
2214 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
2215 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
2216 -from 1 -increment 1 -to 10000000 \
2217 -validate all
-validatecommand "diffcontextvalidate %P" \
2218 -textvariable diffcontextstring
2219 .bleft.mid.diffcontext
set $diffcontext
2220 trace add variable diffcontextstring
write diffcontextchange
2221 lappend entries .bleft.mid.diffcontext
2222 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
2223 ${NS}::checkbutton .bleft.mid.ignspace
-text [mc
"Ignore space change"] \
2224 -command changeignorespace
-variable ignorespace
2225 pack .bleft.mid.ignspace
-side left
-padx 5
2226 set ctext .bleft.bottom.ctext
2227 text
$ctext -background $bgcolor -foreground $fgcolor \
2228 -state disabled
-font textfont \
2229 -yscrollcommand scrolltext
-wrap none \
2230 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2232 $ctext conf
-tabstyle wordprocessor
2234 ${NS}::scrollbar .bleft.bottom.sb
-command "$ctext yview"
2235 ${NS}::scrollbar .bleft.bottom.sbhorizontal
-command "$ctext xview" -orient h
2236 pack .bleft.top
-side top
-fill x
2237 pack .bleft.mid
-side top
-fill x
2238 grid
$ctext .bleft.bottom.sb
-sticky nsew
2239 grid .bleft.bottom.sbhorizontal
-sticky ew
2240 grid columnconfigure .bleft.bottom
0 -weight 1
2241 grid rowconfigure .bleft.bottom
0 -weight 1
2242 grid rowconfigure .bleft.bottom
1 -weight 0
2243 pack .bleft.bottom
-side top
-fill both
-expand 1
2244 lappend bglist
$ctext
2245 lappend fglist
$ctext
2247 $ctext tag conf comment
-wrap $wrapcomment
2248 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
2249 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
2250 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
2251 $ctext tag conf dresult
-fore [lindex
$diffcolors 1]
2252 $ctext tag conf m0
-fore red
2253 $ctext tag conf m1
-fore blue
2254 $ctext tag conf m2
-fore green
2255 $ctext tag conf m3
-fore purple
2256 $ctext tag conf
m4 -fore brown
2257 $ctext tag conf m5
-fore "#009090"
2258 $ctext tag conf m6
-fore magenta
2259 $ctext tag conf m7
-fore "#808000"
2260 $ctext tag conf m8
-fore "#009000"
2261 $ctext tag conf m9
-fore "#ff0080"
2262 $ctext tag conf m10
-fore cyan
2263 $ctext tag conf m11
-fore "#b07070"
2264 $ctext tag conf m12
-fore "#70b0f0"
2265 $ctext tag conf m13
-fore "#70f0b0"
2266 $ctext tag conf m14
-fore "#f0b070"
2267 $ctext tag conf m15
-fore "#ff70b0"
2268 $ctext tag conf mmax
-fore darkgrey
2270 $ctext tag conf mresult
-font textfontbold
2271 $ctext tag conf msep
-font textfontbold
2272 $ctext tag conf found
-back yellow
2274 .pwbottom add .bleft
2276 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
2280 ${NS}::frame .bright
2281 ${NS}::frame .bright.mode
2282 ${NS}::radiobutton .bright.mode.
patch -text [mc
"Patch"] \
2283 -command reselectline
-variable cmitmode
-value "patch"
2284 ${NS}::radiobutton .bright.mode.tree
-text [mc
"Tree"] \
2285 -command reselectline
-variable cmitmode
-value "tree"
2286 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
2287 pack .bright.mode
-side top
-fill x
2288 set cflist .bright.cfiles
2289 set indent
[font measure mainfont
"nn"]
2291 -selectbackground $selectbgcolor \
2292 -background $bgcolor -foreground $fgcolor \
2294 -tabs [list
$indent [expr {2 * $indent}]] \
2295 -yscrollcommand ".bright.sb set" \
2296 -cursor [. cget
-cursor] \
2297 -spacing1 1 -spacing3 1
2298 lappend bglist
$cflist
2299 lappend fglist
$cflist
2300 ${NS}::scrollbar .bright.sb
-command "$cflist yview"
2301 pack .bright.sb
-side right
-fill y
2302 pack
$cflist -side left
-fill both
-expand 1
2303 $cflist tag configure highlight \
2304 -background [$cflist cget
-selectbackground]
2305 $cflist tag configure bold
-font mainfontbold
2307 .pwbottom add .bright
2310 # restore window width & height if known
2311 if {[info exists geometry
(main
)]} {
2312 if {[scan
$geometry(main
) "%dx%d" w h
] >= 2} {
2313 if {$w > [winfo screenwidth .
]} {
2314 set w
[winfo screenwidth .
]
2316 if {$h > [winfo screenheight .
]} {
2317 set h
[winfo screenheight .
]
2319 wm geometry .
"${w}x$h"
2323 if {[info exists geometry
(state
)] && $geometry(state
) eq
"zoomed"} {
2324 wm state .
$geometry(state
)
2327 if {[tk windowingsystem
] eq
{aqua
}} {
2338 %W sashpos
0 $
::geometry
(topheight
)
2340 bind .pwbottom
<Map
> {
2342 %W sashpos
0 $
::geometry
(botwidth
)
2346 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
2347 pack .ctop
-fill both
-expand 1
2348 bindall
<1> {selcanvline
%W
%x
%y
}
2349 #bindall <B1-Motion> {selcanvline %W %x %y}
2350 if {[tk windowingsystem
] == "win32"} {
2351 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
2352 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
2354 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
2355 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
2356 if {[tk windowingsystem
] eq
"aqua"} {
2357 bindall
<MouseWheel
> {
2358 set delta
[expr {- (%D
)}]
2359 allcanvs yview scroll
$delta units
2361 bindall
<Shift-MouseWheel
> {
2362 set delta
[expr {- (%D
)}]
2363 $canv xview scroll
$delta units
2367 bindall
<$
::BM
> "canvscan mark %W %x %y"
2368 bindall
<B$
::BM-Motion
> "canvscan dragto %W %x %y"
2369 bindkey
<Home
> selfirstline
2370 bindkey
<End
> sellastline
2371 bind .
<Key-Up
> "selnextline -1"
2372 bind .
<Key-Down
> "selnextline 1"
2373 bind .
<Shift-Key-Up
> "dofind -1 0"
2374 bind .
<Shift-Key-Down
> "dofind 1 0"
2375 bindkey
<Key-Right
> "goforw"
2376 bindkey
<Key-Left
> "goback"
2377 bind .
<Key-Prior
> "selnextpage -1"
2378 bind .
<Key-Next
> "selnextpage 1"
2379 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
2380 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
2381 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
2382 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
2383 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2384 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2385 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
2386 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
2387 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
2388 bindkey p
"selnextline -1"
2389 bindkey n
"selnextline 1"
2392 bindkey i
"selnextline -1"
2393 bindkey k
"selnextline 1"
2397 bindkey d
"$ctext yview scroll 18 units"
2398 bindkey u
"$ctext yview scroll -18 units"
2399 bindkey
/ {focus
$fstring}
2400 bindkey
<Key-KP_Divide
> {focus
$fstring}
2401 bindkey
<Key-Return
> {dofind
1 1}
2402 bindkey ?
{dofind
-1 1}
2404 bind .
<F5
> updatecommits
2405 bind .
<$M1B-F5> reloadcommits
2406 bind .
<F2
> showrefs
2407 bind .
<Shift-F4
> {newview
0}
2408 catch
{ bind .
<Shift-Key-XF86_Switch_VT_4
> {newview
0} }
2409 bind .
<F4
> edit_or_newview
2410 bind .
<$M1B-q> doquit
2411 bind .
<$M1B-f> {dofind
1 1}
2412 bind .
<$M1B-g> {dofind
1 0}
2413 bind .
<$M1B-r> dosearchback
2414 bind .
<$M1B-s> dosearch
2415 bind .
<$M1B-equal> {incrfont
1}
2416 bind .
<$M1B-plus> {incrfont
1}
2417 bind .
<$M1B-KP_Add> {incrfont
1}
2418 bind .
<$M1B-minus> {incrfont
-1}
2419 bind .
<$M1B-KP_Subtract> {incrfont
-1}
2420 wm protocol . WM_DELETE_WINDOW doquit
2421 bind .
<Destroy
> {stop_backends
}
2422 bind .
<Button-1
> "click %W"
2423 bind $fstring <Key-Return
> {dofind
1 1}
2424 bind $sha1entry <Key-Return
> {gotocommit
; break}
2425 bind $sha1entry <<PasteSelection>> clearsha1
2426 bind $cflist <1> {sel_flist %W %x %y; break}
2427 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2428 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2430 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2431 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2433 set maincursor [. cget -cursor]
2434 set textcursor [$ctext cget -cursor]
2435 set curtextcursor $textcursor
2437 set rowctxmenu .rowctxmenu
2438 makemenu $rowctxmenu {
2439 {mc "Diff this -> selected" command {diffvssel 0}}
2440 {mc "Diff selected -> this" command {diffvssel 1}}
2441 {mc "Make patch" command mkpatch}
2442 {mc "Create tag" command mktag}
2443 {mc "Write commit to file" command writecommit}
2444 {mc "Create new branch" command mkbranch}
2445 {mc "Cherry-pick this commit" command cherrypick}
2446 {mc "Reset HEAD branch to here" command resethead}
2447 {mc "Mark this commit" command markhere}
2448 {mc "Return to mark" command gotomark}
2449 {mc "Find descendant of this and mark" command find_common_desc}
2450 {mc "Compare with marked commit" command compare_commits}
2452 $rowctxmenu configure -tearoff 0
2454 set fakerowmenu .fakerowmenu
2455 makemenu $fakerowmenu {
2456 {mc "Diff this -> selected" command {diffvssel 0}}
2457 {mc "Diff selected -> this" command {diffvssel 1}}
2458 {mc "Make patch" command mkpatch}
2460 $fakerowmenu configure -tearoff 0
2462 set headctxmenu .headctxmenu
2463 makemenu $headctxmenu {
2464 {mc "Check out this branch" command cobranch}
2465 {mc "Remove this branch" command rmbranch}
2467 $headctxmenu configure -tearoff 0
2470 set flist_menu .flistctxmenu
2471 makemenu $flist_menu {
2472 {mc "Highlight this too" command {flist_hl 0}}
2473 {mc "Highlight this only" command {flist_hl 1}}
2474 {mc "External diff" command {external_diff}}
2475 {mc "Blame parent commit" command {external_blame 1}}
2477 $flist_menu configure -tearoff 0
2480 set diff_menu .diffctxmenu
2481 makemenu $diff_menu {
2482 {mc "Show origin of this line" command show_line_source}
2483 {mc "Run git gui blame on this line" command {external_blame_diff}}
2485 $diff_menu configure -tearoff 0
2488 # Windows sends all mouse wheel events to the current focused window, not
2489 # the one where the mouse hovers, so bind those events here and redirect
2490 # to the correct window
2491 proc windows_mousewheel_redirector {W X Y D} {
2492 global canv canv2 canv3
2493 set w [winfo containing -displayof $W $X $Y]
2495 set u [expr {$D < 0 ? 5 : -5}]
2496 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2497 allcanvs yview scroll $u units
2500 $w yview scroll $u units
2506 # Update row number label when selectedline changes
2507 proc selectedline_change {n1 n2 op} {
2508 global selectedline rownumsel
2510 if {$selectedline eq {}} {
2513 set rownumsel [expr {$selectedline + 1}]
2517 # mouse-2 makes all windows scan vertically, but only the one
2518 # the cursor is in scans horizontally
2519 proc canvscan {op w x y} {
2520 global canv canv2 canv3
2521 foreach c [list $canv $canv2 $canv3] {
2530 proc scrollcanv {cscroll f0 f1} {
2531 $cscroll set $f0 $f1
2536 # when we make a key binding for the toplevel, make sure
2537 # it doesn't get triggered when that key is pressed in the
2538 # find string entry widget.
2539 proc bindkey {ev script} {
2542 set escript [bind Entry $ev]
2543 if {$escript == {}} {
2544 set escript [bind Entry <Key>]
2546 foreach e $entries {
2547 bind $e $ev "$escript; break"
2551 # set the focus back to the toplevel for any click outside
2554 global ctext entries
2555 foreach e [concat $entries $ctext] {
2556 if {$w == $e} return
2561 # Adjust the progress bar for a change in requested extent or canvas size
2562 proc adjustprogress {} {
2563 global progresscanv progressitem progresscoords
2564 global fprogitem fprogcoord lastprogupdate progupdatepending
2565 global rprogitem rprogcoord use_ttk
2568 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2572 set w [expr {[winfo width $progresscanv] - 4}]
2573 set x0 [expr {$w * [lindex $progresscoords 0]}]
2574 set x1 [expr {$w * [lindex $progresscoords 1]}]
2575 set h [winfo height $progresscanv]
2576 $progresscanv coords $progressitem $x0 0 $x1 $h
2577 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2578 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2579 set now [clock clicks -milliseconds]
2580 if {$now >= $lastprogupdate + 100} {
2581 set progupdatepending 0
2583 } elseif {!$progupdatepending} {
2584 set progupdatepending 1
2585 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2589 proc doprogupdate {} {
2590 global lastprogupdate progupdatepending
2592 if {$progupdatepending} {
2593 set progupdatepending 0
2594 set lastprogupdate [clock clicks -milliseconds]
2599 proc savestuff {w} {
2600 global canv canv2 canv3 mainfont textfont uifont tabstop
2601 global stuffsaved findmergefiles maxgraphpct
2602 global maxwidth showneartags showlocalchanges
2603 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2604 global cmitmode wrapcomment datetimeformat limitdiffs
2605 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
2606 global autoselect extdifftool perfile_attrs markbgcolor use_ttk
2608 if {$stuffsaved} return
2609 if {![winfo viewable .]} return
2611 set f [open "~/.gitk-new" w]
2612 if {$::tcl_platform(platform) eq {windows}} {
2613 file attributes "~/.gitk-new" -hidden true
2615 puts $f [list set mainfont $mainfont]
2616 puts $f [list set textfont $textfont]
2617 puts $f [list set uifont $uifont]
2618 puts $f [list set tabstop $tabstop]
2619 puts $f [list set findmergefiles $findmergefiles]
2620 puts $f [list set maxgraphpct $maxgraphpct]
2621 puts $f [list set maxwidth $maxwidth]
2622 puts $f [list set cmitmode $cmitmode]
2623 puts $f [list set wrapcomment $wrapcomment]
2624 puts $f [list set autoselect $autoselect]
2625 puts $f [list set showneartags $showneartags]
2626 puts $f [list set showlocalchanges $showlocalchanges]
2627 puts $f [list set datetimeformat $datetimeformat]
2628 puts $f [list set limitdiffs $limitdiffs]
2629 puts $f [list set bgcolor $bgcolor]
2630 puts $f [list set fgcolor $fgcolor]
2631 puts $f [list set colors $colors]
2632 puts $f [list set diffcolors $diffcolors]
2633 puts $f [list set markbgcolor $markbgcolor]
2634 puts $f [list set diffcontext $diffcontext]
2635 puts $f [list set selectbgcolor $selectbgcolor]
2636 puts $f [list set extdifftool $extdifftool]
2637 puts $f [list set perfile_attrs $perfile_attrs]
2639 puts $f "set geometry(main) [wm geometry .]"
2640 puts $f "set geometry(state) [wm state .]"
2641 puts $f "set geometry(topwidth) [winfo width .tf]"
2642 puts $f "set geometry(topheight) [winfo height .tf]"
2644 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2645 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2647 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2648 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2650 puts $f "set geometry(botwidth) [winfo width .bleft]"
2651 puts $f "set geometry(botheight) [winfo height .bleft]"
2653 puts -nonewline $f "set permviews {"
2654 for {set v 0} {$v < $nextviewnum} {incr v} {
2655 if {$viewperm($v)} {
2656 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2661 file rename -force "~/.gitk-new" "~/.gitk"
2666 proc resizeclistpanes {win w} {
2667 global oldwidth use_ttk
2668 if {[info exists oldwidth($win)]} {
2670 set s0 [$win sashpos 0]
2671 set s1 [$win sashpos 1]
2673 set s0 [$win sash coord 0]
2674 set s1 [$win sash coord 1]
2677 set sash0 [expr {int($w/2 - 2)}]
2678 set sash1 [expr {int($w*5/6 - 2)}]
2680 set factor [expr {1.0 * $w / $oldwidth($win)}]
2681 set sash0 [expr {int($factor * [lindex $s0 0])}]
2682 set sash1 [expr {int($factor * [lindex $s1 0])}]
2686 if {$sash1 < $sash0 + 20} {
2687 set sash1 [expr {$sash0 + 20}]
2689 if {$sash1 > $w - 10} {
2690 set sash1 [expr {$w - 10}]
2691 if {$sash0 > $sash1 - 20} {
2692 set sash0 [expr {$sash1 - 20}]
2697 $win sashpos 0 $sash0
2698 $win sashpos 1 $sash1
2700 $win sash place 0 $sash0 [lindex $s0 1]
2701 $win sash place 1 $sash1 [lindex $s1 1]
2704 set oldwidth($win) $w
2707 proc resizecdetpanes {win w} {
2708 global oldwidth use_ttk
2709 if {[info exists oldwidth($win)]} {
2711 set s0 [$win sashpos 0]
2713 set s0 [$win sash coord 0]
2716 set sash0 [expr {int($w*3/4 - 2)}]
2718 set factor [expr {1.0 * $w / $oldwidth($win)}]
2719 set sash0 [expr {int($factor * [lindex $s0 0])}]
2723 if {$sash0 > $w - 15} {
2724 set sash0 [expr {$w - 15}]
2728 $win sashpos 0 $sash0
2730 $win sash place 0 $sash0 [lindex $s0 1]
2733 set oldwidth($win) $w
2736 proc allcanvs args {
2737 global canv canv2 canv3
2743 proc bindall {event action} {
2744 global canv canv2 canv3
2745 bind $canv $event $action
2746 bind $canv2 $event $action
2747 bind $canv3 $event $action
2753 if {[winfo exists $w]} {
2758 wm title $w [mc "About gitk"]
2760 message $w.m -text [mc "
2761 Gitk - a commit viewer for git
2763 Copyright \u00a9 2005-2009 Paul Mackerras
2765 Use and redistribute under the terms of the GNU General Public License"] \
2766 -justify center -aspect 400 -border 2 -bg white -relief groove
2767 pack $w.m -side top -fill x -padx 2 -pady 2
2768 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2769 pack $w.ok -side bottom
2770 bind $w <Visibility> "focus $w.ok"
2771 bind $w <Key-Escape> "destroy $w"
2772 bind $w <Key-Return> "destroy $w"
2773 tk::PlaceWindow $w widget .
2779 if {[winfo exists $w]} {
2783 if {[tk windowingsystem] eq {aqua}} {
2789 wm title $w [mc "Gitk key bindings"]
2791 message $w.m -text "
2792 [mc "Gitk key bindings:"]
2794 [mc "<%s-Q> Quit" $M1T]
2795 [mc "<Home> Move to first commit"]
2796 [mc "<End> Move to last commit"]
2797 [mc "<Up>, p, i Move up one commit"]
2798 [mc "<Down>, n, k Move down one commit"]
2799 [mc "<Left>, z, j Go back in history list"]
2800 [mc "<Right>, x, l Go forward in history list"]
2801 [mc "<PageUp> Move up one page in commit list"]
2802 [mc "<PageDown> Move down one page in commit list"]
2803 [mc "<%s-Home> Scroll to top of commit list" $M1T]
2804 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
2805 [mc "<%s-Up> Scroll commit list up one line" $M1T]
2806 [mc "<%s-Down> Scroll commit list down one line" $M1T]
2807 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
2808 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
2809 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
2810 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
2811 [mc "<Delete>, b Scroll diff view up one page"]
2812 [mc "<Backspace> Scroll diff view up one page"]
2813 [mc "<Space> Scroll diff view down one page"]
2814 [mc "u Scroll diff view up 18 lines"]
2815 [mc "d Scroll diff view down 18 lines"]
2816 [mc "<%s-F> Find" $M1T]
2817 [mc "<%s-G> Move to next find hit" $M1T]
2818 [mc "<Return> Move to next find hit"]
2819 [mc "/ Focus the search box"]
2820 [mc "? Move to previous find hit"]
2821 [mc "f Scroll diff view to next file"]
2822 [mc "<%s-S> Search for next hit in diff view" $M1T]
2823 [mc "<%s-R> Search for previous hit in diff view" $M1T]
2824 [mc "<%s-KP+> Increase font size" $M1T]
2825 [mc "<%s-plus> Increase font size" $M1T]
2826 [mc "<%s-KP-> Decrease font size" $M1T]
2827 [mc "<%s-minus> Decrease font size" $M1T]
2830 -justify left -bg white -border 2 -relief groove
2831 pack $w.m -side top -fill both -padx 2 -pady 2
2832 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2833 bind $w <Key-Escape> [list destroy $w]
2834 pack $w.ok -side bottom
2835 bind $w <Visibility> "focus $w.ok"
2836 bind $w <Key-Escape> "destroy $w"
2837 bind $w <Key-Return> "destroy $w"
2840 # Procedures for manipulating the file list window at the
2841 # bottom right of the overall window.
2843 proc treeview {w l openlevs} {
2844 global treecontents treediropen treeheight treeparent treeindex
2854 set treecontents() {}
2855 $w conf -state normal
2857 while {[string range $f 0 $prefixend] ne $prefix} {
2858 if {$lev <= $openlevs} {
2859 $w mark set e:$treeindex($prefix) "end -1c"
2860 $w mark gravity e:$treeindex($prefix) left
2862 set treeheight($prefix) $ht
2863 incr ht [lindex $htstack end]
2864 set htstack [lreplace $htstack end end]
2865 set prefixend [lindex $prefendstack end]
2866 set prefendstack [lreplace $prefendstack end end]
2867 set prefix [string range $prefix 0 $prefixend]
2870 set tail [string range $f [expr {$prefixend+1}] end]
2871 while {[set slash [string first "/" $tail]] >= 0} {
2874 lappend prefendstack $prefixend
2875 incr prefixend [expr {$slash + 1}]
2876 set d [string range $tail 0 $slash]
2877 lappend treecontents($prefix) $d
2878 set oldprefix $prefix
2880 set treecontents($prefix) {}
2881 set treeindex($prefix) [incr ix]
2882 set treeparent($prefix) $oldprefix
2883 set tail [string range $tail [expr {$slash+1}] end]
2884 if {$lev <= $openlevs} {
2886 set treediropen($prefix) [expr {$lev < $openlevs}]
2887 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2888 $w mark set d:$ix "end -1c"
2889 $w mark gravity d:$ix left
2891 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2893 $w image create end -align center -image $bm -padx 1 \
2895 $w insert end $d [highlight_tag $prefix]
2896 $w mark set s:$ix "end -1c"
2897 $w mark gravity s:$ix left
2902 if {$lev <= $openlevs} {
2905 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2907 $w insert end $tail [highlight_tag $f]
2909 lappend treecontents($prefix) $tail
2912 while {$htstack ne {}} {
2913 set treeheight($prefix) $ht
2914 incr ht [lindex $htstack end]
2915 set htstack [lreplace $htstack end end]
2916 set prefixend [lindex $prefendstack end]
2917 set prefendstack [lreplace $prefendstack end end]
2918 set prefix [string range $prefix 0 $prefixend]
2920 $w conf -state disabled
2923 proc linetoelt {l} {
2924 global treeheight treecontents
2929 foreach e $treecontents($prefix) {
2934 if {[string index $e end] eq "/"} {
2935 set n $treeheight($prefix$e)
2947 proc highlight_tree {y prefix} {
2948 global treeheight treecontents cflist
2950 foreach e $treecontents($prefix) {
2952 if {[highlight_tag $path] ne {}} {
2953 $cflist tag add bold $y.0 "$y.0 lineend"
2956 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2957 set y [highlight_tree $y $path]
2963 proc treeclosedir {w dir} {
2964 global treediropen treeheight treeparent treeindex
2966 set ix $treeindex($dir)
2967 $w conf -state normal
2968 $w delete s:$ix e:$ix
2969 set treediropen($dir) 0
2970 $w image configure a:$ix -image tri-rt
2971 $w conf -state disabled
2972 set n [expr {1 - $treeheight($dir)}]
2973 while {$dir ne {}} {
2974 incr treeheight($dir) $n
2975 set dir $treeparent($dir)
2979 proc treeopendir {w dir} {
2980 global treediropen treeheight treeparent treecontents treeindex
2982 set ix $treeindex($dir)
2983 $w conf -state normal
2984 $w image configure a:$ix -image tri-dn
2985 $w mark set e:$ix s:$ix
2986 $w mark gravity e:$ix right
2989 set n [llength $treecontents($dir)]
2990 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2993 incr treeheight($x) $n
2995 foreach e $treecontents($dir) {
2997 if {[string index $e end] eq "/"} {
2998 set iy $treeindex($de)
2999 $w mark set d:$iy e:$ix
3000 $w mark gravity d:$iy left
3001 $w insert e:$ix $str
3002 set treediropen($de) 0
3003 $w image create e:$ix -align center -image tri-rt -padx 1 \
3005 $w insert e:$ix $e [highlight_tag $de]
3006 $w mark set s:$iy e:$ix
3007 $w mark gravity s:$iy left
3008 set treeheight($de) 1
3010 $w insert e:$ix $str
3011 $w insert e:$ix $e [highlight_tag $de]
3014 $w mark gravity e:$ix right
3015 $w conf -state disabled
3016 set treediropen($dir) 1
3017 set top [lindex [split [$w index @0,0] .] 0]
3018 set ht [$w cget -height]
3019 set l [lindex [split [$w index s:$ix] .] 0]
3022 } elseif {$l + $n + 1 > $top + $ht} {
3023 set top [expr {$l + $n + 2 - $ht}]
3031 proc treeclick {w x y} {
3032 global treediropen cmitmode ctext cflist cflist_top
3034 if {$cmitmode ne "tree"} return
3035 if {![info exists cflist_top]} return
3036 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3037 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3038 $cflist tag add highlight $l.0 "$l.0 lineend"
3044 set e [linetoelt $l]
3045 if {[string index $e end] ne "/"} {
3047 } elseif {$treediropen($e)} {
3054 proc setfilelist {id} {
3055 global treefilelist cflist jump_to_here
3057 treeview $cflist $treefilelist($id) 0
3058 if {$jump_to_here ne {}} {
3059 set f [lindex $jump_to_here 0]
3060 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3066 image create bitmap tri-rt -background black -foreground blue -data {
3067 #define tri-rt_width 13
3068 #define tri-rt_height 13
3069 static unsigned char tri-rt_bits[] = {
3070 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3071 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3074 #define tri-rt-mask_width 13
3075 #define tri-rt-mask_height 13
3076 static unsigned char tri-rt-mask_bits[] = {
3077 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3078 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3081 image create bitmap tri-dn -background black -foreground blue -data {
3082 #define tri-dn_width 13
3083 #define tri-dn_height 13
3084 static unsigned char tri-dn_bits[] = {
3085 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3086 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3089 #define tri-dn-mask_width 13
3090 #define tri-dn-mask_height 13
3091 static unsigned char tri-dn-mask_bits[] = {
3092 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3093 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3097 image create bitmap reficon-T -background black -foreground yellow -data {
3098 #define tagicon_width 13
3099 #define tagicon_height 9
3100 static unsigned char tagicon_bits[] = {
3101 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3102 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3104 #define tagicon-mask_width 13
3105 #define tagicon-mask_height 9
3106 static unsigned char tagicon-mask_bits[] = {
3107 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3108 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3111 #define headicon_width 13
3112 #define headicon_height 9
3113 static unsigned char headicon_bits[] = {
3114 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3115 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3118 #define headicon-mask_width 13
3119 #define headicon-mask_height 9
3120 static unsigned char headicon-mask_bits[] = {
3121 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3122 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3124 image create bitmap reficon-H -background black -foreground green \
3125 -data $rectdata -maskdata $rectmask
3126 image create bitmap reficon-o -background black -foreground "#ddddff" \
3127 -data $rectdata -maskdata $rectmask
3129 proc init_flist {first} {
3130 global cflist cflist_top difffilestart
3132 $cflist conf -state normal
3133 $cflist delete 0.0 end
3135 $cflist insert end $first
3137 $cflist tag add highlight 1.0 "1.0 lineend"
3139 catch {unset cflist_top}
3141 $cflist conf -state disabled
3142 set difffilestart {}
3145 proc highlight_tag {f} {
3146 global highlight_paths
3148 foreach p $highlight_paths {
3149 if {[string match $p $f]} {
3156 proc highlight_filelist {} {
3157 global cmitmode cflist
3159 $cflist conf -state normal
3160 if {$cmitmode ne "tree"} {
3161 set end [lindex [split [$cflist index end] .] 0]
3162 for {set l 2} {$l < $end} {incr l} {
3163 set line [$cflist get $l.0 "$l.0 lineend"]
3164 if {[highlight_tag $line] ne {}} {
3165 $cflist tag add bold $l.0 "$l.0 lineend"
3171 $cflist conf -state disabled
3174 proc unhighlight_filelist {} {
3177 $cflist conf -state normal
3178 $cflist tag remove bold 1.0 end
3179 $cflist conf -state disabled
3182 proc add_flist {fl} {
3185 $cflist conf -state normal
3187 $cflist insert end "\n"
3188 $cflist insert end $f [highlight_tag $f]
3190 $cflist conf -state disabled
3193 proc sel_flist {w x y} {
3194 global ctext difffilestart cflist cflist_top cmitmode
3196 if {$cmitmode eq "tree"} return
3197 if {![info exists cflist_top]} return
3198 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3199 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3200 $cflist tag add highlight $l.0 "$l.0 lineend"
3205 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3209 proc pop_flist_menu {w X Y x y} {
3210 global ctext cflist cmitmode flist_menu flist_menu_file
3211 global treediffs diffids
3214 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3216 if {$cmitmode eq "tree"} {
3217 set e [linetoelt $l]
3218 if {[string index $e end] eq "/"} return
3220 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3222 set flist_menu_file $e
3223 set xdiffstate "normal"
3224 if {$cmitmode eq "tree"} {
3225 set xdiffstate "disabled"
3227 # Disable "External diff" item in tree mode
3228 $flist_menu entryconf 2 -state $xdiffstate
3229 tk_popup $flist_menu $X $Y
3232 proc find_ctext_fileinfo {line} {
3233 global ctext_file_names ctext_file_lines
3235 set ok [bsearch $ctext_file_lines $line]
3236 set tline [lindex $ctext_file_lines $ok]
3238 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3241 return [list [lindex $ctext_file_names $ok] $tline]
3245 proc pop_diff_menu {w X Y x y} {
3246 global ctext diff_menu flist_menu_file
3247 global diff_menu_txtpos diff_menu_line
3248 global diff_menu_filebase
3250 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3251 set diff_menu_line [lindex $diff_menu_txtpos 0]
3252 # don't pop up the menu on hunk-separator or file-separator lines
3253 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3257 set f [find_ctext_fileinfo $diff_menu_line]
3258 if {$f eq {}} return
3259 set flist_menu_file [lindex $f 0]
3260 set diff_menu_filebase [lindex $f 1]
3261 tk_popup $diff_menu $X $Y
3264 proc flist_hl {only} {
3265 global flist_menu_file findstring gdttype
3267 set x [shellquote $flist_menu_file]
3268 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3271 append findstring " " $x
3273 set gdttype [mc "touching paths:"]
3276 proc save_file_from_commit {filename output what} {
3279 if {[catch {exec git show $filename -- > $output} err]} {
3280 if {[string match "fatal: bad revision *" $err]} {
3283 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3289 proc external_diff_get_one_file {diffid filename diffdir} {
3290 global nullid nullid2 nullfile
3293 if {$diffid == $nullid} {
3294 set difffile [file join [file dirname $gitdir] $filename]
3295 if {[file exists $difffile]} {
3300 if {$diffid == $nullid2} {
3301 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3302 return [save_file_from_commit :$filename $difffile index]
3304 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3305 return [save_file_from_commit $diffid:$filename $difffile \
3309 proc external_diff {} {
3310 global gitktmpdir nullid nullid2
3311 global flist_menu_file
3314 global gitdir extdifftool
3316 if {[llength $diffids] == 1} {
3317 # no reference commit given
3318 set diffidto [lindex $diffids 0]
3319 if {$diffidto eq $nullid} {
3320 # diffing working copy with index
3321 set diffidfrom $nullid2
3322 } elseif {$diffidto eq $nullid2} {
3323 # diffing index with HEAD
3324 set diffidfrom "HEAD"
3326 # use first parent commit
3327 global parentlist selectedline
3328 set diffidfrom [lindex $parentlist $selectedline 0]
3331 set diffidfrom [lindex $diffids 0]
3332 set diffidto [lindex $diffids 1]
3335 # make sure that several diffs wont collide
3336 if {![info exists gitktmpdir]} {
3337 set gitktmpdir [file join [file dirname $gitdir] \
3338 [format ".gitk-tmp.%s" [pid]]]
3339 if {[catch {file mkdir $gitktmpdir} err]} {
3340 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3347 set diffdir [file join $gitktmpdir $diffnum]
3348 if {[catch {file mkdir $diffdir} err]} {
3349 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3353 # gather files to diff
3354 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3355 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3357 if {$difffromfile ne {} && $difftofile ne {}} {
3358 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3359 if {[catch {set fl [open |$cmd r]} err]} {
3360 file delete -force $diffdir
3361 error_popup "$extdifftool: [mc "command failed:"] $err"
3363 fconfigure $fl -blocking 0
3364 filerun $fl [list delete_at_eof $fl $diffdir]
3369 proc find_hunk_blamespec {base line} {
3372 # Find and parse the hunk header
3373 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3374 if {$s_lix eq {}} return
3376 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3377 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3378 s_line old_specs osz osz1 new_line nsz]} {
3382 # base lines for the parents
3383 set base_lines [list $new_line]
3384 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3385 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3386 old_spec old_line osz]} {
3389 lappend base_lines $old_line
3392 # Now scan the lines to determine offset within the hunk
3393 set max_parent [expr {[llength $base_lines]-2}]
3395 set s_lno [lindex [split $s_lix "."] 0]
3397 # Determine if the line is removed
3398 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3399 if {[string match {[-+ ]*} $chunk]} {
3400 set removed_idx [string first "-" $chunk]
3401 # Choose a parent index
3402 if {$removed_idx >= 0} {
3403 set parent $removed_idx
3405 set unchanged_idx [string first " " $chunk]
3406 if {$unchanged_idx >= 0} {
3407 set parent $unchanged_idx
3409 # blame the current commit
3413 # then count other lines that belong to it
3414 for {set i $line} {[incr i -1] > $s_lno} {} {
3415 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3416 # Determine if the line is removed
3417 set removed_idx [string first "-" $chunk]
3419 set code [string index $chunk $parent]
3420 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3424 if {$removed_idx < 0} {
3434 incr dline [lindex $base_lines $parent]
3435 return [list $parent $dline]
3438 proc external_blame_diff {} {
3439 global currentid cmitmode
3440 global diff_menu_txtpos diff_menu_line
3441 global diff_menu_filebase flist_menu_file
3443 if {$cmitmode eq "tree"} {
3445 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3447 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3449 set parent_idx [lindex $hinfo 0]
3450 set line [lindex $hinfo 1]
3457 external_blame $parent_idx $line
3460 # Find the SHA1 ID of the blob for file $fname in the index
3462 proc index_sha1 {fname} {
3463 set f [open [list | git ls-files -s $fname] r]
3464 while {[gets $f line] >= 0} {
3465 set info [lindex [split $line "\t"] 0]
3466 set stage [lindex $info 2]
3467 if {$stage eq "0" || $stage eq "2"} {
3469 return [lindex $info 1]
3476 # Turn an absolute path into one relative to the current directory
3477 proc make_relative {f} {
3478 set elts [file split $f]
3479 set here [file split [pwd]]
3484 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3491 set elts [concat $res [lrange $elts $ei end]]
3492 return [eval file join $elts]
3495 proc external_blame {parent_idx {line {}}} {
3496 global flist_menu_file gitdir
3497 global nullid nullid2
3498 global parentlist selectedline currentid
3500 if {$parent_idx > 0} {
3501 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3503 set base_commit $currentid
3506 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3507 error_popup [mc "No such commit"]
3511 set cmdline [list git gui blame]
3512 if {$line ne {} && $line > 1} {
3513 lappend cmdline "--line=$line"
3515 set f [file join [file dirname $gitdir] $flist_menu_file]
3516 # Unfortunately it seems git gui blame doesn't like
3517 # being given an absolute path...
3518 set f [make_relative $f]
3519 lappend cmdline $base_commit $f
3520 if {[catch {eval exec $cmdline &} err]} {
3521 error_popup "[mc "git gui blame: command failed:"] $err"
3525 proc show_line_source {} {
3526 global cmitmode currentid parents curview blamestuff blameinst
3527 global diff_menu_line diff_menu_filebase flist_menu_file
3528 global nullid nullid2 gitdir
3531 if {$cmitmode eq "tree"} {
3533 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3535 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3536 if {$h eq {}} return
3537 set pi [lindex $h 0]
3539 mark_ctext_line $diff_menu_line
3543 if {$currentid eq $nullid} {
3545 # must be a merge in progress...
3547 # get the last line from .git/MERGE_HEAD
3548 set f [open [file join $gitdir MERGE_HEAD] r]
3549 set id [lindex [split [read $f] "\n"] end-1]
3552 error_popup [mc "Couldn't read merge head: %s" $err]
3555 } elseif {$parents($curview,$currentid) eq $nullid2} {
3556 # need to do the blame from the index
3558 set from_index [index_sha1 $flist_menu_file]
3560 error_popup [mc "Error reading index: %s" $err]
3564 set id $parents($curview,$currentid)
3567 set id [lindex $parents($curview,$currentid) $pi]
3569 set line [lindex $h 1]
3572 if {$from_index ne {}} {
3573 lappend blameargs | git cat-file blob $from_index
3575 lappend blameargs | git blame -p -L$line,+1
3576 if {$from_index ne {}} {
3577 lappend blameargs --contents -
3579 lappend blameargs $id
3581 lappend blameargs -- [file join [file dirname $gitdir] $flist_menu_file]
3583 set f [open $blameargs r]
3585 error_popup [mc "Couldn't start git blame: %s" $err]
3588 nowbusy blaming [mc "Searching"]
3589 fconfigure $f -blocking 0
3590 set i [reg_instance $f]
3591 set blamestuff($i) {}
3593 filerun $f [list read_line_source $f $i]
3596 proc stopblaming {} {
3599 if {[info exists blameinst]} {
3600 stop_instance $blameinst
3606 proc read_line_source {fd inst} {
3607 global blamestuff curview commfd blameinst nullid nullid2
3609 while {[gets $fd line] >= 0} {
3610 lappend blamestuff($inst) $line
3618 fconfigure $fd -blocking 1
3619 if {[catch {close $fd} err]} {
3620 error_popup [mc "Error running git blame: %s" $err]
3625 set line [split [lindex $blamestuff($inst) 0] " "]
3626 set id [lindex $line 0]
3627 set lnum [lindex $line 1]
3628 if {[string length $id] == 40 && [string is xdigit $id] &&
3629 [string is digit -strict $lnum]} {
3630 # look for "filename" line
3631 foreach l $blamestuff($inst) {
3632 if {[string match "filename *" $l]} {
3633 set fname [string range $l 9 end]
3639 # all looks good, select it
3640 if {$id eq $nullid} {
3641 # blame uses all-zeroes to mean not committed,
3642 # which would mean a change in the index
3645 if {[commitinview $id $curview]} {
3646 selectline [rowofcommit $id] 1 [list $fname $lnum]
3648 error_popup [mc "That line comes from commit %s, \
3649 which is not in this view" [shortids $id]]
3652 puts "oops couldn't parse git blame output"
3657 # delete $dir when we see eof on $f (presumably because the child has exited)
3658 proc delete_at_eof {f dir} {
3659 while {[gets $f line] >= 0} {}
3661 if {[catch {close $f} err]} {
3662 error_popup "[mc "External diff viewer failed:"] $err"
3664 file delete -force $dir
3670 # Functions for adding and removing shell-type quoting
3672 proc shellquote {str} {
3673 if {![string match "*\['\"\\ \t]*" $str]} {
3676 if {![string match "*\['\"\\]*" $str]} {
3679 if {![string match "*'*" $str]} {
3682 return "\"[string map {\" \\\" \\ \\\\} $str]\""
3685 proc shellarglist {l} {
3691 append str [shellquote $a]
3696 proc shelldequote {str} {
3701 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3702 append ret [string range $str $used end]
3703 set used [string length $str]
3706 set first [lindex $first 0]
3707 set ch [string index $str $first]
3708 if {$first > $used} {
3709 append ret [string range $str $used [expr {$first - 1}]]
3712 if {$ch eq " " || $ch eq "\t"} break
3715 set first [string first "'" $str $used]
3717 error "unmatched single-quote"
3719 append ret [string range $str $used [expr {$first - 1}]]
3724 if {$used >= [string length $str]} {
3725 error "trailing backslash"
3727 append ret [string index $str $used]
3732 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3733 error "unmatched double-quote"
3735 set first [lindex $first 0]
3736 set ch [string index $str $first]
3737 if {$first > $used} {
3738 append ret [string range $str $used [expr {$first - 1}]]
3741 if {$ch eq "\""} break
3743 append ret [string index $str $used]
3747 return [list $used $ret]
3750 proc shellsplit {str} {
3753 set str [string trimleft $str]
3754 if {$str eq {}} break
3755 set dq [shelldequote $str]
3756 set n [lindex $dq 0]
3757 set word [lindex $dq 1]
3758 set str [string range $str $n end]
3764 # Code to implement multiple views
3766 proc newview {ishighlight} {
3767 global nextviewnum newviewname newishighlight
3768 global revtreeargs viewargscmd newviewopts curview
3770 set newishighlight $ishighlight
3772 if {[winfo exists $top]} {
3776 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3777 set newviewopts($nextviewnum,perm) 0
3778 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
3779 decode_view_opts $nextviewnum $revtreeargs
3780 vieweditor $top $nextviewnum [mc "Gitk view definition"]
3783 set known_view_options {
3784 {perm b . {} {mc "Remember this view"}}
3785 {args t50= + {} {mc "Commits to include (arguments to git log):"}}
3786 {all b * "--all" {mc "Use all refs"}}
3787 {dorder b . {"--date-order" "-d"} {mc "Strictly sort by date"}}
3788 {lright b . "--left-right" {mc "Mark branch sides"}}
3789 {since t15 + {"--since=*" "--after=*"} {mc "Since date:"}}
3790 {until t15 . {"--until=*" "--before=*"} {mc "Until date:"}}
3791 {limit t10 + "--max-count=*" {mc "Max count:"}}
3792 {skip t10 . "--skip=*" {mc "Skip:"}}
3793 {first b . "--first-parent" {mc "Limit to first parent"}}
3794 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
3797 proc encode_view_opts {n} {
3798 global known_view_options newviewopts
3801 foreach opt $known_view_options {
3802 set patterns [lindex $opt 3]
3803 if {$patterns eq {}} continue
3804 set pattern [lindex $patterns 0]
3806 set val $newviewopts($n,[lindex $opt 0])
3808 if {[lindex $opt 1] eq "b"} {
3810 lappend rargs $pattern
3813 set val [string trim $val]
3815 set pfix [string range $pattern 0 end-1]
3816 lappend rargs $pfix$val
3820 return [concat $rargs [shellsplit $newviewopts($n,args)]]
3823 proc decode_view_opts {n view_args} {
3824 global known_view_options newviewopts
3826 foreach opt $known_view_options {
3827 if {[lindex $opt 1] eq "b"} {
3832 set newviewopts($n,[lindex $opt 0]) $val
3835 foreach arg $view_args {
3836 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
3837 && ![info exists found(limit)]} {
3838 set newviewopts($n,limit) $cnt
3843 foreach opt $known_view_options {
3844 set id [lindex $opt 0]
3845 if {[info exists found($id)]} continue
3846 foreach pattern [lindex $opt 3] {
3847 if {![string match $pattern $arg]} continue
3848 if {[lindex $opt 1] ne "b"} {
3849 set size [string length $pattern]
3850 set val [string range $arg [expr {$size-1}] end]
3854 set newviewopts($n,$id) $val
3858 if {[info exists val]} break
3860 if {[info exists val]} continue
3863 set newviewopts($n,args) [shellarglist $oargs]
3866 proc edit_or_newview {} {
3878 global viewname viewperm newviewname newviewopts
3879 global viewargs viewargscmd
3881 set top .gitkvedit-$curview
3882 if {[winfo exists $top]} {
3886 set newviewname($curview) $viewname($curview)
3887 set newviewopts($curview,perm) $viewperm($curview)
3888 set newviewopts($curview,cmd) $viewargscmd($curview)
3889 decode_view_opts $curview $viewargs($curview)
3890 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
3893 proc vieweditor {top n title} {
3894 global newviewname newviewopts viewfiles bgcolor
3895 global known_view_options NS
3898 wm title $top $title
3899 make_transient $top .
3902 ${NS}::frame $top.nfr
3903 ${NS}::label $top.nl -text [mc "Name"]
3904 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
3905 pack $top.nfr -in $top -fill x -pady 5 -padx 3
3906 pack $top.nl -in $top.nfr -side left -padx {0 30}
3907 pack $top.name -in $top.nfr -side left
3913 foreach opt $known_view_options {
3914 set id [lindex $opt 0]
3915 set type [lindex $opt 1]
3916 set flags [lindex $opt 2]
3917 set title [eval [lindex $opt 4]]
3920 if {$flags eq "+" || $flags eq "*"} {
3921 set cframe $top.fr$cnt
3923 ${NS}::frame $cframe
3924 pack $cframe -in $top -fill x -pady 3 -padx 3
3925 set cexpand [expr {$flags eq "*"}]
3931 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
3932 pack $cframe.c_$id -in $cframe -side left \
3933 -padx [list $lxpad 0] -expand $cexpand -anchor w
3934 } elseif {[regexp {^t(\d+)$} $type type sz]} {
3935 ${NS}::label $cframe.l_$id -text $title
3936 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
3937 -textvariable newviewopts($n,$id)
3938 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
3939 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
3940 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
3941 ${NS}::label $cframe.l_$id -text $title
3942 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
3943 -textvariable newviewopts($n,$id)
3944 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
3945 pack $cframe.e_$id -in $cframe -side top -fill x
3950 ${NS}::label $top.l \
3951 -text [mc "Enter files and directories to include, one per line:"]
3952 pack $top.l -in $top -side top -pady [list 7 0] -anchor w -padx 3
3953 text $top.t -width 40 -height 5 -background $bgcolor -font uifont
3954 if {[info exists viewfiles($n)]} {
3955 foreach f $viewfiles($n) {
3956 $top.t insert end $f
3957 $top.t insert end "\n"
3959 $top.t delete {end - 1c} end
3960 $top.t mark set insert 0.0
3962 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
3963 ${NS}::frame $top.buts
3964 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
3965 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
3966 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
3967 bind $top <Control-Return> [list newviewok $top $n]
3968 bind $top <F5> [list newviewok $top $n 1]
3969 bind $top <Escape> [list destroy $top]
3970 grid $top.buts.ok $top.buts.apply $top.buts.can
3971 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3972 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3973 grid columnconfigure $top.buts 2 -weight 1 -uniform a
3974 pack $top.buts -in $top -side top -fill x
3978 proc doviewmenu {m first cmd op argv} {
3979 set nmenu [$m index end]
3980 for {set i $first} {$i <= $nmenu} {incr i} {
3981 if {[$m entrycget $i -command] eq $cmd} {
3982 eval $m $op $i $argv
3988 proc allviewmenus {n op args} {
3991 doviewmenu .bar.view 5 [list showview $n] $op $args
3992 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
3995 proc newviewok {top n {apply 0}} {
3996 global nextviewnum newviewperm newviewname newishighlight
3997 global viewname viewfiles viewperm selectedview curview
3998 global viewargs viewargscmd newviewopts viewhlmenu
4001 set newargs [encode_view_opts $n]
4003 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4007 foreach f [split [$top.t get 0.0 end] "\n"] {
4008 set ft [string trim $f]
4013 if {![info exists viewfiles($n)]} {
4014 # creating a new view
4016 set viewname($n) $newviewname($n)
4017 set viewperm($n) $newviewopts($n,perm)
4018 set viewfiles($n) $files
4019 set viewargs($n) $newargs
4020 set viewargscmd($n) $newviewopts($n,cmd)
4022 if {!$newishighlight} {
4025 run addvhighlight $n
4028 # editing an existing view
4029 set viewperm($n) $newviewopts($n,perm)
4030 if {$newviewname($n) ne $viewname($n)} {
4031 set viewname($n) $newviewname($n)
4032 doviewmenu .bar.view 5 [list showview $n] \
4033 entryconf [list -label $viewname($n)]
4034 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4035 # entryconf [list -label $viewname($n) -value $viewname($n)]
4037 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4038 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4039 set viewfiles($n) $files
4040 set viewargs($n) $newargs
4041 set viewargscmd($n) $newviewopts($n,cmd)
4042 if {$curview == $n} {
4048 catch {destroy $top}
4052 global curview viewperm hlview selectedhlview
4054 if {$curview == 0} return
4055 if {[info exists hlview] && $hlview == $curview} {
4056 set selectedhlview [mc "None"]
4059 allviewmenus $curview delete
4060 set viewperm($curview) 0
4064 proc addviewmenu {n} {
4065 global viewname viewhlmenu
4067 .bar.view add radiobutton -label $viewname($n) \
4068 -command [list showview $n] -variable selectedview -value $n
4069 #$viewhlmenu add radiobutton -label $viewname($n) \
4070 # -command [list addvhighlight $n] -variable selectedhlview
4074 global curview cached_commitrow ordertok
4075 global displayorder parentlist rowidlist rowisopt rowfinal
4076 global colormap rowtextx nextcolor canvxmax
4077 global numcommits viewcomplete
4078 global selectedline currentid canv canvy0
4080 global pending_select mainheadid
4083 global hlview selectedhlview commitinterest
4085 if {$n == $curview} return
4087 set ymax [lindex [$canv cget -scrollregion] 3]
4088 set span [$canv yview]
4089 set ytop [expr {[lindex $span 0] * $ymax}]
4090 set ybot [expr {[lindex $span 1] * $ymax}]
4091 set yscreen [expr {($ybot - $ytop) / 2}]
4092 if {$selectedline ne {}} {
4093 set selid $currentid
4094 set y [yc $selectedline]
4095 if {$ytop < $y && $y < $ybot} {
4096 set yscreen [expr {$y - $ytop}]
4098 } elseif {[info exists pending_select]} {
4099 set selid $pending_select
4100 unset pending_select
4104 catch {unset treediffs}
4106 if {[info exists hlview] && $hlview == $n} {
4108 set selectedhlview [mc "None"]
4110 catch {unset commitinterest}
4111 catch {unset cached_commitrow}
4112 catch {unset ordertok}
4116 .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4117 .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4120 if {![info exists viewcomplete($n)]} {
4130 set numcommits $commitidx($n)
4132 catch {unset colormap}
4133 catch {unset rowtextx}
4135 set canvxmax [$canv cget -width]
4141 if {$selid ne {} && [commitinview $selid $n]} {
4142 set row [rowofcommit $selid]
4143 # try to get the selected row in the same position on the screen
4144 set ymax [lindex [$canv cget -scrollregion] 3]
4145 set ytop [expr {[yc $row] - $yscreen}]
4149 set yf [expr {$ytop * 1.0 / $ymax}]
4151 allcanvs yview moveto $yf
4155 } elseif {!$viewcomplete($n)} {
4156 reset_pending_select $selid
4158 reset_pending_select {}
4160 if {[commitinview $pending_select $curview]} {
4161 selectline [rowofcommit $pending_select] 1
4163 set row [first_real_row]
4164 if {$row < $numcommits} {
4169 if {!$viewcomplete($n)} {
4170 if {$numcommits == 0} {
4171 show_status [mc "Reading commits..."]
4173 } elseif {$numcommits == 0} {
4174 show_status [mc "No commits selected"]
4178 # Stuff relating to the highlighting facility
4180 proc ishighlighted {id} {
4181 global vhighlights fhighlights nhighlights rhighlights
4183 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4184 return $nhighlights($id)
4186 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4187 return $vhighlights($id)
4189 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4190 return $fhighlights($id)
4192 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4193 return $rhighlights($id)
4198 proc bolden {id font} {
4199 global canv linehtag currentid boldids need_redisplay markedid
4201 # need_redisplay = 1 means the display is stale and about to be redrawn
4202 if {$need_redisplay} return
4204 $canv itemconf $linehtag($id) -font $font
4205 if {[info exists currentid] && $id eq $currentid} {
4207 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4208 -outline {{}} -tags secsel \
4209 -fill [$canv cget -selectbackground]]
4212 if {[info exists markedid] && $id eq $markedid} {
4217 proc bolden_name {id font} {
4218 global canv2 linentag currentid boldnameids need_redisplay
4220 if {$need_redisplay} return
4221 lappend boldnameids $id
4222 $canv2 itemconf $linentag($id) -font $font
4223 if {[info exists currentid] && $id eq $currentid} {
4224 $canv2 delete secsel
4225 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4226 -outline {{}} -tags secsel \
4227 -fill [$canv2 cget -selectbackground]]
4236 foreach id $boldids {
4237 if {![ishighlighted $id]} {
4240 lappend stillbold $id
4243 set boldids $stillbold
4246 proc addvhighlight {n} {
4247 global hlview viewcomplete curview vhl_done commitidx
4249 if {[info exists hlview]} {
4253 if {$n != $curview && ![info exists viewcomplete($n)]} {
4256 set vhl_done $commitidx($hlview)
4257 if {$vhl_done > 0} {
4262 proc delvhighlight {} {
4263 global hlview vhighlights
4265 if {![info exists hlview]} return
4267 catch {unset vhighlights}
4271 proc vhighlightmore {} {
4272 global hlview vhl_done commitidx vhighlights curview
4274 set max $commitidx($hlview)
4275 set vr [visiblerows]
4276 set r0 [lindex $vr 0]
4277 set r1 [lindex $vr 1]
4278 for {set i $vhl_done} {$i < $max} {incr i} {
4279 set id [commitonrow $i $hlview]
4280 if {[commitinview $id $curview]} {
4281 set row [rowofcommit $id]
4282 if {$r0 <= $row && $row <= $r1} {
4283 if {![highlighted $row]} {
4284 bolden $id mainfontbold
4286 set vhighlights($id) 1
4294 proc askvhighlight {row id} {
4295 global hlview vhighlights iddrawn
4297 if {[commitinview $id $hlview]} {
4298 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4299 bolden $id mainfontbold
4301 set vhighlights($id) 1
4303 set vhighlights($id) 0
4307 proc hfiles_change {} {
4308 global highlight_files filehighlight fhighlights fh_serial
4309 global highlight_paths
4311 if {[info exists filehighlight]} {
4312 # delete previous highlights
4313 catch {close $filehighlight}
4315 catch {unset fhighlights}
4317 unhighlight_filelist
4319 set highlight_paths {}
4320 after cancel do_file_hl $fh_serial
4322 if {$highlight_files ne {}} {
4323 after 300 do_file_hl $fh_serial
4327 proc gdttype_change {name ix op} {
4328 global gdttype highlight_files findstring findpattern
4331 if {$findstring ne {}} {
4332 if {$gdttype eq [mc "containing:"]} {
4333 if {$highlight_files ne {}} {
4334 set highlight_files {}
4339 if {$findpattern ne {}} {
4343 set highlight_files $findstring
4348 # enable/disable findtype/findloc menus too
4351 proc find_change {name ix op} {
4352 global gdttype findstring highlight_files
4355 if {$gdttype eq [mc "containing:"]} {
4358 if {$highlight_files ne $findstring} {
4359 set highlight_files $findstring
4366 proc findcom_change args {
4367 global nhighlights boldnameids
4368 global findpattern findtype findstring gdttype
4371 # delete previous highlights, if any
4372 foreach id $boldnameids {
4373 bolden_name $id mainfont
4376 catch {unset nhighlights}
4379 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4381 } elseif {$findtype eq [mc "Regexp"]} {
4382 set findpattern $findstring
4384 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4386 set findpattern "*$e*"
4390 proc makepatterns {l} {
4393 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4394 if {[string index $ee end] eq "/"} {
4404 proc do_file_hl {serial} {
4405 global highlight_files filehighlight highlight_paths gdttype fhl_list
4407 if {$gdttype eq [mc "touching paths:"]} {
4408 if {[catch {set paths [shellsplit $highlight_files]}]} return
4409 set highlight_paths [makepatterns $paths]
4411 set gdtargs [concat -- $paths]
4412 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4413 set gdtargs [list "-S$highlight_files"]
4415 # must be "containing:", i.e. we're searching commit info
4418 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4419 set filehighlight [open $cmd r+]
4420 fconfigure $filehighlight -blocking 0
4421 filerun $filehighlight readfhighlight
4427 proc flushhighlights {} {
4428 global filehighlight fhl_list
4430 if {[info exists filehighlight]} {
4432 puts $filehighlight ""
4433 flush $filehighlight
4437 proc askfilehighlight {row id} {
4438 global filehighlight fhighlights fhl_list
4440 lappend fhl_list $id
4441 set fhighlights($id) -1
4442 puts $filehighlight $id
4445 proc readfhighlight {} {
4446 global filehighlight fhighlights curview iddrawn
4447 global fhl_list find_dirn
4449 if {![info exists filehighlight]} {
4453 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4454 set line [string trim $line]
4455 set i [lsearch -exact $fhl_list $line]
4456 if {$i < 0} continue
4457 for {set j 0} {$j < $i} {incr j} {
4458 set id [lindex $fhl_list $j]
4459 set fhighlights($id) 0
4461 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4462 if {$line eq {}} continue
4463 if {![commitinview $line $curview]} continue
4464 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4465 bolden $line mainfontbold
4467 set fhighlights($line) 1
4469 if {[eof $filehighlight]} {
4471 puts "oops, git diff-tree died"
4472 catch {close $filehighlight}
4476 if {[info exists find_dirn]} {
4482 proc doesmatch {f} {
4483 global findtype findpattern
4485 if {$findtype eq [mc "Regexp"]} {
4486 return [regexp $findpattern $f]
4487 } elseif {$findtype eq [mc "IgnCase"]} {
4488 return [string match -nocase $findpattern $f]
4490 return [string match $findpattern $f]
4494 proc askfindhighlight {row id} {
4495 global nhighlights commitinfo iddrawn
4497 global markingmatches
4499 if {![info exists commitinfo($id)]} {
4502 set info $commitinfo($id)
4504 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
4505 foreach f $info ty $fldtypes {
4506 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4508 if {$ty eq [mc "Author"]} {
4515 if {$isbold && [info exists iddrawn($id)]} {
4516 if {![ishighlighted $id]} {
4517 bolden $id mainfontbold
4519 bolden_name $id mainfontbold
4522 if {$markingmatches} {
4523 markrowmatches $row $id
4526 set nhighlights($id) $isbold
4529 proc markrowmatches {row id} {
4530 global canv canv2 linehtag linentag commitinfo findloc
4532 set headline [lindex $commitinfo($id) 0]
4533 set author [lindex $commitinfo($id) 1]
4534 $canv delete match$row
4535 $canv2 delete match$row
4536 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4537 set m [findmatches $headline]
4539 markmatches $canv $row $headline $linehtag($id) $m \
4540 [$canv itemcget $linehtag($id) -font] $row
4543 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4544 set m [findmatches $author]
4546 markmatches $canv2 $row $author $linentag($id) $m \
4547 [$canv2 itemcget $linentag($id) -font] $row
4552 proc vrel_change {name ix op} {
4553 global highlight_related
4556 if {$highlight_related ne [mc "None"]} {
4561 # prepare for testing whether commits are descendents or ancestors of a
4562 proc rhighlight_sel {a} {
4563 global descendent desc_todo ancestor anc_todo
4564 global highlight_related
4566 catch {unset descendent}
4567 set desc_todo [list $a]
4568 catch {unset ancestor}
4569 set anc_todo [list $a]
4570 if {$highlight_related ne [mc "None"]} {
4576 proc rhighlight_none {} {
4579 catch {unset rhighlights}
4583 proc is_descendent {a} {
4584 global curview children descendent desc_todo
4587 set la [rowofcommit $a]
4591 for {set i 0} {$i < [llength $todo]} {incr i} {
4592 set do [lindex $todo $i]
4593 if {[rowofcommit $do] < $la} {
4594 lappend leftover $do
4597 foreach nk $children($v,$do) {
4598 if {![info exists descendent($nk)]} {
4599 set descendent($nk) 1
4607 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4611 set descendent($a) 0
4612 set desc_todo $leftover
4615 proc is_ancestor {a} {
4616 global curview parents ancestor anc_todo
4619 set la [rowofcommit $a]
4623 for {set i 0} {$i < [llength $todo]} {incr i} {
4624 set do [lindex $todo $i]
4625 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4626 lappend leftover $do
4629 foreach np $parents($v,$do) {
4630 if {![info exists ancestor($np)]} {
4639 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4644 set anc_todo $leftover
4647 proc askrelhighlight {row id} {
4648 global descendent highlight_related iddrawn rhighlights
4649 global selectedline ancestor
4651 if {$selectedline eq {}} return
4653 if {$highlight_related eq [mc "Descendant"] ||
4654 $highlight_related eq [mc "Not descendant"]} {
4655 if {![info exists descendent($id)]} {
4658 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4661 } elseif {$highlight_related eq [mc "Ancestor"] ||
4662 $highlight_related eq [mc "Not ancestor"]} {
4663 if {![info exists ancestor($id)]} {
4666 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4670 if {[info exists iddrawn($id)]} {
4671 if {$isbold && ![ishighlighted $id]} {
4672 bolden $id mainfontbold
4675 set rhighlights($id) $isbold
4678 # Graph layout functions
4680 proc shortids {ids} {
4683 if {[llength $id] > 1} {
4684 lappend res [shortids $id]
4685 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4686 lappend res [string range $id 0 7]
4697 for {set mask 1} {$mask <= $n} {incr mask $mask} {
4698 if {($n & $mask) != 0} {
4699 set ret [concat $ret $o]
4701 set o [concat $o $o]
4706 proc ordertoken {id} {
4707 global ordertok curview varcid varcstart varctok curview parents children
4708 global nullid nullid2
4710 if {[info exists ordertok($id)]} {
4711 return $ordertok($id)
4716 if {[info exists varcid($curview,$id)]} {
4717 set a $varcid($curview,$id)
4718 set p [lindex $varcstart($curview) $a]
4720 set p [lindex $children($curview,$id) 0]
4722 if {[info exists ordertok($p)]} {
4723 set tok $ordertok($p)
4726 set id [first_real_child $curview,$p]
4729 set tok [lindex $varctok($curview) $varcid($curview,$p)]
4732 if {[llength $parents($curview,$id)] == 1} {
4733 lappend todo [list $p {}]
4735 set j [lsearch -exact $parents($curview,$id) $p]
4737 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
4739 lappend todo [list $p [strrep $j]]
4742 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
4743 set p [lindex $todo $i 0]
4744 append tok [lindex $todo $i 1]
4745 set ordertok($p) $tok
4747 set ordertok($origid) $tok
4751 # Work out where id should go in idlist so that order-token
4752 # values increase from left to right
4753 proc idcol {idlist id {i 0}} {
4754 set t [ordertoken $id]
4758 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
4759 if {$i > [llength $idlist]} {
4760 set i [llength $idlist]
4762 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
4765 if {$t > [ordertoken [lindex $idlist $i]]} {
4766 while {[incr i] < [llength $idlist] &&
4767 $t >= [ordertoken [lindex $idlist $i]]} {}
4773 proc initlayout {} {
4774 global rowidlist rowisopt rowfinal displayorder parentlist
4775 global numcommits canvxmax canv
4777 global colormap rowtextx
4786 set canvxmax [$canv cget -width]
4787 catch {unset colormap}
4788 catch {unset rowtextx}
4792 proc setcanvscroll {} {
4793 global canv canv2 canv3 numcommits linespc canvxmax canvy0
4794 global lastscrollset lastscrollrows
4796 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
4797 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
4798 $canv2 conf -scrollregion [list 0 0 0 $ymax]
4799 $canv3 conf -scrollregion [list 0 0 0 $ymax]
4800 set lastscrollset [clock clicks -milliseconds]
4801 set lastscrollrows $numcommits
4804 proc visiblerows {} {
4805 global canv numcommits linespc
4807 set ymax [lindex [$canv cget -scrollregion] 3]
4808 if {$ymax eq {} || $ymax == 0} return
4810 set y0 [expr {int([lindex $f 0] * $ymax)}]
4811 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
4815 set y1 [expr {int([lindex $f 1] * $ymax)}]
4816 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
4817 if {$r1 >= $numcommits} {
4818 set r1 [expr {$numcommits - 1}]
4820 return [list $r0 $r1]
4823 proc layoutmore {} {
4824 global commitidx viewcomplete curview
4825 global numcommits pending_select curview
4826 global lastscrollset lastscrollrows
4828 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
4829 [clock clicks -milliseconds] - $lastscrollset > 500} {
4832 if {[info exists pending_select] &&
4833 [commitinview $pending_select $curview]} {
4835 selectline [rowofcommit $pending_select] 1
4840 # With path limiting, we mightn't get the actual HEAD commit,
4841 # so ask git rev-list what is the first ancestor of HEAD that
4842 # touches a file in the path limit.
4843 proc get_viewmainhead {view} {
4844 global viewmainheadid vfilelimit viewinstances mainheadid
4847 set rfd [open [concat | git rev-list -1 $mainheadid \
4848 -- $vfilelimit($view)] r]
4849 set j [reg_instance $rfd]
4850 lappend viewinstances($view) $j
4851 fconfigure $rfd -blocking 0
4852 filerun $rfd [list getviewhead $rfd $j $view]
4853 set viewmainheadid($curview) {}
4857 # git rev-list should give us just 1 line to use as viewmainheadid($view)
4858 proc getviewhead {fd inst view} {
4859 global viewmainheadid commfd curview viewinstances showlocalchanges
4862 if {[gets $fd line] < 0} {
4866 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
4869 set viewmainheadid($view) $id
4872 set i [lsearch -exact $viewinstances($view) $inst]
4874 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
4876 if {$showlocalchanges && $id ne {} && $view == $curview} {
4882 proc doshowlocalchanges {} {
4883 global curview viewmainheadid
4885 if {$viewmainheadid($curview) eq {}} return
4886 if {[commitinview $viewmainheadid($curview) $curview]} {
4889 interestedin $viewmainheadid($curview) dodiffindex
4893 proc dohidelocalchanges {} {
4894 global nullid nullid2 lserial curview
4896 if {[commitinview $nullid $curview]} {
4897 removefakerow $nullid
4899 if {[commitinview $nullid2 $curview]} {
4900 removefakerow $nullid2
4905 # spawn off a process to do git diff-index --cached HEAD
4906 proc dodiffindex {} {
4907 global lserial showlocalchanges vfilelimit curview
4910 if {!$showlocalchanges || !$isworktree} return
4912 set cmd "|git diff-index --cached HEAD"
4913 if {$vfilelimit($curview) ne {}} {
4914 set cmd [concat $cmd -- $vfilelimit($curview)]
4916 set fd [open $cmd r]
4917 fconfigure $fd -blocking 0
4918 set i [reg_instance $fd]
4919 filerun $fd [list readdiffindex $fd $lserial $i]
4922 proc readdiffindex {fd serial inst} {
4923 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
4927 if {[gets $fd line] < 0} {
4933 # we only need to see one line and we don't really care what it says...
4936 if {$serial != $lserial} {
4940 # now see if there are any local changes not checked in to the index
4941 set cmd "|git diff-files"
4942 if {$vfilelimit($curview) ne {}} {
4943 set cmd [concat $cmd -- $vfilelimit($curview)]
4945 set fd [open $cmd r]
4946 fconfigure $fd -blocking 0
4947 set i [reg_instance $fd]
4948 filerun $fd [list readdifffiles $fd $serial $i]
4950 if {$isdiff && ![commitinview $nullid2 $curview]} {
4951 # add the line for the changes in the index to the graph
4952 set hl [mc "Local changes checked in to index but not committed"]
4953 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
4954 set commitdata($nullid2) "\n $hl\n"
4955 if {[commitinview $nullid $curview]} {
4956 removefakerow $nullid
4958 insertfakerow $nullid2 $viewmainheadid($curview)
4959 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
4960 if {[commitinview $nullid $curview]} {
4961 removefakerow $nullid
4963 removefakerow $nullid2
4968 proc readdifffiles {fd serial inst} {
4969 global viewmainheadid nullid nullid2 curview
4970 global commitinfo commitdata lserial
4973 if {[gets $fd line] < 0} {
4979 # we only need to see one line and we don't really care what it says...
4982 if {$serial != $lserial} {
4986 if {$isdiff && ![commitinview $nullid $curview]} {
4987 # add the line for the local diff to the graph
4988 set hl [mc "Local uncommitted changes, not checked in to index"]
4989 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
4990 set commitdata($nullid) "\n $hl\n"
4991 if {[commitinview $nullid2 $curview]} {
4994 set p $viewmainheadid($curview)
4996 insertfakerow $nullid $p
4997 } elseif {!$isdiff && [commitinview $nullid $curview]} {
4998 removefakerow $nullid
5003 proc nextuse {id row} {
5004 global curview children
5006 if {[info exists children($curview,$id)]} {
5007 foreach kid $children($curview,$id) {
5008 if {![commitinview $kid $curview]} {
5011 if {[rowofcommit $kid] > $row} {
5012 return [rowofcommit $kid]
5016 if {[commitinview $id $curview]} {
5017 return [rowofcommit $id]
5022 proc prevuse {id row} {
5023 global curview children
5026 if {[info exists children($curview,$id)]} {
5027 foreach kid $children($curview,$id) {
5028 if {![commitinview $kid $curview]} break
5029 if {[rowofcommit $kid] < $row} {
5030 set ret [rowofcommit $kid]
5037 proc make_idlist {row} {
5038 global displayorder parentlist uparrowlen downarrowlen mingaplen
5039 global commitidx curview children
5041 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5045 set ra [expr {$row - $downarrowlen}]
5049 set rb [expr {$row + $uparrowlen}]
5050 if {$rb > $commitidx($curview)} {
5051 set rb $commitidx($curview)
5053 make_disporder $r [expr {$rb + 1}]
5055 for {} {$r < $ra} {incr r} {
5056 set nextid [lindex $displayorder [expr {$r + 1}]]
5057 foreach p [lindex $parentlist $r] {
5058 if {$p eq $nextid} continue
5059 set rn [nextuse $p $r]
5061 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5062 lappend ids [list [ordertoken $p] $p]
5066 for {} {$r < $row} {incr r} {
5067 set nextid [lindex $displayorder [expr {$r + 1}]]
5068 foreach p [lindex $parentlist $r] {
5069 if {$p eq $nextid} continue
5070 set rn [nextuse $p $r]
5071 if {$rn < 0 || $rn >= $row} {
5072 lappend ids [list [ordertoken $p] $p]
5076 set id [lindex $displayorder $row]
5077 lappend ids [list [ordertoken $id] $id]
5079 foreach p [lindex $parentlist $r] {
5080 set firstkid [lindex $children($curview,$p) 0]
5081 if {[rowofcommit $firstkid] < $row} {
5082 lappend ids [list [ordertoken $p] $p]
5086 set id [lindex $displayorder $r]
5088 set firstkid [lindex $children($curview,$id) 0]
5089 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5090 lappend ids [list [ordertoken $id] $id]
5095 foreach idx [lsort -unique $ids] {
5096 lappend idlist [lindex $idx 1]
5101 proc rowsequal {a b} {
5102 while {[set i [lsearch -exact $a {}]] >= 0} {
5103 set a [lreplace $a $i $i]
5105 while {[set i [lsearch -exact $b {}]] >= 0} {
5106 set b [lreplace $b $i $i]
5108 return [expr {$a eq $b}]
5111 proc makeupline {id row rend col} {
5112 global rowidlist uparrowlen downarrowlen mingaplen
5114 for {set r $rend} {1} {set r $rstart} {
5115 set rstart [prevuse $id $r]
5116 if {$rstart < 0} return
5117 if {$rstart < $row} break
5119 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5120 set rstart [expr {$rend - $uparrowlen - 1}]
5122 for {set r $rstart} {[incr r] <= $row} {} {
5123 set idlist [lindex $rowidlist $r]
5124 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5125 set col [idcol $idlist $id $col]
5126 lset rowidlist $r [linsert $idlist $col $id]
5132 proc layoutrows {row endrow} {
5133 global rowidlist rowisopt rowfinal displayorder
5134 global uparrowlen downarrowlen maxwidth mingaplen
5135 global children parentlist
5136 global commitidx viewcomplete curview
5138 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5141 set rm1 [expr {$row - 1}]
5142 foreach id [lindex $rowidlist $rm1] {
5147 set final [lindex $rowfinal $rm1]
5149 for {} {$row < $endrow} {incr row} {
5150 set rm1 [expr {$row - 1}]
5151 if {$rm1 < 0 || $idlist eq {}} {
5152 set idlist [make_idlist $row]
5155 set id [lindex $displayorder $rm1]
5156 set col [lsearch -exact $idlist $id]
5157 set idlist [lreplace $idlist $col $col]
5158 foreach p [lindex $parentlist $rm1] {
5159 if {[lsearch -exact $idlist $p] < 0} {
5160 set col [idcol $idlist $p $col]
5161 set idlist [linsert $idlist $col $p]
5162 # if not the first child, we have to insert a line going up
5163 if {$id ne [lindex $children($curview,$p) 0]} {
5164 makeupline $p $rm1 $row $col
5168 set id [lindex $displayorder $row]
5169 if {$row > $downarrowlen} {
5170 set termrow [expr {$row - $downarrowlen - 1}]
5171 foreach p [lindex $parentlist $termrow] {
5172 set i [lsearch -exact $idlist $p]
5173 if {$i < 0} continue
5174 set nr [nextuse $p $termrow]
5175 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5176 set idlist [lreplace $idlist $i $i]
5180 set col [lsearch -exact $idlist $id]
5182 set col [idcol $idlist $id]
5183 set idlist [linsert $idlist $col $id]
5184 if {$children($curview,$id) ne {}} {
5185 makeupline $id $rm1 $row $col
5188 set r [expr {$row + $uparrowlen - 1}]
5189 if {$r < $commitidx($curview)} {
5191 foreach p [lindex $parentlist $r] {
5192 if {[lsearch -exact $idlist $p] >= 0} continue
5193 set fk [lindex $children($curview,$p) 0]
5194 if {[rowofcommit $fk] < $row} {
5195 set x [idcol $idlist $p $x]
5196 set idlist [linsert $idlist $x $p]
5199 if {[incr r] < $commitidx($curview)} {
5200 set p [lindex $displayorder $r]
5201 if {[lsearch -exact $idlist $p] < 0} {
5202 set fk [lindex $children($curview,$p) 0]
5203 if {$fk ne {} && [rowofcommit $fk] < $row} {
5204 set x [idcol $idlist $p $x]
5205 set idlist [linsert $idlist $x $p]
5211 if {$final && !$viewcomplete($curview) &&
5212 $row + $uparrowlen + $mingaplen + $downarrowlen
5213 >= $commitidx($curview)} {
5216 set l [llength $rowidlist]
5218 lappend rowidlist $idlist
5220 lappend rowfinal $final
5221 } elseif {$row < $l} {
5222 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5223 lset rowidlist $row $idlist
5226 lset rowfinal $row $final
5228 set pad [ntimes [expr {$row - $l}] {}]
5229 set rowidlist [concat $rowidlist $pad]
5230 lappend rowidlist $idlist
5231 set rowfinal [concat $rowfinal $pad]
5232 lappend rowfinal $final
5233 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5239 proc changedrow {row} {
5240 global displayorder iddrawn rowisopt need_redisplay
5242 set l [llength $rowisopt]
5244 lset rowisopt $row 0
5245 if {$row + 1 < $l} {
5246 lset rowisopt [expr {$row + 1}] 0
5247 if {$row + 2 < $l} {
5248 lset rowisopt [expr {$row + 2}] 0
5252 set id [lindex $displayorder $row]
5253 if {[info exists iddrawn($id)]} {
5254 set need_redisplay 1
5258 proc insert_pad {row col npad} {
5261 set pad [ntimes $npad {}]
5262 set idlist [lindex $rowidlist $row]
5263 set bef [lrange $idlist 0 [expr {$col - 1}]]
5264 set aft [lrange $idlist $col end]
5265 set i [lsearch -exact $aft {}]
5267 set aft [lreplace $aft $i $i]
5269 lset rowidlist $row [concat $bef $pad $aft]
5273 proc optimize_rows {row col endrow} {
5274 global rowidlist rowisopt displayorder curview children
5279 for {} {$row < $endrow} {incr row; set col 0} {
5280 if {[lindex $rowisopt $row]} continue
5282 set y0 [expr {$row - 1}]
5283 set ym [expr {$row - 2}]
5284 set idlist [lindex $rowidlist $row]
5285 set previdlist [lindex $rowidlist $y0]
5286 if {$idlist eq {} || $previdlist eq {}} continue
5288 set pprevidlist [lindex $rowidlist $ym]
5289 if {$pprevidlist eq {}} continue
5295 for {} {$col < [llength $idlist]} {incr col} {
5296 set id [lindex $idlist $col]
5297 if {[lindex $previdlist $col] eq $id} continue
5302 set x0 [lsearch -exact $previdlist $id]
5303 if {$x0 < 0} continue
5304 set z [expr {$x0 - $col}]
5308 set xm [lsearch -exact $pprevidlist $id]
5310 set z0 [expr {$xm - $x0}]
5314 # if row y0 is the first child of $id then it's not an arrow
5315 if {[lindex $children($curview,$id) 0] ne
5316 [lindex $displayorder $y0]} {
5320 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5321 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5324 # Looking at lines from this row to the previous row,
5325 # make them go straight up if they end in an arrow on
5326 # the previous row; otherwise make them go straight up
5328 if {$z < -1 || ($z < 0 && $isarrow)} {
5329 # Line currently goes left too much;
5330 # insert pads in the previous row, then optimize it
5331 set npad [expr {-1 - $z + $isarrow}]
5332 insert_pad $y0 $x0 $npad
5334 optimize_rows $y0 $x0 $row
5336 set previdlist [lindex $rowidlist $y0]
5337 set x0 [lsearch -exact $previdlist $id]
5338 set z [expr {$x0 - $col}]
5340 set pprevidlist [lindex $rowidlist $ym]
5341 set xm [lsearch -exact $pprevidlist $id]
5342 set z0 [expr {$xm - $x0}]
5344 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5345 # Line currently goes right too much;
5346 # insert pads in this line
5347 set npad [expr {$z - 1 + $isarrow}]
5348 insert_pad $row $col $npad
5349 set idlist [lindex $rowidlist $row]
5351 set z [expr {$x0 - $col}]
5354 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5355 # this line links to its first child on row $row-2
5356 set id [lindex $displayorder $ym]
5357 set xc [lsearch -exact $pprevidlist $id]
5359 set z0 [expr {$xc - $x0}]
5362 # avoid lines jigging left then immediately right
5363 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5364 insert_pad $y0 $x0 1
5366 optimize_rows $y0 $x0 $row
5367 set previdlist [lindex $rowidlist $y0]
5371 # Find the first column that doesn't have a line going right
5372 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5373 set id [lindex $idlist $col]
5374 if {$id eq {}} break
5375 set x0 [lsearch -exact $previdlist $id]
5377 # check if this is the link to the first child
5378 set kid [lindex $displayorder $y0]
5379 if {[lindex $children($curview,$id) 0] eq $kid} {
5380 # it is, work out offset to child
5381 set x0 [lsearch -exact $previdlist $kid]
5384 if {$x0 <= $col} break
5386 # Insert a pad at that column as long as it has a line and
5387 # isn't the last column
5388 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5389 set idlist [linsert $idlist $col {}]
5390 lset rowidlist $row $idlist
5398 global canvx0 linespc
5399 return [expr {$canvx0 + $col * $linespc}]
5403 global canvy0 linespc
5404 return [expr {$canvy0 + $row * $linespc}]
5407 proc linewidth {id} {
5408 global thickerline lthickness
5411 if {[info exists thickerline] && $id eq $thickerline} {
5412 set wid [expr {2 * $lthickness}]
5417 proc rowranges {id} {
5418 global curview children uparrowlen downarrowlen
5421 set kids $children($curview,$id)
5427 foreach child $kids {
5428 if {![commitinview $child $curview]} break
5429 set row [rowofcommit $child]
5430 if {![info exists prev]} {
5431 lappend ret [expr {$row + 1}]
5433 if {$row <= $prevrow} {
5434 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5436 # see if the line extends the whole way from prevrow to row
5437 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5438 [lsearch -exact [lindex $rowidlist \
5439 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5440 # it doesn't, see where it ends
5441 set r [expr {$prevrow + $downarrowlen}]
5442 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5443 while {[incr r -1] > $prevrow &&
5444 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5446 while {[incr r] <= $row &&
5447 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5451 # see where it starts up again
5452 set r [expr {$row - $uparrowlen}]
5453 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5454 while {[incr r] < $row &&
5455 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5457 while {[incr r -1] >= $prevrow &&
5458 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5464 if {$child eq $id} {
5473 proc drawlineseg {id row endrow arrowlow} {
5474 global rowidlist displayorder iddrawn linesegs
5475 global canv colormap linespc curview maxlinelen parentlist
5477 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5478 set le [expr {$row + 1}]
5481 set c [lsearch -exact [lindex $rowidlist $le] $id]
5487 set x [lindex $displayorder $le]
5492 if {[info exists iddrawn($x)] || $le == $endrow} {
5493 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5509 if {[info exists linesegs($id)]} {
5510 set lines $linesegs($id)
5512 set r0 [lindex $li 0]
5514 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5524 set li [lindex $lines [expr {$i-1}]]
5525 set r1 [lindex $li 1]
5526 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5531 set x [lindex $cols [expr {$le - $row}]]
5532 set xp [lindex $cols [expr {$le - 1 - $row}]]
5533 set dir [expr {$xp - $x}]
5535 set ith [lindex $lines $i 2]
5536 set coords [$canv coords $ith]
5537 set ah [$canv itemcget $ith -arrow]
5538 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5539 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5540 if {$x2 ne {} && $x - $x2 == $dir} {
5541 set coords [lrange $coords 0 end-2]
5544 set coords [list [xc $le $x] [yc $le]]
5547 set itl [lindex $lines [expr {$i-1}] 2]
5548 set al [$canv itemcget $itl -arrow]
5549 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5550 } elseif {$arrowlow} {
5551 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5552 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5556 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5557 for {set y $le} {[incr y -1] > $row} {} {
5559 set xp [lindex $cols [expr {$y - 1 - $row}]]
5560 set ndir [expr {$xp - $x}]
5561 if {$dir != $ndir || $xp < 0} {
5562 lappend coords [xc $y $x] [yc $y]
5568 # join parent line to first child
5569 set ch [lindex $displayorder $row]
5570 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5572 puts "oops: drawlineseg: child $ch not on row $row"
5573 } elseif {$xc != $x} {
5574 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5575 set d [expr {int(0.5 * $linespc)}]
5578 set x2 [expr {$x1 - $d}]
5580 set x2 [expr {$x1 + $d}]
5583 set y1 [expr {$y2 + $d}]
5584 lappend coords $x1 $y1 $x2 $y2
5585 } elseif {$xc < $x - 1} {
5586 lappend coords [xc $row [expr {$x-1}]] [yc $row]
5587 } elseif {$xc > $x + 1} {
5588 lappend coords [xc $row [expr {$x+1}]] [yc $row]
5592 lappend coords [xc $row $x] [yc $row]
5594 set xn [xc $row $xp]
5596 lappend coords $xn $yn
5600 set t [$canv create line $coords -width [linewidth $id] \
5601 -fill $colormap($id) -tags lines.$id -arrow $arrow]
5604 set lines [linsert $lines $i [list $row $le $t]]
5606 $canv coords $ith $coords
5607 if {$arrow ne $ah} {
5608 $canv itemconf $ith -arrow $arrow
5610 lset lines $i 0 $row
5613 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5614 set ndir [expr {$xo - $xp}]
5615 set clow [$canv coords $itl]
5616 if {$dir == $ndir} {
5617 set clow [lrange $clow 2 end]
5619 set coords [concat $coords $clow]
5621 lset lines [expr {$i-1}] 1 $le
5623 # coalesce two pieces
5625 set b [lindex $lines [expr {$i-1}] 0]
5626 set e [lindex $lines $i 1]
5627 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5629 $canv coords $itl $coords
5630 if {$arrow ne $al} {
5631 $canv itemconf $itl -arrow $arrow
5635 set linesegs($id) $lines
5639 proc drawparentlinks {id row} {
5640 global rowidlist canv colormap curview parentlist
5641 global idpos linespc
5643 set rowids [lindex $rowidlist $row]
5644 set col [lsearch -exact $rowids $id]
5645 if {$col < 0} return
5646 set olds [lindex $parentlist $row]
5647 set row2 [expr {$row + 1}]
5648 set x [xc $row $col]
5651 set d [expr {int(0.5 * $linespc)}]
5652 set ymid [expr {$y + $d}]
5653 set ids [lindex $rowidlist $row2]
5654 # rmx = right-most X coord used
5657 set i [lsearch -exact $ids $p]
5659 puts "oops, parent $p of $id not in list"
5662 set x2 [xc $row2 $i]
5666 set j [lsearch -exact $rowids $p]
5668 # drawlineseg will do this one for us
5672 # should handle duplicated parents here...
5673 set coords [list $x $y]
5675 # if attaching to a vertical segment, draw a smaller
5676 # slant for visual distinctness
5679 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5681 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5683 } elseif {$i < $col && $i < $j} {
5684 # segment slants towards us already
5685 lappend coords [xc $row $j] $y
5687 if {$i < $col - 1} {
5688 lappend coords [expr {$x2 + $linespc}] $y
5689 } elseif {$i > $col + 1} {
5690 lappend coords [expr {$x2 - $linespc}] $y
5692 lappend coords $x2 $y2
5695 lappend coords $x2 $y2
5697 set t [$canv create line $coords -width [linewidth $p] \
5698 -fill $colormap($p) -tags lines.$p]
5702 if {$rmx > [lindex $idpos($id) 1]} {
5703 lset idpos($id) 1 $rmx
5708 proc drawlines {id} {
5711 $canv itemconf lines.$id -width [linewidth $id]
5714 proc drawcmittext {id row col} {
5715 global linespc canv canv2 canv3 fgcolor curview
5716 global cmitlisted commitinfo rowidlist parentlist
5717 global rowtextx idpos idtags idheads idotherrefs
5718 global linehtag linentag linedtag selectedline
5719 global canvxmax boldids boldnameids fgcolor markedid
5720 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5722 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5723 set listed $cmitlisted($curview,$id)
5724 if {$id eq $nullid} {
5726 } elseif {$id eq $nullid2} {
5728 } elseif {$id eq $mainheadid} {
5731 set ofill [lindex $circlecolors $listed]
5733 set x [xc $row $col]
5735 set orad [expr {$linespc / 3}]
5737 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
5738 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5739 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5740 } elseif {$listed == 3} {
5741 # triangle pointing left for left-side commits
5742 set t [$canv create polygon \
5743 [expr {$x - $orad}] $y \
5744 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
5745 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
5746 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5748 # triangle pointing right for right-side commits
5749 set t [$canv create polygon \
5750 [expr {$x + $orad - 1}] $y \
5751 [expr {$x - $orad}] [expr {$y - $orad}] \
5752 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
5753 -fill $ofill -outline $fgcolor -width 1 -tags circle]
5755 set circleitem($row) $t
5757 $canv bind $t <1> {selcanvline {} %x %y}
5758 set rmx [llength [lindex $rowidlist $row]]
5759 set olds [lindex $parentlist $row]
5761 set nextids [lindex $rowidlist [expr {$row + 1}]]
5763 set i [lsearch -exact $nextids $p]
5769 set xt [xc $row $rmx]
5770 set rowtextx($row) $xt
5771 set idpos($id) [list $x $xt $y]
5772 if {[info exists idtags($id)] || [info exists idheads($id)]
5773 || [info exists idotherrefs($id)]} {
5774 set xt [drawtags $id $x $xt $y]
5776 set headline [lindex $commitinfo($id) 0]
5777 set name [lindex $commitinfo($id) 1]
5778 set date [lindex $commitinfo($id) 2]
5779 set date [formatdate $date]
5782 set isbold [ishighlighted $id]
5785 set font mainfontbold
5787 lappend boldnameids $id
5788 set nfont mainfontbold
5791 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
5792 -text $headline -font $font -tags text]
5793 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
5794 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
5795 -text $name -font $nfont -tags text]
5796 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
5797 -text $date -font mainfont -tags text]
5798 if {$selectedline == $row} {
5801 if {[info exists markedid] && $markedid eq $id} {
5804 set xr [expr {$xt + [font measure $font $headline]}]
5805 if {$xr > $canvxmax} {
5811 proc drawcmitrow {row} {
5812 global displayorder rowidlist nrows_drawn
5813 global iddrawn markingmatches
5814 global commitinfo numcommits
5815 global filehighlight fhighlights findpattern nhighlights
5816 global hlview vhighlights
5817 global highlight_related rhighlights
5819 if {$row >= $numcommits} return
5821 set id [lindex $displayorder $row]
5822 if {[info exists hlview] && ![info exists vhighlights($id)]} {
5823 askvhighlight $row $id
5825 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
5826 askfilehighlight $row $id
5828 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
5829 askfindhighlight $row $id
5831 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
5832 askrelhighlight $row $id
5834 if {![info exists iddrawn($id)]} {
5835 set col [lsearch -exact [lindex $rowidlist $row] $id]
5837 puts "oops, row $row id $id not in list"
5840 if {![info exists commitinfo($id)]} {
5844 drawcmittext $id $row $col
5848 if {$markingmatches} {
5849 markrowmatches $row $id
5853 proc drawcommits {row {endrow {}}} {
5854 global numcommits iddrawn displayorder curview need_redisplay
5855 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
5860 if {$endrow eq {}} {
5863 if {$endrow >= $numcommits} {
5864 set endrow [expr {$numcommits - 1}]
5867 set rl1 [expr {$row - $downarrowlen - 3}]
5871 set ro1 [expr {$row - 3}]
5875 set r2 [expr {$endrow + $uparrowlen + 3}]
5876 if {$r2 > $numcommits} {
5879 for {set r $rl1} {$r < $r2} {incr r} {
5880 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
5884 set rl1 [expr {$r + 1}]
5890 optimize_rows $ro1 0 $r2
5891 if {$need_redisplay || $nrows_drawn > 2000} {
5895 # make the lines join to already-drawn rows either side
5896 set r [expr {$row - 1}]
5897 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
5900 set er [expr {$endrow + 1}]
5901 if {$er >= $numcommits ||
5902 ![info exists iddrawn([lindex $displayorder $er])]} {
5905 for {} {$r <= $er} {incr r} {
5906 set id [lindex $displayorder $r]
5907 set wasdrawn [info exists iddrawn($id)]
5909 if {$r == $er} break
5910 set nextid [lindex $displayorder [expr {$r + 1}]]
5911 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
5912 drawparentlinks $id $r
5914 set rowids [lindex $rowidlist $r]
5915 foreach lid $rowids {
5916 if {$lid eq {}} continue
5917 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
5919 # see if this is the first child of any of its parents
5920 foreach p [lindex $parentlist $r] {
5921 if {[lsearch -exact $rowids $p] < 0} {
5922 # make this line extend up to the child
5923 set lineend($p) [drawlineseg $p $r $er 0]
5927 set lineend($lid) [drawlineseg $lid $r $er 1]
5933 proc undolayout {row} {
5934 global uparrowlen mingaplen downarrowlen
5935 global rowidlist rowisopt rowfinal need_redisplay
5937 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
5941 if {[llength $rowidlist] > $r} {
5943 set rowidlist [lrange $rowidlist 0 $r]
5944 set rowfinal [lrange $rowfinal 0 $r]
5945 set rowisopt [lrange $rowisopt 0 $r]
5946 set need_redisplay 1
5951 proc drawvisible {} {
5952 global canv linespc curview vrowmod selectedline targetrow targetid
5953 global need_redisplay cscroll numcommits
5955 set fs [$canv yview]
5956 set ymax [lindex [$canv cget -scrollregion] 3]
5957 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
5958 set f0 [lindex $fs 0]
5959 set f1 [lindex $fs 1]
5960 set y0 [expr {int($f0 * $ymax)}]
5961 set y1 [expr {int($f1 * $ymax)}]
5963 if {[info exists targetid]} {
5964 if {[commitinview $targetid $curview]} {
5965 set r [rowofcommit $targetid]
5966 if {$r != $targetrow} {
5967 # Fix up the scrollregion and change the scrolling position
5968 # now that our target row has moved.
5969 set diff [expr {($r - $targetrow) * $linespc}]
5972 set ymax [lindex [$canv cget -scrollregion] 3]
5975 set f0 [expr {$y0 / $ymax}]
5976 set f1 [expr {$y1 / $ymax}]
5977 allcanvs yview moveto $f0
5978 $cscroll set $f0 $f1
5979 set need_redisplay 1
5986 set row [expr {int(($y0 - 3) / $linespc) - 1}]
5987 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
5988 if {$endrow >= $vrowmod($curview)} {
5989 update_arcrows $curview
5991 if {$selectedline ne {} &&
5992 $row <= $selectedline && $selectedline <= $endrow} {
5993 set targetrow $selectedline
5994 } elseif {[info exists targetid]} {
5995 set targetrow [expr {int(($row + $endrow) / 2)}]
5997 if {[info exists targetrow]} {
5998 if {$targetrow >= $numcommits} {
5999 set targetrow [expr {$numcommits - 1}]
6001 set targetid [commitonrow $targetrow]
6003 drawcommits $row $endrow
6006 proc clear_display {} {
6007 global iddrawn linesegs need_redisplay nrows_drawn
6008 global vhighlights fhighlights nhighlights rhighlights
6009 global linehtag linentag linedtag boldids boldnameids
6012 catch {unset iddrawn}
6013 catch {unset linesegs}
6014 catch {unset linehtag}
6015 catch {unset linentag}
6016 catch {unset linedtag}
6019 catch {unset vhighlights}
6020 catch {unset fhighlights}
6021 catch {unset nhighlights}
6022 catch {unset rhighlights}
6023 set need_redisplay 0
6027 proc findcrossings {id} {
6028 global rowidlist parentlist numcommits displayorder
6032 foreach {s e} [rowranges $id] {
6033 if {$e >= $numcommits} {
6034 set e [expr {$numcommits - 1}]
6036 if {$e <= $s} continue
6037 for {set row $e} {[incr row -1] >= $s} {} {
6038 set x [lsearch -exact [lindex $rowidlist $row] $id]
6040 set olds [lindex $parentlist $row]
6041 set kid [lindex $displayorder $row]
6042 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6043 if {$kidx < 0} continue
6044 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6046 set px [lsearch -exact $nextrow $p]
6047 if {$px < 0} continue
6048 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6049 if {[lsearch -exact $ccross $p] >= 0} continue
6050 if {$x == $px + ($kidx < $px? -1: 1)} {
6052 } elseif {[lsearch -exact $cross $p] < 0} {
6059 return [concat $ccross {{}} $cross]
6062 proc assigncolor {id} {
6063 global colormap colors nextcolor
6064 global parents children children curview
6066 if {[info exists colormap($id)]} return
6067 set ncolors [llength $colors]
6068 if {[info exists children($curview,$id)]} {
6069 set kids $children($curview,$id)
6073 if {[llength $kids] == 1} {
6074 set child [lindex $kids 0]
6075 if {[info exists colormap($child)]
6076 && [llength $parents($curview,$child)] == 1} {
6077 set colormap($id) $colormap($child)
6083 foreach x [findcrossings $id] {
6085 # delimiter between corner crossings and other crossings
6086 if {[llength $badcolors] >= $ncolors - 1} break
6087 set origbad $badcolors
6089 if {[info exists colormap($x)]
6090 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6091 lappend badcolors $colormap($x)
6094 if {[llength $badcolors] >= $ncolors} {
6095 set badcolors $origbad
6097 set origbad $badcolors
6098 if {[llength $badcolors] < $ncolors - 1} {
6099 foreach child $kids {
6100 if {[info exists colormap($child)]
6101 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6102 lappend badcolors $colormap($child)
6104 foreach p $parents($curview,$child) {
6105 if {[info exists colormap($p)]
6106 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6107 lappend badcolors $colormap($p)
6111 if {[llength $badcolors] >= $ncolors} {
6112 set badcolors $origbad
6115 for {set i 0} {$i <= $ncolors} {incr i} {
6116 set c [lindex $colors $nextcolor]
6117 if {[incr nextcolor] >= $ncolors} {
6120 if {[lsearch -exact $badcolors $c]} break
6122 set colormap($id) $c
6125 proc bindline {t id} {
6128 $canv bind $t <Enter> "lineenter %x %y $id"
6129 $canv bind $t <Motion> "linemotion %x %y $id"
6130 $canv bind $t <Leave> "lineleave $id"
6131 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6134 proc drawtags {id x xt y1} {
6135 global idtags idheads idotherrefs mainhead
6136 global linespc lthickness
6137 global canv rowtextx curview fgcolor bgcolor ctxbut
6142 if {[info exists idtags($id)]} {
6143 set marks $idtags($id)
6144 set ntags [llength $marks]
6146 if {[info exists idheads($id)]} {
6147 set marks [concat $marks $idheads($id)]
6148 set nheads [llength $idheads($id)]
6150 if {[info exists idotherrefs($id)]} {
6151 set marks [concat $marks $idotherrefs($id)]
6157 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6158 set yt [expr {$y1 - 0.5 * $linespc}]
6159 set yb [expr {$yt + $linespc - 1}]
6163 foreach tag $marks {
6165 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6166 set wid [font measure mainfontbold $tag]
6168 set wid [font measure mainfont $tag]
6172 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
6174 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6175 -width $lthickness -fill black -tags tag.$id]
6177 foreach tag $marks x $xvals wid $wvals {
6178 set xl [expr {$x + $delta}]
6179 set xr [expr {$x + $delta + $wid + $lthickness}]
6181 if {[incr ntags -1] >= 0} {
6183 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6184 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6185 -width 1 -outline black -fill yellow -tags tag.$id]
6186 $canv bind $t <1> [list showtag $tag 1]
6187 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6189 # draw a head or other ref
6190 if {[incr nheads -1] >= 0} {
6192 if {$tag eq $mainhead} {
6193 set font mainfontbold
6198 set xl [expr {$xl - $delta/2}]
6199 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6200 -width 1 -outline black -fill $col -tags tag.$id
6201 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6202 set rwid [font measure mainfont $remoteprefix]
6203 set xi [expr {$x + 1}]
6204 set yti [expr {$yt + 1}]
6205 set xri [expr {$x + $rwid}]
6206 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6207 -width 0 -fill "#ffddaa" -tags tag.$id
6210 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
6211 -font $font -tags [list tag.$id text]]
6213 $canv bind $t <1> [list showtag $tag 1]
6214 } elseif {$nheads >= 0} {
6215 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag]
6221 proc xcoord {i level ln} {
6222 global canvx0 xspc1 xspc2
6224 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6225 if {$i > 0 && $i == $level} {
6226 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6227 } elseif {$i > $level} {
6228 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6233 proc show_status {msg} {
6237 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6238 -tags text -fill $fgcolor
6241 # Don't change the text pane cursor if it is currently the hand cursor,
6242 # showing that we are over a sha1 ID link.
6243 proc settextcursor {c} {
6244 global ctext curtextcursor
6246 if {[$ctext cget -cursor] == $curtextcursor} {
6247 $ctext config -cursor $c
6249 set curtextcursor $c
6252 proc nowbusy {what {name {}}} {
6253 global isbusy busyname statusw
6255 if {[array names isbusy] eq {}} {
6256 . config -cursor watch
6260 set busyname($what) $name
6262 $statusw conf -text $name
6266 proc notbusy {what} {
6267 global isbusy maincursor textcursor busyname statusw
6271 if {$busyname($what) ne {} &&
6272 [$statusw cget -text] eq $busyname($what)} {
6273 $statusw conf -text {}
6276 if {[array names isbusy] eq {}} {
6277 . config -cursor $maincursor
6278 settextcursor $textcursor
6282 proc findmatches {f} {
6283 global findtype findstring
6284 if {$findtype == [mc "Regexp"]} {
6285 set matches [regexp -indices -all -inline $findstring $f]
6288 if {$findtype == [mc "IgnCase"]} {
6289 set f [string tolower $f]
6290 set fs [string tolower $fs]
6294 set l [string length $fs]
6295 while {[set j [string first $fs $f $i]] >= 0} {
6296 lappend matches [list $j [expr {$j+$l-1}]]
6297 set i [expr {$j + $l}]
6303 proc dofind {{dirn 1} {wrap 1}} {
6304 global findstring findstartline findcurline selectedline numcommits
6305 global gdttype filehighlight fh_serial find_dirn findallowwrap
6307 if {[info exists find_dirn]} {
6308 if {$find_dirn == $dirn} return
6312 if {$findstring eq {} || $numcommits == 0} return
6313 if {$selectedline eq {}} {
6314 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6316 set findstartline $selectedline
6318 set findcurline $findstartline
6319 nowbusy finding [mc "Searching"]
6320 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6321 after cancel do_file_hl $fh_serial
6322 do_file_hl $fh_serial
6325 set findallowwrap $wrap
6329 proc stopfinding {} {
6330 global find_dirn findcurline fprogcoord
6332 if {[info exists find_dirn]} {
6343 global commitdata commitinfo numcommits findpattern findloc
6344 global findstartline findcurline findallowwrap
6345 global find_dirn gdttype fhighlights fprogcoord
6346 global curview varcorder vrownum varccommits vrowmod
6348 if {![info exists find_dirn]} {
6351 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
6354 if {$find_dirn > 0} {
6356 if {$l >= $numcommits} {
6359 if {$l <= $findstartline} {
6360 set lim [expr {$findstartline + 1}]
6363 set moretodo $findallowwrap
6370 if {$l >= $findstartline} {
6371 set lim [expr {$findstartline - 1}]
6374 set moretodo $findallowwrap
6377 set n [expr {($lim - $l) * $find_dirn}]
6382 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6383 update_arcrows $curview
6387 set ai [bsearch $vrownum($curview) $l]
6388 set a [lindex $varcorder($curview) $ai]
6389 set arow [lindex $vrownum($curview) $ai]
6390 set ids [lindex $varccommits($curview,$a)]
6391 set arowend [expr {$arow + [llength $ids]}]
6392 if {$gdttype eq [mc "containing:"]} {
6393 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6394 if {$l < $arow || $l >= $arowend} {
6396 set a [lindex $varcorder($curview) $ai]
6397 set arow [lindex $vrownum($curview) $ai]
6398 set ids [lindex $varccommits($curview,$a)]
6399 set arowend [expr {$arow + [llength $ids]}]
6401 set id [lindex $ids [expr {$l - $arow}]]
6402 # shouldn't happen unless git log doesn't give all the commits...
6403 if {![info exists commitdata($id)] ||
6404 ![doesmatch $commitdata($id)]} {
6407 if {![info exists commitinfo($id)]} {
6410 set info $commitinfo($id)
6411 foreach f $info ty $fldtypes {
6412 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6421 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6422 if {$l < $arow || $l >= $arowend} {
6424 set a [lindex $varcorder($curview) $ai]
6425 set arow [lindex $vrownum($curview) $ai]
6426 set ids [lindex $varccommits($curview,$a)]
6427 set arowend [expr {$arow + [llength $ids]}]
6429 set id [lindex $ids [expr {$l - $arow}]]
6430 if {![info exists fhighlights($id)]} {
6431 # this sets fhighlights($id) to -1
6432 askfilehighlight $l $id
6434 if {$fhighlights($id) > 0} {
6438 if {$fhighlights($id) < 0} {
6441 set findcurline [expr {$l - $find_dirn}]
6446 if {$found || ($domore && !$moretodo)} {
6462 set findcurline [expr {$l - $find_dirn}]
6464 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6468 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6473 proc findselectline {l} {
6474 global findloc commentend ctext findcurline markingmatches gdttype
6476 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6479 if {$markingmatches &&
6480 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6481 # highlight the matches in the comments
6482 set f [$ctext get 1.0 $commentend]
6483 set matches [findmatches $f]
6484 foreach match $matches {
6485 set start [lindex $match 0]
6486 set end [expr {[lindex $match 1] + 1}]
6487 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6493 # mark the bits of a headline or author that match a find string
6494 proc markmatches {canv l str tag matches font row} {
6497 set bbox [$canv bbox $tag]
6498 set x0 [lindex $bbox 0]
6499 set y0 [lindex $bbox 1]
6500 set y1 [lindex $bbox 3]
6501 foreach match $matches {
6502 set start [lindex $match 0]
6503 set end [lindex $match 1]
6504 if {$start > $end} continue
6505 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6506 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6507 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6508 [expr {$x0+$xlen+2}] $y1 \
6509 -outline {} -tags [list match$l matches] -fill yellow]
6511 if {$row == $selectedline} {
6512 $canv raise $t secsel
6517 proc unmarkmatches {} {
6518 global markingmatches
6520 allcanvs delete matches
6521 set markingmatches 0
6525 proc selcanvline {w x y} {
6526 global canv canvy0 ctext linespc
6528 set ymax [lindex [$canv cget -scrollregion] 3]
6529 if {$ymax == {}} return
6530 set yfrac [lindex [$canv yview] 0]
6531 set y [expr {$y + $yfrac * $ymax}]
6532 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6537 set xmax [lindex [$canv cget -scrollregion] 2]
6538 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6539 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6545 proc commit_descriptor {p} {
6547 if {![info exists commitinfo($p)]} {
6551 if {[llength $commitinfo($p)] > 1} {
6552 set l [lindex $commitinfo($p) 0]
6557 # append some text to the ctext widget, and make any SHA1 ID
6558 # that we know about be a clickable link.
6559 proc appendwithlinks {text tags} {
6560 global ctext linknum curview
6562 set start [$ctext index "end - 1c"]
6563 $ctext insert end $text $tags
6564 set links [regexp -indices -all -inline {\m[0-9a-f]{6,40}\M} $text]
6568 set linkid [string range $text $s $e]
6570 $ctext tag delete link$linknum
6571 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6572 setlink $linkid link$linknum
6577 proc setlink {id lk} {
6578 global curview ctext pendinglinks
6581 if {[string length $id] < 40} {
6582 set matches [longid $id]
6583 if {[llength $matches] > 0} {
6584 if {[llength $matches] > 1} return
6586 set id [lindex $matches 0]
6589 set known [commitinview $id $curview]
6592 $ctext tag conf $lk -foreground blue -underline 1
6593 $ctext tag bind $lk <1> [list selbyid $id]
6594 $ctext tag bind $lk <Enter> {linkcursor %W 1}
6595 $ctext tag bind $lk <Leave> {linkcursor %W -1}
6597 lappend pendinglinks($id) $lk
6598 interestedin $id {makelink %P}
6602 proc appendshortlink {id {pre {}} {post {}}} {
6603 global ctext linknum
6605 $ctext insert end $pre
6606 $ctext tag delete link$linknum
6607 $ctext insert end [string range $id 0 7] link$linknum
6608 $ctext insert end $post
6609 setlink $id link$linknum
6613 proc makelink {id} {
6616 if {![info exists pendinglinks($id)]} return
6617 foreach lk $pendinglinks($id) {
6620 unset pendinglinks($id)
6623 proc linkcursor {w inc} {
6624 global linkentercount curtextcursor
6626 if {[incr linkentercount $inc] > 0} {
6627 $w configure -cursor hand2
6629 $w configure -cursor $curtextcursor
6630 if {$linkentercount < 0} {
6631 set linkentercount 0
6636 proc viewnextline {dir} {
6640 set ymax [lindex [$canv cget -scrollregion] 3]
6641 set wnow [$canv yview]
6642 set wtop [expr {[lindex $wnow 0] * $ymax}]
6643 set newtop [expr {$wtop + $dir * $linespc}]
6646 } elseif {$newtop > $ymax} {
6649 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6652 # add a list of tag or branch names at position pos
6653 # returns the number of names inserted
6654 proc appendrefs {pos ids var} {
6655 global ctext linknum curview $var maxrefs
6657 if {[catch {$ctext index $pos}]} {
6660 $ctext conf -state normal
6661 $ctext delete $pos "$pos lineend"
6664 foreach tag [set $var\($id\)] {
6665 lappend tags [list $tag $id]
6668 if {[llength $tags] > $maxrefs} {
6669 $ctext insert $pos "[mc "many"] ([llength $tags])"
6671 set tags [lsort -index 0 -decreasing $tags]
6674 set id [lindex $ti 1]
6677 $ctext tag delete $lk
6678 $ctext insert $pos $sep
6679 $ctext insert $pos [lindex $ti 0] $lk
6684 $ctext conf -state disabled
6685 return [llength $tags]
6688 # called when we have finished computing the nearby tags
6689 proc dispneartags {delay} {
6690 global selectedline currentid showneartags tagphase
6692 if {$selectedline eq {} || !$showneartags} return
6693 after cancel dispnexttag
6695 after 200 dispnexttag
6698 after idle dispnexttag
6703 proc dispnexttag {} {
6704 global selectedline currentid showneartags tagphase ctext
6706 if {$selectedline eq {} || !$showneartags} return
6707 switch -- $tagphase {
6709 set dtags [desctags $currentid]
6711 appendrefs precedes $dtags idtags
6715 set atags [anctags $currentid]
6717 appendrefs follows $atags idtags
6721 set dheads [descheads $currentid]
6722 if {$dheads ne {}} {
6723 if {[appendrefs branch $dheads idheads] > 1
6724 && [$ctext get "branch -3c"] eq "h"} {
6725 # turn "Branch" into "Branches"
6726 $ctext conf -state normal
6727 $ctext insert "branch -2c" "es"
6728 $ctext conf -state disabled
6733 if {[incr tagphase] <= 2} {
6734 after idle dispnexttag
6738 proc make_secsel {id} {
6739 global linehtag linentag linedtag canv canv2 canv3
6741 if {![info exists linehtag($id)]} return
6743 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
6744 -tags secsel -fill [$canv cget -selectbackground]]
6746 $canv2 delete secsel
6747 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
6748 -tags secsel -fill [$canv2 cget -selectbackground]]
6750 $canv3 delete secsel
6751 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
6752 -tags secsel -fill [$canv3 cget -selectbackground]]
6756 proc make_idmark {id} {
6757 global linehtag canv fgcolor
6759 if {![info exists linehtag($id)]} return
6761 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
6762 -tags markid -outline $fgcolor]
6766 proc selectline {l isnew {desired_loc {}}} {
6767 global canv ctext commitinfo selectedline
6768 global canvy0 linespc parents children curview
6769 global currentid sha1entry
6770 global commentend idtags linknum
6771 global mergemax numcommits pending_select
6772 global cmitmode showneartags allcommits
6773 global targetrow targetid lastscrollrows
6774 global autoselect jump_to_here
6776 catch {unset pending_select}
6781 if {$l < 0 || $l >= $numcommits} return
6782 set id [commitonrow $l]
6787 if {$lastscrollrows < $numcommits} {
6791 set y [expr {$canvy0 + $l * $linespc}]
6792 set ymax [lindex [$canv cget -scrollregion] 3]
6793 set ytop [expr {$y - $linespc - 1}]
6794 set ybot [expr {$y + $linespc + 1}]
6795 set wnow [$canv yview]
6796 set wtop [expr {[lindex $wnow 0] * $ymax}]
6797 set wbot [expr {[lindex $wnow 1] * $ymax}]
6798 set wh [expr {$wbot - $wtop}]
6800 if {$ytop < $wtop} {
6801 if {$ybot < $wtop} {
6802 set newtop [expr {$y - $wh / 2.0}]
6805 if {$newtop > $wtop - $linespc} {
6806 set newtop [expr {$wtop - $linespc}]
6809 } elseif {$ybot > $wbot} {
6810 if {$ytop > $wbot} {
6811 set newtop [expr {$y - $wh / 2.0}]
6813 set newtop [expr {$ybot - $wh}]
6814 if {$newtop < $wtop + $linespc} {
6815 set newtop [expr {$wtop + $linespc}]
6819 if {$newtop != $wtop} {
6823 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6830 addtohistory [list selbyid $id 0] savecmitpos
6833 $sha1entry delete 0 end
6834 $sha1entry insert 0 $id
6836 $sha1entry selection range 0 end
6840 $ctext conf -state normal
6843 if {![info exists commitinfo($id)]} {
6846 set info $commitinfo($id)
6847 set date [formatdate [lindex $info 2]]
6848 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
6849 set date [formatdate [lindex $info 4]]
6850 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
6851 if {[info exists idtags($id)]} {
6852 $ctext insert end [mc "Tags:"]
6853 foreach tag $idtags($id) {
6854 $ctext insert end " $tag"
6856 $ctext insert end "\n"
6860 set olds $parents($curview,$id)
6861 if {[llength $olds] > 1} {
6864 if {$np >= $mergemax} {
6869 $ctext insert end "[mc "Parent"]: " $tag
6870 appendwithlinks [commit_descriptor $p] {}
6875 append headers "[mc "Parent"]: [commit_descriptor $p]"
6879 foreach c $children($curview,$id) {
6880 append headers "[mc "Child"]: [commit_descriptor $c]"
6883 # make anything that looks like a SHA1 ID be a clickable link
6884 appendwithlinks $headers {}
6885 if {$showneartags} {
6886 if {![info exists allcommits]} {
6889 $ctext insert end "[mc "Branch"]: "
6890 $ctext mark set branch "end -1c"
6891 $ctext mark gravity branch left
6892 $ctext insert end "\n[mc "Follows"]: "
6893 $ctext mark set follows "end -1c"
6894 $ctext mark gravity follows left
6895 $ctext insert end "\n[mc "Precedes"]: "
6896 $ctext mark set precedes "end -1c"
6897 $ctext mark gravity precedes left
6898 $ctext insert end "\n"
6901 $ctext insert end "\n"
6902 set comment [lindex $info 5]
6903 if {[string first "\r" $comment] >= 0} {
6904 set comment [string map {"\r" "\n "} $comment]
6906 appendwithlinks $comment {comment}
6908 $ctext tag remove found 1.0 end
6909 $ctext conf -state disabled
6910 set commentend [$ctext index "end - 1c"]
6912 set jump_to_here $desired_loc
6913 init_flist [mc "Comments"]
6914 if {$cmitmode eq "tree"} {
6916 } elseif {[llength $olds] <= 1} {
6923 proc selfirstline {} {
6928 proc sellastline {} {
6931 set l [expr {$numcommits - 1}]
6935 proc selnextline {dir} {
6938 if {$selectedline eq {}} return
6939 set l [expr {$selectedline + $dir}]
6944 proc selnextpage {dir} {
6945 global canv linespc selectedline numcommits
6947 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
6951 allcanvs yview scroll [expr {$dir * $lpp}] units
6953 if {$selectedline eq {}} return
6954 set l [expr {$selectedline + $dir * $lpp}]
6957 } elseif {$l >= $numcommits} {
6958 set l [expr $numcommits - 1]
6964 proc unselectline {} {
6965 global selectedline currentid
6968 catch {unset currentid}
6969 allcanvs delete secsel
6973 proc reselectline {} {
6976 if {$selectedline ne {}} {
6977 selectline $selectedline 0
6981 proc addtohistory {cmd {saveproc {}}} {
6982 global history historyindex curview
6986 set elt [list $curview $cmd $saveproc {}]
6987 if {$historyindex > 0
6988 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
6992 if {$historyindex < [llength $history]} {
6993 set history [lreplace $history $historyindex end $elt]
6995 lappend history $elt
6998 if {$historyindex > 1} {
6999 .tf.bar.leftbut conf -state normal
7001 .tf.bar.leftbut conf -state disabled
7003 .tf.bar.rightbut conf -state disabled
7006 # save the scrolling position of the diff display pane
7007 proc save_position {} {
7008 global historyindex history
7010 if {$historyindex < 1} return
7011 set hi [expr {$historyindex - 1}]
7012 set fn [lindex $history $hi 2]
7014 lset history $hi 3 [eval $fn]
7018 proc unset_posvars {} {
7021 if {[info exists last_posvars]} {
7022 foreach {var val} $last_posvars {
7031 global curview last_posvars
7033 set view [lindex $elt 0]
7034 set cmd [lindex $elt 1]
7035 set pv [lindex $elt 3]
7036 if {$curview != $view} {
7040 foreach {var val} $pv {
7044 set last_posvars $pv
7049 global history historyindex
7052 if {$historyindex > 1} {
7054 incr historyindex -1
7055 godo [lindex $history [expr {$historyindex - 1}]]
7056 .tf.bar.rightbut conf -state normal
7058 if {$historyindex <= 1} {
7059 .tf.bar.leftbut conf -state disabled
7064 global history historyindex
7067 if {$historyindex < [llength $history]} {
7069 set cmd [lindex $history $historyindex]
7072 .tf.bar.leftbut conf -state normal
7074 if {$historyindex >= [llength $history]} {
7075 .tf.bar.rightbut conf -state disabled
7080 global treefilelist treeidlist diffids diffmergeid treepending
7081 global nullid nullid2
7084 catch {unset diffmergeid}
7085 if {![info exists treefilelist($id)]} {
7086 if {![info exists treepending]} {
7087 if {$id eq $nullid} {
7088 set cmd [list | git ls-files]
7089 } elseif {$id eq $nullid2} {
7090 set cmd [list | git ls-files --stage -t]
7092 set cmd [list | git ls-tree -r $id]
7094 if {[catch {set gtf [open $cmd r]}]} {
7098 set treefilelist($id) {}
7099 set treeidlist($id) {}
7100 fconfigure $gtf -blocking 0 -encoding binary
7101 filerun $gtf [list gettreeline $gtf $id]
7108 proc gettreeline {gtf id} {
7109 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7112 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7113 if {$diffids eq $nullid} {
7116 set i [string first "\t" $line]
7117 if {$i < 0} continue
7118 set fname [string range $line [expr {$i+1}] end]
7119 set line [string range $line 0 [expr {$i-1}]]
7120 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7121 set sha1 [lindex $line 2]
7122 lappend treeidlist($id) $sha1
7124 if {[string index $fname 0] eq "\""} {
7125 set fname [lindex $fname 0]
7127 set fname [encoding convertfrom $fname]
7128 lappend treefilelist($id) $fname
7131 return [expr {$nl >= 1000? 2: 1}]
7135 if {$cmitmode ne "tree"} {
7136 if {![info exists diffmergeid]} {
7137 gettreediffs $diffids
7139 } elseif {$id ne $diffids} {
7148 global treefilelist treeidlist diffids nullid nullid2
7149 global ctext_file_names ctext_file_lines
7150 global ctext commentend
7152 set i [lsearch -exact $treefilelist($diffids) $f]
7154 puts "oops, $f not in list for id $diffids"
7157 if {$diffids eq $nullid} {
7158 if {[catch {set bf [open $f r]} err]} {
7159 puts "oops, can't read $f: $err"
7163 set blob [lindex $treeidlist($diffids) $i]
7164 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7165 puts "oops, error reading blob $blob: $err"
7169 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7170 filerun $bf [list getblobline $bf $diffids]
7171 $ctext config -state normal
7172 clear_ctext $commentend
7173 lappend ctext_file_names $f
7174 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7175 $ctext insert end "\n"
7176 $ctext insert end "$f\n" filesep
7177 $ctext config -state disabled
7178 $ctext yview $commentend
7182 proc getblobline {bf id} {
7183 global diffids cmitmode ctext
7185 if {$id ne $diffids || $cmitmode ne "tree"} {
7189 $ctext config -state normal
7191 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7192 $ctext insert end "$line\n"
7195 global jump_to_here ctext_file_names commentend
7197 # delete last newline
7198 $ctext delete "end - 2c" "end - 1c"
7200 if {$jump_to_here ne {} &&
7201 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7202 set lnum [expr {[lindex $jump_to_here 1] +
7203 [lindex [split $commentend .] 0]}]
7204 mark_ctext_line $lnum
7208 $ctext config -state disabled
7209 return [expr {$nl >= 1000? 2: 1}]
7212 proc mark_ctext_line {lnum} {
7213 global ctext markbgcolor
7215 $ctext tag delete omark
7216 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7217 $ctext tag conf omark -background $markbgcolor
7221 proc mergediff {id} {
7223 global diffids treediffs
7224 global parents curview
7228 set treediffs($id) {}
7229 set np [llength $parents($curview,$id)]
7234 proc startdiff {ids} {
7235 global treediffs diffids treepending diffmergeid nullid nullid2
7239 catch {unset diffmergeid}
7240 if {![info exists treediffs($ids)] ||
7241 [lsearch -exact $ids $nullid] >= 0 ||
7242 [lsearch -exact $ids $nullid2] >= 0} {
7243 if {![info exists treepending]} {
7251 proc path_filter {filter name} {
7253 set l [string length $p]
7254 if {[string index $p end] eq "/"} {
7255 if {[string compare -length $l $p $name] == 0} {
7259 if {[string compare -length $l $p $name] == 0 &&
7260 ([string length $name] == $l ||
7261 [string index $name $l] eq "/")} {
7269 proc addtocflist {ids} {
7272 add_flist $treediffs($ids)
7276 proc diffcmd {ids flags} {
7277 global nullid nullid2
7279 set i [lsearch -exact $ids $nullid]
7280 set j [lsearch -exact $ids $nullid2]
7282 if {[llength $ids] > 1 && $j < 0} {
7283 # comparing working directory with some specific revision
7284 set cmd [concat | git diff-index $flags]
7286 lappend cmd -R [lindex $ids 1]
7288 lappend cmd [lindex $ids 0]
7291 # comparing working directory with index
7292 set cmd [concat | git diff-files $flags]
7297 } elseif {$j >= 0} {
7298 set cmd [concat | git diff-index --cached $flags]
7299 if {[llength $ids] > 1} {
7300 # comparing index with specific revision
7302 lappend cmd -R [lindex $ids 1]
7304 lappend cmd [lindex $ids 0]
7307 # comparing index with HEAD
7311 set cmd [concat | git diff-tree -r $flags $ids]
7316 proc gettreediffs {ids} {
7317 global treediff treepending
7319 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
7321 set treepending $ids
7323 fconfigure $gdtf -blocking 0 -encoding binary
7324 filerun $gdtf [list gettreediffline $gdtf $ids]
7327 proc gettreediffline {gdtf ids} {
7328 global treediff treediffs treepending diffids diffmergeid
7329 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7334 if {$perfile_attrs} {
7335 # cache_gitattr is slow, and even slower on win32 where we
7336 # have to invoke it for only about 30 paths at a time
7338 if {[tk windowingsystem] == "win32"} {
7342 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7343 set i [string first "\t" $line]
7345 set file [string range $line [expr {$i+1}] end]
7346 if {[string index $file 0] eq "\""} {
7347 set file [lindex $file 0]
7349 set file [encoding convertfrom $file]
7350 if {$file ne [lindex $treediff end]} {
7351 lappend treediff $file
7352 lappend sublist $file
7356 if {$perfile_attrs} {
7357 cache_gitattr encoding $sublist
7360 return [expr {$nr >= $max? 2: 1}]
7363 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7365 foreach f $treediff {
7366 if {[path_filter $vfilelimit($curview) $f]} {
7370 set treediffs($ids) $flist
7372 set treediffs($ids) $treediff
7375 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7377 } elseif {$ids != $diffids} {
7378 if {![info exists diffmergeid]} {
7379 gettreediffs $diffids
7387 # empty string or positive integer
7388 proc diffcontextvalidate {v} {
7389 return [regexp {^(|[1-9][0-9]*)$} $v]
7392 proc diffcontextchange {n1 n2 op} {
7393 global diffcontextstring diffcontext
7395 if {[string is integer -strict $diffcontextstring]} {
7396 if {$diffcontextstring > 0} {
7397 set diffcontext $diffcontextstring
7403 proc changeignorespace {} {
7407 proc getblobdiffs {ids} {
7408 global blobdifffd diffids env
7409 global diffinhdr treediffs
7412 global limitdiffs vfilelimit curview
7413 global diffencoding targetline diffnparents
7415 set cmd [diffcmd $ids "-p -C --cc --no-commit-id -U$diffcontext"]
7419 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7420 set cmd [concat $cmd -- $vfilelimit($curview)]
7422 if {[catch {set bdf [open $cmd r]} err]} {
7423 error_popup [mc "Error getting diffs: %s" $err]
7429 set diffencoding [get_path_encoding {}]
7430 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7431 set blobdifffd($ids) $bdf
7432 filerun $bdf [list getblobdiffline $bdf $diffids]
7435 proc savecmitpos {} {
7436 global ctext cmitmode
7438 if {$cmitmode eq "tree"} {
7441 return [list target_scrollpos [$ctext index @0,0]]
7444 proc savectextpos {} {
7447 return [list target_scrollpos [$ctext index @0,0]]
7450 proc maybe_scroll_ctext {ateof} {
7451 global ctext target_scrollpos
7453 if {![info exists target_scrollpos]} return
7455 set nlines [expr {[winfo height $ctext]
7456 / [font metrics textfont -linespace]}]
7457 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7459 $ctext yview $target_scrollpos
7460 unset target_scrollpos
7463 proc setinlist {var i val} {
7466 while {[llength [set $var]] < $i} {
7469 if {[llength [set $var]] == $i} {
7476 proc makediffhdr {fname ids} {
7477 global ctext curdiffstart treediffs diffencoding
7478 global ctext_file_names jump_to_here targetline diffline
7480 set fname [encoding convertfrom $fname]
7481 set diffencoding [get_path_encoding $fname]
7482 set i [lsearch -exact $treediffs($ids) $fname]
7484 setinlist difffilestart $i $curdiffstart
7486 lset ctext_file_names end $fname
7487 set l [expr {(78 - [string length $fname]) / 2}]
7488 set pad [string range "----------------------------------------" 1 $l]
7489 $ctext insert $curdiffstart "$pad $fname $pad" filesep
7491 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7492 set targetline [lindex $jump_to_here 1]
7497 proc getblobdiffline {bdf ids} {
7498 global diffids blobdifffd ctext curdiffstart
7499 global diffnexthead diffnextnote difffilestart
7500 global ctext_file_names ctext_file_lines
7501 global diffinhdr treediffs mergemax diffnparents
7502 global diffencoding jump_to_here targetline diffline
7505 $ctext conf -state normal
7506 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7507 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7511 if {![string compare -length 5 "diff " $line]} {
7512 if {![regexp {^diff (--cc|--git) } $line m type]} {
7513 set line [encoding convertfrom $line]
7514 $ctext insert end "$line\n" hunksep
7517 # start of a new file
7519 $ctext insert end "\n"
7520 set curdiffstart [$ctext index "end - 1c"]
7521 lappend ctext_file_names ""
7522 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7523 $ctext insert end "\n" filesep
7525 if {$type eq "--cc"} {
7526 # start of a new file in a merge diff
7527 set fname [string range $line 10 end]
7528 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7529 lappend treediffs($ids) $fname
7530 add_flist [list $fname]
7534 set line [string range $line 11 end]
7535 # If the name hasn't changed the length will be odd,
7536 # the middle char will be a space, and the two bits either
7537 # side will be a/name and b/name, or "a/name" and "b/name".
7538 # If the name has changed we'll get "rename from" and
7539 # "rename to" or "copy from" and "copy to" lines following
7540 # this, and we'll use them to get the filenames.
7541 # This complexity is necessary because spaces in the
7542 # filename(s) don't get escaped.
7543 set l [string length $line]
7544 set i [expr {$l / 2}]
7545 if {!(($l & 1) && [string index $line $i] eq " " &&
7546 [string range $line 2 [expr {$i - 1}]] eq \
7547 [string range $line [expr {$i + 3}] end])} {
7550 # unescape if quoted and chop off the a/ from the front
7551 if {[string index $line 0] eq "\""} {
7552 set fname [string range [lindex $line 0] 2 end]
7554 set fname [string range $line 2 [expr {$i - 1}]]
7557 makediffhdr $fname $ids
7559 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
7560 set fname [encoding convertfrom [string range $line 16 end]]
7561 $ctext insert end "\n"
7562 set curdiffstart [$ctext index "end - 1c"]
7563 lappend ctext_file_names $fname
7564 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7565 $ctext insert end "$line\n" filesep
7566 set i [lsearch -exact $treediffs($ids) $fname]
7568 setinlist difffilestart $i $curdiffstart
7571 } elseif {![string compare -length 2 "@@" $line]} {
7572 regexp {^@@+} $line ats
7573 set line [encoding convertfrom $diffencoding $line]
7574 $ctext insert end "$line\n" hunksep
7575 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
7578 set diffnparents [expr {[string length $ats] - 1}]
7581 } elseif {$diffinhdr} {
7582 if {![string compare -length 12 "rename from " $line]} {
7583 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
7584 if {[string index $fname 0] eq "\""} {
7585 set fname [lindex $fname 0]
7587 set fname [encoding convertfrom $fname]
7588 set i [lsearch -exact $treediffs($ids) $fname]
7590 setinlist difffilestart $i $curdiffstart
7592 } elseif {![string compare -length 10 $line "rename to "] ||
7593 ![string compare -length 8 $line "copy to "]} {
7594 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
7595 if {[string index $fname 0] eq "\""} {
7596 set fname [lindex $fname 0]
7598 makediffhdr $fname $ids
7599 } elseif {[string compare -length 3 $line "---"] == 0} {
7602 } elseif {[string compare -length 3 $line "+++"] == 0} {
7606 $ctext insert end "$line\n" filesep
7609 set line [string map {\x1A ^Z} \
7610 [encoding convertfrom $diffencoding $line]]
7611 # parse the prefix - one ' ', '-' or '+' for each parent
7612 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
7613 set tag [expr {$diffnparents > 1? "m": "d"}]
7614 if {[string trim $prefix " -+"] eq {}} {
7615 # prefix only has " ", "-" and "+" in it: normal diff line
7616 set num [string first "-" $prefix]
7618 # removed line, first parent with line is $num
7619 if {$num >= $mergemax} {
7622 $ctext insert end "$line\n" $tag$num
7625 if {[string first "+" $prefix] >= 0} {
7627 lappend tags ${tag}result
7628 if {$diffnparents > 1} {
7629 set num [string first " " $prefix]
7631 if {$num >= $mergemax} {
7638 if {$targetline ne {}} {
7639 if {$diffline == $targetline} {
7640 set seehere [$ctext index "end - 1 chars"]
7646 $ctext insert end "$line\n" $tags
7649 # "\ No newline at end of file",
7650 # or something else we don't recognize
7651 $ctext insert end "$line\n" hunksep
7655 if {[info exists seehere]} {
7656 mark_ctext_line [lindex [split $seehere .] 0]
7658 maybe_scroll_ctext [eof $bdf]
7659 $ctext conf -state disabled
7664 return [expr {$nr >= 1000? 2: 1}]
7667 proc changediffdisp {} {
7668 global ctext diffelide
7670 $ctext tag conf d0 -elide [lindex $diffelide 0]
7671 $ctext tag conf dresult -elide [lindex $diffelide 1]
7674 proc highlightfile {loc cline} {
7675 global ctext cflist cflist_top
7678 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
7679 $cflist tag add highlight $cline.0 "$cline.0 lineend"
7680 $cflist see $cline.0
7681 set cflist_top $cline
7685 global difffilestart ctext cmitmode
7687 if {$cmitmode eq "tree"} return
7690 set here [$ctext index @0,0]
7691 foreach loc $difffilestart {
7692 if {[$ctext compare $loc >= $here]} {
7693 highlightfile $prev $prevline
7699 highlightfile $prev $prevline
7703 global difffilestart ctext cmitmode
7705 if {$cmitmode eq "tree"} return
7706 set here [$ctext index @0,0]
7708 foreach loc $difffilestart {
7710 if {[$ctext compare $loc > $here]} {
7711 highlightfile $loc $line
7717 proc clear_ctext {{first 1.0}} {
7718 global ctext smarktop smarkbot
7719 global ctext_file_names ctext_file_lines
7722 set l [lindex [split $first .] 0]
7723 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
7726 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
7729 $ctext delete $first end
7730 if {$first eq "1.0"} {
7731 catch {unset pendinglinks}
7733 set ctext_file_names {}
7734 set ctext_file_lines {}
7737 proc settabs {{firstab {}}} {
7738 global firsttabstop tabstop ctext have_tk85
7740 if {$firstab ne {} && $have_tk85} {
7741 set firsttabstop $firstab
7743 set w [font measure textfont "0"]
7744 if {$firsttabstop != 0} {
7745 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
7746 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
7747 } elseif {$have_tk85 || $tabstop != 8} {
7748 $ctext conf -tabs [expr {$tabstop * $w}]
7750 $ctext conf -tabs {}
7754 proc incrsearch {name ix op} {
7755 global ctext searchstring searchdirn
7757 $ctext tag remove found 1.0 end
7758 if {[catch {$ctext index anchor}]} {
7759 # no anchor set, use start of selection, or of visible area
7760 set sel [$ctext tag ranges sel]
7762 $ctext mark set anchor [lindex $sel 0]
7763 } elseif {$searchdirn eq "-forwards"} {
7764 $ctext mark set anchor @0,0
7766 $ctext mark set anchor @0,[winfo height $ctext]
7769 if {$searchstring ne {}} {
7770 set here [$ctext search $searchdirn -- $searchstring anchor]
7779 global sstring ctext searchstring searchdirn
7782 $sstring icursor end
7783 set searchdirn -forwards
7784 if {$searchstring ne {}} {
7785 set sel [$ctext tag ranges sel]
7787 set start "[lindex $sel 0] + 1c"
7788 } elseif {[catch {set start [$ctext index anchor]}]} {
7791 set match [$ctext search -count mlen -- $searchstring $start]
7792 $ctext tag remove sel 1.0 end
7798 set mend "$match + $mlen c"
7799 $ctext tag add sel $match $mend
7800 $ctext mark unset anchor
7804 proc dosearchback {} {
7805 global sstring ctext searchstring searchdirn
7808 $sstring icursor end
7809 set searchdirn -backwards
7810 if {$searchstring ne {}} {
7811 set sel [$ctext tag ranges sel]
7813 set start [lindex $sel 0]
7814 } elseif {[catch {set start [$ctext index anchor]}]} {
7815 set start @0,[winfo height $ctext]
7817 set match [$ctext search -backwards -count ml -- $searchstring $start]
7818 $ctext tag remove sel 1.0 end
7824 set mend "$match + $ml c"
7825 $ctext tag add sel $match $mend
7826 $ctext mark unset anchor
7830 proc searchmark {first last} {
7831 global ctext searchstring
7835 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
7836 if {$match eq {}} break
7837 set mend "$match + $mlen c"
7838 $ctext tag add found $match $mend
7842 proc searchmarkvisible {doall} {
7843 global ctext smarktop smarkbot
7845 set topline [lindex [split [$ctext index @0,0] .] 0]
7846 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
7847 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
7848 # no overlap with previous
7849 searchmark $topline $botline
7850 set smarktop $topline
7851 set smarkbot $botline
7853 if {$topline < $smarktop} {
7854 searchmark $topline [expr {$smarktop-1}]
7855 set smarktop $topline
7857 if {$botline > $smarkbot} {
7858 searchmark [expr {$smarkbot+1}] $botline
7859 set smarkbot $botline
7864 proc scrolltext {f0 f1} {
7867 .bleft.bottom.sb set $f0 $f1
7868 if {$searchstring ne {}} {
7874 global linespc charspc canvx0 canvy0
7875 global xspc1 xspc2 lthickness
7877 set linespc [font metrics mainfont -linespace]
7878 set charspc [font measure mainfont "m"]
7879 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
7880 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
7881 set lthickness [expr {int($linespc / 9) + 1}]
7882 set xspc1(0) $linespc
7890 set ymax [lindex [$canv cget -scrollregion] 3]
7891 if {$ymax eq {} || $ymax == 0} return
7892 set span [$canv yview]
7895 allcanvs yview moveto [lindex $span 0]
7897 if {$selectedline ne {}} {
7898 selectline $selectedline 0
7899 allcanvs yview moveto [lindex $span 0]
7903 proc parsefont {f n} {
7906 set fontattr($f,family) [lindex $n 0]
7908 if {$s eq {} || $s == 0} {
7911 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
7913 set fontattr($f,size) $s
7914 set fontattr($f,weight) normal
7915 set fontattr($f,slant) roman
7916 foreach style [lrange $n 2 end] {
7919 "bold" {set fontattr($f,weight) $style}
7921 "italic" {set fontattr($f,slant) $style}
7926 proc fontflags {f {isbold 0}} {
7929 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
7930 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
7931 -slant $fontattr($f,slant)]
7937 set n [list $fontattr($f,family) $fontattr($f,size)]
7938 if {$fontattr($f,weight) eq "bold"} {
7941 if {$fontattr($f,slant) eq "italic"} {
7947 proc incrfont {inc} {
7948 global mainfont textfont ctext canv cflist showrefstop
7949 global stopped entries fontattr
7952 set s $fontattr(mainfont,size)
7957 set fontattr(mainfont,size) $s
7958 font config mainfont -size $s
7959 font config mainfontbold -size $s
7960 set mainfont [fontname mainfont]
7961 set s $fontattr(textfont,size)
7966 set fontattr(textfont,size) $s
7967 font config textfont -size $s
7968 font config textfontbold -size $s
7969 set textfont [fontname textfont]
7976 global sha1entry sha1string
7977 if {[string length $sha1string] == 40} {
7978 $sha1entry delete 0 end
7982 proc sha1change {n1 n2 op} {
7983 global sha1string currentid sha1but
7984 if {$sha1string == {}
7985 || ([info exists currentid] && $sha1string == $currentid)} {
7990 if {[$sha1but cget -state] == $state} return
7991 if {$state == "normal"} {
7992 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
7994 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
7998 proc gotocommit {} {
7999 global sha1string tagids headids curview varcid
8001 if {$sha1string == {}
8002 || ([info exists currentid] && $sha1string == $currentid)} return
8003 if {[info exists tagids($sha1string)]} {
8004 set id $tagids($sha1string)
8005 } elseif {[info exists headids($sha1string)]} {
8006 set id $headids($sha1string)
8008 set id [string tolower $sha1string]
8009 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8010 set matches [longid $id]
8011 if {$matches ne {}} {
8012 if {[llength $matches] > 1} {
8013 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8016 set id [lindex $matches 0]
8020 if {[commitinview $id $curview]} {
8021 selectline [rowofcommit $id] 1
8024 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8025 set msg [mc "SHA1 id %s is not known" $sha1string]
8027 set msg [mc "Tag/Head %s is not known" $sha1string]
8032 proc lineenter {x y id} {
8033 global hoverx hovery hoverid hovertimer
8034 global commitinfo canv
8036 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8040 if {[info exists hovertimer]} {
8041 after cancel $hovertimer
8043 set hovertimer [after 500 linehover]
8047 proc linemotion {x y id} {
8048 global hoverx hovery hoverid hovertimer
8050 if {[info exists hoverid] && $id == $hoverid} {
8053 if {[info exists hovertimer]} {
8054 after cancel $hovertimer
8056 set hovertimer [after 500 linehover]
8060 proc lineleave {id} {
8061 global hoverid hovertimer canv
8063 if {[info exists hoverid] && $id == $hoverid} {
8065 if {[info exists hovertimer]} {
8066 after cancel $hovertimer
8074 global hoverx hovery hoverid hovertimer
8075 global canv linespc lthickness
8078 set text [lindex $commitinfo($hoverid) 0]
8079 set ymax [lindex [$canv cget -scrollregion] 3]
8080 if {$ymax == {}} return
8081 set yfrac [lindex [$canv yview] 0]
8082 set x [expr {$hoverx + 2 * $linespc}]
8083 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8084 set x0 [expr {$x - 2 * $lthickness}]
8085 set y0 [expr {$y - 2 * $lthickness}]
8086 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8087 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8088 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8089 -fill \#ffff80 -outline black -width 1 -tags hover]
8091 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8096 proc clickisonarrow {id y} {
8099 set ranges [rowranges $id]
8100 set thresh [expr {2 * $lthickness + 6}]
8101 set n [expr {[llength $ranges] - 1}]
8102 for {set i 1} {$i < $n} {incr i} {
8103 set row [lindex $ranges $i]
8104 if {abs([yc $row] - $y) < $thresh} {
8111 proc arrowjump {id n y} {
8114 # 1 <-> 2, 3 <-> 4, etc...
8115 set n [expr {(($n - 1) ^ 1) + 1}]
8116 set row [lindex [rowranges $id] $n]
8118 set ymax [lindex [$canv cget -scrollregion] 3]
8119 if {$ymax eq {} || $ymax <= 0} return
8120 set view [$canv yview]
8121 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8122 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8126 allcanvs yview moveto $yfrac
8129 proc lineclick {x y id isnew} {
8130 global ctext commitinfo children canv thickerline curview
8132 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8137 # draw this line thicker than normal
8141 set ymax [lindex [$canv cget -scrollregion] 3]
8142 if {$ymax eq {}} return
8143 set yfrac [lindex [$canv yview] 0]
8144 set y [expr {$y + $yfrac * $ymax}]
8146 set dirn [clickisonarrow $id $y]
8148 arrowjump $id $dirn $y
8153 addtohistory [list lineclick $x $y $id 0] savectextpos
8155 # fill the details pane with info about this line
8156 $ctext conf -state normal
8159 $ctext insert end "[mc "Parent"]:\t"
8160 $ctext insert end $id link0
8162 set info $commitinfo($id)
8163 $ctext insert end "\n\t[lindex $info 0]\n"
8164 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8165 set date [formatdate [lindex $info 2]]
8166 $ctext insert end "\t[mc "Date"]:\t$date\n"
8167 set kids $children($curview,$id)
8169 $ctext insert end "\n[mc "Children"]:"
8171 foreach child $kids {
8173 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8174 set info $commitinfo($child)
8175 $ctext insert end "\n\t"
8176 $ctext insert end $child link$i
8177 setlink $child link$i
8178 $ctext insert end "\n\t[lindex $info 0]"
8179 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8180 set date [formatdate [lindex $info 2]]
8181 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8184 maybe_scroll_ctext 1
8185 $ctext conf -state disabled
8189 proc normalline {} {
8191 if {[info exists thickerline]} {
8198 proc selbyid {id {isnew 1}} {
8200 if {[commitinview $id $curview]} {
8201 selectline [rowofcommit $id] $isnew
8207 if {![info exists startmstime]} {
8208 set startmstime [clock clicks -milliseconds]
8210 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8213 proc rowmenu {x y id} {
8214 global rowctxmenu selectedline rowmenuid curview
8215 global nullid nullid2 fakerowmenu mainhead markedid
8219 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8224 if {$id ne $nullid && $id ne $nullid2} {
8225 set menu $rowctxmenu
8226 if {$mainhead ne {}} {
8227 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8229 $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8231 if {[info exists markedid] && $markedid ne $id} {
8232 $menu entryconfigure 9 -state normal
8233 $menu entryconfigure 10 -state normal
8234 $menu entryconfigure 11 -state normal
8236 $menu entryconfigure 9 -state disabled
8237 $menu entryconfigure 10 -state disabled
8238 $menu entryconfigure 11 -state disabled
8241 set menu $fakerowmenu
8243 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8244 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8245 $menu entryconfigure [mca "Make patch"] -state $state
8246 tk_popup $menu $x $y
8250 global rowmenuid markedid canv
8252 set markedid $rowmenuid
8253 make_idmark $markedid
8259 if {[info exists markedid]} {
8264 proc replace_by_kids {l r} {
8265 global curview children
8267 set id [commitonrow $r]
8268 set l [lreplace $l 0 0]
8269 foreach kid $children($curview,$id) {
8270 lappend l [rowofcommit $kid]
8272 return [lsort -integer -decreasing -unique $l]
8275 proc find_common_desc {} {
8276 global markedid rowmenuid curview children
8278 if {![info exists markedid]} return
8279 if {![commitinview $markedid $curview] ||
8280 ![commitinview $rowmenuid $curview]} return
8281 #set t1 [clock clicks -milliseconds]
8282 set l1 [list [rowofcommit $markedid]]
8283 set l2 [list [rowofcommit $rowmenuid]]
8285 set r1 [lindex $l1 0]
8286 set r2 [lindex $l2 0]
8287 if {$r1 eq {} || $r2 eq {}} break
8293 set l1 [replace_by_kids $l1 $r1]
8295 set l2 [replace_by_kids $l2 $r2]
8298 #set t2 [clock clicks -milliseconds]
8299 #puts "took [expr {$t2-$t1}]ms"
8302 proc compare_commits {} {
8303 global markedid rowmenuid curview children
8305 if {![info exists markedid]} return
8306 if {![commitinview $markedid $curview]} return
8307 addtohistory [list do_cmp_commits $markedid $rowmenuid]
8308 do_cmp_commits $markedid $rowmenuid
8311 proc getpatchid {id} {
8314 if {![info exists patchids($id)]} {
8315 set cmd [diffcmd [list $id] {-p --root}]
8316 # trim off the initial "|"
8317 set cmd [lrange $cmd 1 end]
8319 set x [eval exec $cmd | git patch-id]
8320 set patchids($id) [lindex $x 0]
8322 set patchids($id) "error"
8325 return $patchids($id)
8328 proc do_cmp_commits {a b} {
8329 global ctext curview parents children patchids commitinfo
8331 $ctext conf -state normal
8334 for {set i 0} {$i < 100} {incr i} {
8337 if {[llength $parents($curview,$a)] > 1} {
8338 appendshortlink $a [mc "Skipping merge commit "] "\n"
8341 set patcha [getpatchid $a]
8343 if {[llength $parents($curview,$b)] > 1} {
8344 appendshortlink $b [mc "Skipping merge commit "] "\n"
8347 set patchb [getpatchid $b]
8349 if {!$skipa && !$skipb} {
8350 set heada [lindex $commitinfo($a) 0]
8351 set headb [lindex $commitinfo($b) 0]
8352 if {$patcha eq "error"} {
8353 appendshortlink $a [mc "Error getting patch ID for "] \
8354 [mc " - stopping\n"]
8357 if {$patchb eq "error"} {
8358 appendshortlink $b [mc "Error getting patch ID for "] \
8359 [mc " - stopping\n"]
8362 if {$patcha eq $patchb} {
8363 if {$heada eq $headb} {
8364 appendshortlink $a [mc "Commit "]
8365 appendshortlink $b " == " " $heada\n"
8367 appendshortlink $a [mc "Commit "] " $heada\n"
8368 appendshortlink $b [mc " is the same patch as\n "] \
8374 $ctext insert end "\n"
8375 appendshortlink $a [mc "Commit "] " $heada\n"
8376 appendshortlink $b [mc " differs from\n "] \
8378 $ctext insert end [mc "- stopping\n"]
8383 if {[llength $children($curview,$a)] != 1} {
8384 $ctext insert end "\n"
8385 appendshortlink $a [mc "Commit "] \
8386 [mc " has %s children - stopping\n" \
8387 [llength $children($curview,$a)]]
8390 set a [lindex $children($curview,$a) 0]
8393 if {[llength $children($curview,$b)] != 1} {
8394 appendshortlink $b [mc "Commit "] \
8395 [mc " has %s children - stopping\n" \
8396 [llength $children($curview,$b)]]
8399 set b [lindex $children($curview,$b) 0]
8402 $ctext conf -state disabled
8405 proc diffvssel {dirn} {
8406 global rowmenuid selectedline
8408 if {$selectedline eq {}} return
8410 set oldid [commitonrow $selectedline]
8411 set newid $rowmenuid
8413 set oldid $rowmenuid
8414 set newid [commitonrow $selectedline]
8416 addtohistory [list doseldiff $oldid $newid] savectextpos
8417 doseldiff $oldid $newid
8420 proc doseldiff {oldid newid} {
8424 $ctext conf -state normal
8426 init_flist [mc "Top"]
8427 $ctext insert end "[mc "From"] "
8428 $ctext insert end $oldid link0
8429 setlink $oldid link0
8430 $ctext insert end "\n "
8431 $ctext insert end [lindex $commitinfo($oldid) 0]
8432 $ctext insert end "\n\n[mc "To"] "
8433 $ctext insert end $newid link1
8434 setlink $newid link1
8435 $ctext insert end "\n "
8436 $ctext insert end [lindex $commitinfo($newid) 0]
8437 $ctext insert end "\n"
8438 $ctext conf -state disabled
8439 $ctext tag remove found 1.0 end
8440 startdiff [list $oldid $newid]
8444 global rowmenuid currentid commitinfo patchtop patchnum NS
8446 if {![info exists currentid]} return
8447 set oldid $currentid
8448 set oldhead [lindex $commitinfo($oldid) 0]
8449 set newid $rowmenuid
8450 set newhead [lindex $commitinfo($newid) 0]
8453 catch {destroy $top}
8455 make_transient $top .
8456 ${NS}::label $top.title -text [mc "Generate patch"]
8457 grid $top.title - -pady 10
8458 ${NS}::label $top.from -text [mc "From:"]
8459 ${NS}::entry $top.fromsha1 -width 40
8460 $top.fromsha1 insert 0 $oldid
8461 $top.fromsha1 conf -state readonly
8462 grid $top.from $top.fromsha1 -sticky w
8463 ${NS}::entry $top.fromhead -width 60
8464 $top.fromhead insert 0 $oldhead
8465 $top.fromhead conf -state readonly
8466 grid x $top.fromhead -sticky w
8467 ${NS}::label $top.to -text [mc "To:"]
8468 ${NS}::entry $top.tosha1 -width 40
8469 $top.tosha1 insert 0 $newid
8470 $top.tosha1 conf -state readonly
8471 grid $top.to $top.tosha1 -sticky w
8472 ${NS}::entry $top.tohead -width 60
8473 $top.tohead insert 0 $newhead
8474 $top.tohead conf -state readonly
8475 grid x $top.tohead -sticky w
8476 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
8477 grid $top.rev x -pady 10 -padx 5
8478 ${NS}::label $top.flab -text [mc "Output file:"]
8479 ${NS}::entry $top.fname -width 60
8480 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
8482 grid $top.flab $top.fname -sticky w
8483 ${NS}::frame $top.buts
8484 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
8485 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
8486 bind $top <Key-Return> mkpatchgo
8487 bind $top <Key-Escape> mkpatchcan
8488 grid $top.buts.gen $top.buts.can
8489 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8490 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8491 grid $top.buts - -pady 10 -sticky ew
8495 proc mkpatchrev {} {
8498 set oldid [$patchtop.fromsha1 get]
8499 set oldhead [$patchtop.fromhead get]
8500 set newid [$patchtop.tosha1 get]
8501 set newhead [$patchtop.tohead get]
8502 foreach e [list fromsha1 fromhead tosha1 tohead] \
8503 v [list $newid $newhead $oldid $oldhead] {
8504 $patchtop.$e conf -state normal
8505 $patchtop.$e delete 0 end
8506 $patchtop.$e insert 0 $v
8507 $patchtop.$e conf -state readonly
8512 global patchtop nullid nullid2
8514 set oldid [$patchtop.fromsha1 get]
8515 set newid [$patchtop.tosha1 get]
8516 set fname [$patchtop.fname get]
8517 set cmd [diffcmd [list $oldid $newid] -p]
8518 # trim off the initial "|"
8519 set cmd [lrange $cmd 1 end]
8520 lappend cmd >$fname &
8521 if {[catch {eval exec $cmd} err]} {
8522 error_popup "[mc "Error creating patch:"] $err" $patchtop
8524 catch {destroy $patchtop}
8528 proc mkpatchcan {} {
8531 catch {destroy $patchtop}
8536 global rowmenuid mktagtop commitinfo NS
8540 catch {destroy $top}
8542 make_transient $top .
8543 ${NS}::label $top.title -text [mc "Create tag"]
8544 grid $top.title - -pady 10
8545 ${NS}::label $top.id -text [mc "ID:"]
8546 ${NS}::entry $top.sha1 -width 40
8547 $top.sha1 insert 0 $rowmenuid
8548 $top.sha1 conf -state readonly
8549 grid $top.id $top.sha1 -sticky w
8550 ${NS}::entry $top.head -width 60
8551 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8552 $top.head conf -state readonly
8553 grid x $top.head -sticky w
8554 ${NS}::label $top.tlab -text [mc "Tag name:"]
8555 ${NS}::entry $top.tag -width 60
8556 grid $top.tlab $top.tag -sticky w
8557 ${NS}::frame $top.buts
8558 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
8559 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
8560 bind $top <Key-Return> mktaggo
8561 bind $top <Key-Escape> mktagcan
8562 grid $top.buts.gen $top.buts.can
8563 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8564 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8565 grid $top.buts - -pady 10 -sticky ew
8570 global mktagtop env tagids idtags
8572 set id [$mktagtop.sha1 get]
8573 set tag [$mktagtop.tag get]
8575 error_popup [mc "No tag name specified"] $mktagtop
8578 if {[info exists tagids($tag)]} {
8579 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
8583 exec git tag $tag $id
8585 error_popup "[mc "Error creating tag:"] $err" $mktagtop
8589 set tagids($tag) $id
8590 lappend idtags($id) $tag
8598 proc redrawtags {id} {
8599 global canv linehtag idpos currentid curview cmitlisted markedid
8600 global canvxmax iddrawn circleitem mainheadid circlecolors
8602 if {![commitinview $id $curview]} return
8603 if {![info exists iddrawn($id)]} return
8604 set row [rowofcommit $id]
8605 if {$id eq $mainheadid} {
8608 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
8610 $canv itemconf $circleitem($row) -fill $ofill
8611 $canv delete tag.$id
8612 set xt [eval drawtags $id $idpos($id)]
8613 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
8614 set text [$canv itemcget $linehtag($id) -text]
8615 set font [$canv itemcget $linehtag($id) -font]
8616 set xr [expr {$xt + [font measure $font $text]}]
8617 if {$xr > $canvxmax} {
8621 if {[info exists currentid] && $currentid == $id} {
8624 if {[info exists markedid] && $markedid eq $id} {
8632 catch {destroy $mktagtop}
8637 if {![domktag]} return
8641 proc writecommit {} {
8642 global rowmenuid wrcomtop commitinfo wrcomcmd NS
8644 set top .writecommit
8646 catch {destroy $top}
8648 make_transient $top .
8649 ${NS}::label $top.title -text [mc "Write commit to file"]
8650 grid $top.title - -pady 10
8651 ${NS}::label $top.id -text [mc "ID:"]
8652 ${NS}::entry $top.sha1 -width 40
8653 $top.sha1 insert 0 $rowmenuid
8654 $top.sha1 conf -state readonly
8655 grid $top.id $top.sha1 -sticky w
8656 ${NS}::entry $top.head -width 60
8657 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
8658 $top.head conf -state readonly
8659 grid x $top.head -sticky w
8660 ${NS}::label $top.clab -text [mc "Command:"]
8661 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
8662 grid $top.clab $top.cmd -sticky w -pady 10
8663 ${NS}::label $top.flab -text [mc "Output file:"]
8664 ${NS}::entry $top.fname -width 60
8665 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
8666 grid $top.flab $top.fname -sticky w
8667 ${NS}::frame $top.buts
8668 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
8669 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
8670 bind $top <Key-Return> wrcomgo
8671 bind $top <Key-Escape> wrcomcan
8672 grid $top.buts.gen $top.buts.can
8673 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8674 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8675 grid $top.buts - -pady 10 -sticky ew
8682 set id [$wrcomtop.sha1 get]
8683 set cmd "echo $id | [$wrcomtop.cmd get]"
8684 set fname [$wrcomtop.fname get]
8685 if {[catch {exec sh -c $cmd >$fname &} err]} {
8686 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
8688 catch {destroy $wrcomtop}
8695 catch {destroy $wrcomtop}
8700 global rowmenuid mkbrtop NS
8703 catch {destroy $top}
8705 make_transient $top .
8706 ${NS}::label $top.title -text [mc "Create new branch"]
8707 grid $top.title - -pady 10
8708 ${NS}::label $top.id -text [mc "ID:"]
8709 ${NS}::entry $top.sha1 -width 40
8710 $top.sha1 insert 0 $rowmenuid
8711 $top.sha1 conf -state readonly
8712 grid $top.id $top.sha1 -sticky w
8713 ${NS}::label $top.nlab -text [mc "Name:"]
8714 ${NS}::entry $top.name -width 40
8715 grid $top.nlab $top.name -sticky w
8716 ${NS}::frame $top.buts
8717 ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
8718 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
8719 bind $top <Key-Return> [list mkbrgo $top]
8720 bind $top <Key-Escape> "catch {destroy $top}"
8721 grid $top.buts.go $top.buts.can
8722 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8723 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8724 grid $top.buts - -pady 10 -sticky ew
8729 global headids idheads
8731 set name [$top.name get]
8732 set id [$top.sha1 get]
8736 error_popup [mc "Please specify a name for the new branch"] $top
8739 if {[info exists headids($name)]} {
8740 if {![confirm_popup [mc \
8741 "Branch '%s' already exists. Overwrite?" $name] $top]} {
8744 set old_id $headids($name)
8747 catch {destroy $top}
8748 lappend cmdargs $name $id
8752 eval exec git branch $cmdargs
8758 if {$old_id ne {}} {
8764 set headids($name) $id
8765 lappend idheads($id) $name
8774 proc exec_citool {tool_args {baseid {}}} {
8775 global commitinfo env
8777 set save_env [array get env GIT_AUTHOR_*]
8779 if {$baseid ne {}} {
8780 if {![info exists commitinfo($baseid)]} {
8783 set author [lindex $commitinfo($baseid) 1]
8784 set date [lindex $commitinfo($baseid) 2]
8785 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
8786 $author author name email]
8788 set env(GIT_AUTHOR_NAME) $name
8789 set env(GIT_AUTHOR_EMAIL) $email
8790 set env(GIT_AUTHOR_DATE) $date
8794 eval exec git citool $tool_args &
8796 array unset env GIT_AUTHOR_*
8797 array set env $save_env
8800 proc cherrypick {} {
8801 global rowmenuid curview
8802 global mainhead mainheadid
8804 set oldhead [exec git rev-parse HEAD]
8805 set dheads [descheads $rowmenuid]
8806 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
8807 set ok [confirm_popup [mc "Commit %s is already\
8808 included in branch %s -- really re-apply it?" \
8809 [string range $rowmenuid 0 7] $mainhead]]
8812 nowbusy cherrypick [mc "Cherry-picking"]
8814 # Unfortunately git-cherry-pick writes stuff to stderr even when
8815 # no error occurs, and exec takes that as an indication of error...
8816 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
8819 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
8821 error_popup [mc "Cherry-pick failed because of local changes\
8822 to file '%s'.\nPlease commit, reset or stash\
8823 your changes and try again." $fname]
8824 } elseif {[regexp -line \
8825 {^(CONFLICT \(.*\):|Automatic cherry-pick failed)} \
8827 if {[confirm_popup [mc "Cherry-pick failed because of merge\
8828 conflict.\nDo you wish to run git citool to\
8830 # Force citool to read MERGE_MSG
8831 file delete [file join [gitdir] "GITGUI_MSG"]
8832 exec_citool {} $rowmenuid
8840 set newhead [exec git rev-parse HEAD]
8841 if {$newhead eq $oldhead} {
8843 error_popup [mc "No changes committed"]
8846 addnewchild $newhead $oldhead
8847 if {[commitinview $oldhead $curview]} {
8848 # XXX this isn't right if we have a path limit...
8849 insertrow $newhead $oldhead $curview
8850 if {$mainhead ne {}} {
8851 movehead $newhead $mainhead
8852 movedhead $newhead $mainhead
8854 set mainheadid $newhead
8863 global mainhead rowmenuid confirm_ok resettype NS
8866 set w ".confirmreset"
8869 wm title $w [mc "Confirm reset"]
8870 ${NS}::label $w.m -text \
8871 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
8872 pack $w.m -side top -fill x -padx 20 -pady 20
8873 ${NS}::labelframe $w.f -text [mc "Reset type:"]
8875 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
8876 -text [mc "Soft: Leave working tree and index untouched"]
8877 grid $w.f.soft -sticky w
8878 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
8879 -text [mc "Mixed: Leave working tree untouched, reset index"]
8880 grid $w.f.mixed -sticky w
8881 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
8882 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
8883 grid $w.f.hard -sticky w
8884 pack $w.f -side top -fill x -padx 4
8885 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
8886 pack $w.ok -side left -fill x -padx 20 -pady 20
8887 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
8888 bind $w <Key-Escape> [list destroy $w]
8889 pack $w.cancel -side right -fill x -padx 20 -pady 20
8890 bind $w <Visibility> "grab $w; focus $w"
8892 if {!$confirm_ok} return
8893 if {[catch {set fd [open \
8894 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
8898 filerun $fd [list readresetstat $fd]
8899 nowbusy reset [mc "Resetting"]
8904 proc readresetstat {fd} {
8905 global mainhead mainheadid showlocalchanges rprogcoord
8907 if {[gets $fd line] >= 0} {
8908 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8909 set rprogcoord [expr {1.0 * $m / $n}]
8917 if {[catch {close $fd} err]} {
8920 set oldhead $mainheadid
8921 set newhead [exec git rev-parse HEAD]
8922 if {$newhead ne $oldhead} {
8923 movehead $newhead $mainhead
8924 movedhead $newhead $mainhead
8925 set mainheadid $newhead
8929 if {$showlocalchanges} {
8935 # context menu for a head
8936 proc headmenu {x y id head} {
8937 global headmenuid headmenuhead headctxmenu mainhead
8941 set headmenuhead $head
8943 if {$head eq $mainhead} {
8946 $headctxmenu entryconfigure 0 -state $state
8947 $headctxmenu entryconfigure 1 -state $state
8948 tk_popup $headctxmenu $x $y
8952 global headmenuid headmenuhead headids
8953 global showlocalchanges
8955 # check the tree is clean first??
8956 nowbusy checkout [mc "Checking out"]
8960 set fd [open [list | git checkout $headmenuhead 2>@1] r]
8964 if {$showlocalchanges} {
8968 filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
8972 proc readcheckoutstat {fd newhead newheadid} {
8973 global mainhead mainheadid headids showlocalchanges progresscoords
8974 global viewmainheadid curview
8976 if {[gets $fd line] >= 0} {
8977 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
8978 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
8983 set progresscoords {0 0}
8986 if {[catch {close $fd} err]} {
8989 set oldmainid $mainheadid
8990 set mainhead $newhead
8991 set mainheadid $newheadid
8992 set viewmainheadid($curview) $newheadid
8993 redrawtags $oldmainid
8994 redrawtags $newheadid
8996 if {$showlocalchanges} {
9002 global headmenuid headmenuhead mainhead
9005 set head $headmenuhead
9007 # this check shouldn't be needed any more...
9008 if {$head eq $mainhead} {
9009 error_popup [mc "Cannot delete the currently checked-out branch"]
9012 set dheads [descheads $id]
9013 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9014 # the stuff on this branch isn't on any other branch
9015 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9016 branch.\nReally delete branch %s?" $head $head]]} return
9020 if {[catch {exec git branch -D $head} err]} {
9025 removehead $id $head
9026 removedhead $id $head
9033 # Display a list of tags and heads
9035 global showrefstop bgcolor fgcolor selectbgcolor NS
9036 global bglist fglist reflistfilter reflist maincursor
9039 set showrefstop $top
9040 if {[winfo exists $top]} {
9046 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9047 make_transient $top .
9048 text $top.list -background $bgcolor -foreground $fgcolor \
9049 -selectbackground $selectbgcolor -font mainfont \
9050 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9051 -width 30 -height 20 -cursor $maincursor \
9052 -spacing1 1 -spacing3 1 -state disabled
9053 $top.list tag configure highlight -background $selectbgcolor
9054 lappend bglist $top.list
9055 lappend fglist $top.list
9056 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9057 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9058 grid $top.list $top.ysb -sticky nsew
9059 grid $top.xsb x -sticky ew
9061 ${NS}::label $top.f.l -text "[mc "Filter"]: "
9062 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9063 set reflistfilter "*"
9064 trace add variable reflistfilter write reflistfilter_change
9065 pack $top.f.e -side right -fill x -expand 1
9066 pack $top.f.l -side left
9067 grid $top.f - -sticky ew -pady 2
9068 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9069 bind $top <Key-Escape> [list destroy $top]
9071 grid columnconfigure $top 0 -weight 1
9072 grid rowconfigure $top 0 -weight 1
9073 bind $top.list <1> {break}
9074 bind $top.list <B1-Motion> {break}
9075 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9080 proc sel_reflist {w x y} {
9081 global showrefstop reflist headids tagids otherrefids
9083 if {![winfo exists $showrefstop]} return
9084 set l [lindex [split [$w index "@$x,$y"] "."] 0]
9085 set ref [lindex $reflist [expr {$l-1}]]
9086 set n [lindex $ref 0]
9087 switch -- [lindex $ref 1] {
9088 "H" {selbyid $headids($n)}
9089 "T" {selbyid $tagids($n)}
9090 "o" {selbyid $otherrefids($n)}
9092 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9095 proc unsel_reflist {} {
9098 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9099 $showrefstop.list tag remove highlight 0.0 end
9102 proc reflistfilter_change {n1 n2 op} {
9103 global reflistfilter
9105 after cancel refill_reflist
9106 after 200 refill_reflist
9109 proc refill_reflist {} {
9110 global reflist reflistfilter showrefstop headids tagids otherrefids
9113 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9115 foreach n [array names headids] {
9116 if {[string match $reflistfilter $n]} {
9117 if {[commitinview $headids($n) $curview]} {
9118 lappend refs [list $n H]
9120 interestedin $headids($n) {run refill_reflist}
9124 foreach n [array names tagids] {
9125 if {[string match $reflistfilter $n]} {
9126 if {[commitinview $tagids($n) $curview]} {
9127 lappend refs [list $n T]
9129 interestedin $tagids($n) {run refill_reflist}
9133 foreach n [array names otherrefids] {
9134 if {[string match $reflistfilter $n]} {
9135 if {[commitinview $otherrefids($n) $curview]} {
9136 lappend refs [list $n o]
9138 interestedin $otherrefids($n) {run refill_reflist}
9142 set refs [lsort -index 0 $refs]
9143 if {$refs eq $reflist} return
9145 # Update the contents of $showrefstop.list according to the
9146 # differences between $reflist (old) and $refs (new)
9147 $showrefstop.list conf -state normal
9148 $showrefstop.list insert end "\n"
9151 while {$i < [llength $reflist] || $j < [llength $refs]} {
9152 if {$i < [llength $reflist]} {
9153 if {$j < [llength $refs]} {
9154 set cmp [string compare [lindex $reflist $i 0] \
9155 [lindex $refs $j 0]]
9157 set cmp [string compare [lindex $reflist $i 1] \
9158 [lindex $refs $j 1]]
9168 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9176 set l [expr {$j + 1}]
9177 $showrefstop.list image create $l.0 -align baseline \
9178 -image reficon-[lindex $refs $j 1] -padx 2
9179 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9185 # delete last newline
9186 $showrefstop.list delete end-2c end-1c
9187 $showrefstop.list conf -state disabled
9190 # Stuff for finding nearby tags
9191 proc getallcommits {} {
9192 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9193 global idheads idtags idotherrefs allparents tagobjid
9195 if {![info exists allcommits]} {
9201 set allccache [file join [gitdir] "gitk.cache"]
9203 set f [open $allccache r]
9212 set cmd [list | git rev-list --parents]
9213 set allcupdate [expr {$seeds ne {}}]
9217 set refs [concat [array names idheads] [array names idtags] \
9218 [array names idotherrefs]]
9221 foreach name [array names tagobjid] {
9222 lappend tagobjs $tagobjid($name)
9224 foreach id [lsort -unique $refs] {
9225 if {![info exists allparents($id)] &&
9226 [lsearch -exact $tagobjs $id] < 0} {
9237 set fd [open [concat $cmd $ids] r]
9238 fconfigure $fd -blocking 0
9241 filerun $fd [list getallclines $fd]
9247 # Since most commits have 1 parent and 1 child, we group strings of
9248 # such commits into "arcs" joining branch/merge points (BMPs), which
9249 # are commits that either don't have 1 parent or don't have 1 child.
9251 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9252 # arcout(id) - outgoing arcs for BMP
9253 # arcids(a) - list of IDs on arc including end but not start
9254 # arcstart(a) - BMP ID at start of arc
9255 # arcend(a) - BMP ID at end of arc
9256 # growing(a) - arc a is still growing
9257 # arctags(a) - IDs out of arcids (excluding end) that have tags
9258 # archeads(a) - IDs out of arcids (excluding end) that have heads
9259 # The start of an arc is at the descendent end, so "incoming" means
9260 # coming from descendents, and "outgoing" means going towards ancestors.
9262 proc getallclines {fd} {
9263 global allparents allchildren idtags idheads nextarc
9264 global arcnos arcids arctags arcout arcend arcstart archeads growing
9265 global seeds allcommits cachedarcs allcupdate
9268 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9269 set id [lindex $line 0]
9270 if {[info exists allparents($id)]} {
9275 set olds [lrange $line 1 end]
9276 set allparents($id) $olds
9277 if {![info exists allchildren($id)]} {
9278 set allchildren($id) {}
9283 if {[llength $olds] == 1 && [llength $a] == 1} {
9284 lappend arcids($a) $id
9285 if {[info exists idtags($id)]} {
9286 lappend arctags($a) $id
9288 if {[info exists idheads($id)]} {
9289 lappend archeads($a) $id
9291 if {[info exists allparents($olds)]} {
9292 # seen parent already
9293 if {![info exists arcout($olds)]} {
9296 lappend arcids($a) $olds
9297 set arcend($a) $olds
9300 lappend allchildren($olds) $id
9301 lappend arcnos($olds) $a
9305 foreach a $arcnos($id) {
9306 lappend arcids($a) $id
9313 lappend allchildren($p) $id
9314 set a [incr nextarc]
9315 set arcstart($a) $id
9322 if {[info exists allparents($p)]} {
9323 # seen it already, may need to make a new branch
9324 if {![info exists arcout($p)]} {
9327 lappend arcids($a) $p
9331 lappend arcnos($p) $a
9336 global cached_dheads cached_dtags cached_atags
9337 catch {unset cached_dheads}
9338 catch {unset cached_dtags}
9339 catch {unset cached_atags}
9342 return [expr {$nid >= 1000? 2: 1}]
9346 fconfigure $fd -blocking 1
9349 # got an error reading the list of commits
9350 # if we were updating, try rereading the whole thing again
9356 error_popup "[mc "Error reading commit topology information;\
9357 branch and preceding/following tag information\
9358 will be incomplete."]\n($err)"
9361 if {[incr allcommits -1] == 0} {
9371 proc recalcarc {a} {
9372 global arctags archeads arcids idtags idheads
9376 foreach id [lrange $arcids($a) 0 end-1] {
9377 if {[info exists idtags($id)]} {
9380 if {[info exists idheads($id)]} {
9385 set archeads($a) $ah
9389 global arcnos arcids nextarc arctags archeads idtags idheads
9390 global arcstart arcend arcout allparents growing
9393 if {[llength $a] != 1} {
9394 puts "oops splitarc called but [llength $a] arcs already"
9398 set i [lsearch -exact $arcids($a) $p]
9400 puts "oops splitarc $p not in arc $a"
9403 set na [incr nextarc]
9404 if {[info exists arcend($a)]} {
9405 set arcend($na) $arcend($a)
9407 set l [lindex $allparents([lindex $arcids($a) end]) 0]
9408 set j [lsearch -exact $arcnos($l) $a]
9409 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
9411 set tail [lrange $arcids($a) [expr {$i+1}] end]
9412 set arcids($a) [lrange $arcids($a) 0 $i]
9414 set arcstart($na) $p
9416 set arcids($na) $tail
9417 if {[info exists growing($a)]} {
9423 if {[llength $arcnos($id)] == 1} {
9426 set j [lsearch -exact $arcnos($id) $a]
9427 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
9431 # reconstruct tags and heads lists
9432 if {$arctags($a) ne {} || $archeads($a) ne {}} {
9437 set archeads($na) {}
9441 # Update things for a new commit added that is a child of one
9442 # existing commit. Used when cherry-picking.
9443 proc addnewchild {id p} {
9444 global allparents allchildren idtags nextarc
9445 global arcnos arcids arctags arcout arcend arcstart archeads growing
9446 global seeds allcommits
9448 if {![info exists allcommits] || ![info exists arcnos($p)]} return
9449 set allparents($id) [list $p]
9450 set allchildren($id) {}
9453 lappend allchildren($p) $id
9454 set a [incr nextarc]
9455 set arcstart($a) $id
9458 set arcids($a) [list $p]
9460 if {![info exists arcout($p)]} {
9463 lappend arcnos($p) $a
9464 set arcout($id) [list $a]
9467 # This implements a cache for the topology information.
9468 # The cache saves, for each arc, the start and end of the arc,
9469 # the ids on the arc, and the outgoing arcs from the end.
9470 proc readcache {f} {
9471 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
9472 global idtags idheads allparents cachedarcs possible_seeds seeds growing
9477 if {$lim - $a > 500} {
9478 set lim [expr {$a + 500}]
9482 # finish reading the cache and setting up arctags, etc.
9484 if {$line ne "1"} {error "bad final version"}
9486 foreach id [array names idtags] {
9487 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9488 [llength $allparents($id)] == 1} {
9489 set a [lindex $arcnos($id) 0]
9490 if {$arctags($a) eq {}} {
9495 foreach id [array names idheads] {
9496 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
9497 [llength $allparents($id)] == 1} {
9498 set a [lindex $arcnos($id) 0]
9499 if {$archeads($a) eq {}} {
9504 foreach id [lsort -unique $possible_seeds] {
9505 if {$arcnos($id) eq {}} {
9511 while {[incr a] <= $lim} {
9513 if {[llength $line] != 3} {error "bad line"}
9514 set s [lindex $line 0]
9516 lappend arcout($s) $a
9517 if {![info exists arcnos($s)]} {
9518 lappend possible_seeds $s
9521 set e [lindex $line 1]
9526 if {![info exists arcout($e)]} {
9530 set arcids($a) [lindex $line 2]
9531 foreach id $arcids($a) {
9532 lappend allparents($s) $id
9534 lappend arcnos($id) $a
9536 if {![info exists allparents($s)]} {
9537 set allparents($s) {}
9542 set nextarc [expr {$a - 1}]
9555 global nextarc cachedarcs possible_seeds
9559 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
9560 # make sure it's an integer
9561 set cachedarcs [expr {int([lindex $line 1])}]
9562 if {$cachedarcs < 0} {error "bad number of arcs"}
9564 set possible_seeds {}
9572 proc dropcache {err} {
9573 global allcwait nextarc cachedarcs seeds
9575 #puts "dropping cache ($err)"
9576 foreach v {arcnos arcout arcids arcstart arcend growing \
9577 arctags archeads allparents allchildren} {
9588 proc writecache {f} {
9589 global cachearc cachedarcs allccache
9590 global arcstart arcend arcnos arcids arcout
9594 if {$lim - $a > 1000} {
9595 set lim [expr {$a + 1000}]
9598 while {[incr a] <= $lim} {
9599 if {[info exists arcend($a)]} {
9600 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
9602 puts $f [list $arcstart($a) {} $arcids($a)]
9607 catch {file delete $allccache}
9608 #puts "writing cache failed ($err)"
9611 set cachearc [expr {$a - 1}]
9612 if {$a > $cachedarcs} {
9621 global nextarc cachedarcs cachearc allccache
9623 if {$nextarc == $cachedarcs} return
9625 set cachedarcs $nextarc
9627 set f [open $allccache w]
9628 puts $f [list 1 $cachedarcs]
9633 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
9634 # or 0 if neither is true.
9635 proc anc_or_desc {a b} {
9636 global arcout arcstart arcend arcnos cached_isanc
9638 if {$arcnos($a) eq $arcnos($b)} {
9639 # Both are on the same arc(s); either both are the same BMP,
9640 # or if one is not a BMP, the other is also not a BMP or is
9641 # the BMP at end of the arc (and it only has 1 incoming arc).
9642 # Or both can be BMPs with no incoming arcs.
9643 if {$a eq $b || $arcnos($a) eq {}} {
9646 # assert {[llength $arcnos($a)] == 1}
9647 set arc [lindex $arcnos($a) 0]
9648 set i [lsearch -exact $arcids($arc) $a]
9649 set j [lsearch -exact $arcids($arc) $b]
9650 if {$i < 0 || $i > $j} {
9657 if {![info exists arcout($a)]} {
9658 set arc [lindex $arcnos($a) 0]
9659 if {[info exists arcend($arc)]} {
9660 set aend $arcend($arc)
9664 set a $arcstart($arc)
9668 if {![info exists arcout($b)]} {
9669 set arc [lindex $arcnos($b) 0]
9670 if {[info exists arcend($arc)]} {
9671 set bend $arcend($arc)
9675 set b $arcstart($arc)
9685 if {[info exists cached_isanc($a,$bend)]} {
9686 if {$cached_isanc($a,$bend)} {
9690 if {[info exists cached_isanc($b,$aend)]} {
9691 if {$cached_isanc($b,$aend)} {
9694 if {[info exists cached_isanc($a,$bend)]} {
9699 set todo [list $a $b]
9702 for {set i 0} {$i < [llength $todo]} {incr i} {
9703 set x [lindex $todo $i]
9704 if {$anc($x) eq {}} {
9707 foreach arc $arcnos($x) {
9708 set xd $arcstart($arc)
9710 set cached_isanc($a,$bend) 1
9711 set cached_isanc($b,$aend) 0
9713 } elseif {$xd eq $aend} {
9714 set cached_isanc($b,$aend) 1
9715 set cached_isanc($a,$bend) 0
9718 if {![info exists anc($xd)]} {
9719 set anc($xd) $anc($x)
9721 } elseif {$anc($xd) ne $anc($x)} {
9726 set cached_isanc($a,$bend) 0
9727 set cached_isanc($b,$aend) 0
9731 # This identifies whether $desc has an ancestor that is
9732 # a growing tip of the graph and which is not an ancestor of $anc
9733 # and returns 0 if so and 1 if not.
9734 # If we subsequently discover a tag on such a growing tip, and that
9735 # turns out to be a descendent of $anc (which it could, since we
9736 # don't necessarily see children before parents), then $desc
9737 # isn't a good choice to display as a descendent tag of
9738 # $anc (since it is the descendent of another tag which is
9739 # a descendent of $anc). Similarly, $anc isn't a good choice to
9740 # display as a ancestor tag of $desc.
9742 proc is_certain {desc anc} {
9743 global arcnos arcout arcstart arcend growing problems
9746 if {[llength $arcnos($anc)] == 1} {
9747 # tags on the same arc are certain
9748 if {$arcnos($desc) eq $arcnos($anc)} {
9751 if {![info exists arcout($anc)]} {
9752 # if $anc is partway along an arc, use the start of the arc instead
9753 set a [lindex $arcnos($anc) 0]
9754 set anc $arcstart($a)
9757 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
9760 set a [lindex $arcnos($desc) 0]
9766 set anclist [list $x]
9770 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
9771 set x [lindex $anclist $i]
9776 foreach a $arcout($x) {
9777 if {[info exists growing($a)]} {
9778 if {![info exists growanc($x)] && $dl($x)} {
9784 if {[info exists dl($y)]} {
9788 if {![info exists done($y)]} {
9791 if {[info exists growanc($x)]} {
9795 for {set k 0} {$k < [llength $xl]} {incr k} {
9796 set z [lindex $xl $k]
9797 foreach c $arcout($z) {
9798 if {[info exists arcend($c)]} {
9800 if {[info exists dl($v)] && $dl($v)} {
9802 if {![info exists done($v)]} {
9805 if {[info exists growanc($v)]} {
9815 } elseif {$y eq $anc || !$dl($x)} {
9826 foreach x [array names growanc] {
9835 proc validate_arctags {a} {
9836 global arctags idtags
9840 foreach id $arctags($a) {
9842 if {![info exists idtags($id)]} {
9843 set na [lreplace $na $i $i]
9850 proc validate_archeads {a} {
9851 global archeads idheads
9854 set na $archeads($a)
9855 foreach id $archeads($a) {
9857 if {![info exists idheads($id)]} {
9858 set na [lreplace $na $i $i]
9862 set archeads($a) $na
9865 # Return the list of IDs that have tags that are descendents of id,
9866 # ignoring IDs that are descendents of IDs already reported.
9867 proc desctags {id} {
9868 global arcnos arcstart arcids arctags idtags allparents
9869 global growing cached_dtags
9871 if {![info exists allparents($id)]} {
9874 set t1 [clock clicks -milliseconds]
9876 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
9877 # part-way along an arc; check that arc first
9878 set a [lindex $arcnos($id) 0]
9879 if {$arctags($a) ne {}} {
9881 set i [lsearch -exact $arcids($a) $id]
9883 foreach t $arctags($a) {
9884 set j [lsearch -exact $arcids($a) $t]
9892 set id $arcstart($a)
9893 if {[info exists idtags($id)]} {
9897 if {[info exists cached_dtags($id)]} {
9898 return $cached_dtags($id)
9905 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
9906 set id [lindex $todo $i]
9908 set ta [info exists hastaggedancestor($id)]
9912 # ignore tags on starting node
9913 if {!$ta && $i > 0} {
9914 if {[info exists idtags($id)]} {
9917 } elseif {[info exists cached_dtags($id)]} {
9918 set tagloc($id) $cached_dtags($id)
9922 foreach a $arcnos($id) {
9924 if {!$ta && $arctags($a) ne {}} {
9926 if {$arctags($a) ne {}} {
9927 lappend tagloc($id) [lindex $arctags($a) end]
9930 if {$ta || $arctags($a) ne {}} {
9931 set tomark [list $d]
9932 for {set j 0} {$j < [llength $tomark]} {incr j} {
9933 set dd [lindex $tomark $j]
9934 if {![info exists hastaggedancestor($dd)]} {
9935 if {[info exists done($dd)]} {
9936 foreach b $arcnos($dd) {
9937 lappend tomark $arcstart($b)
9939 if {[info exists tagloc($dd)]} {
9942 } elseif {[info exists queued($dd)]} {
9945 set hastaggedancestor($dd) 1
9949 if {![info exists queued($d)]} {
9952 if {![info exists hastaggedancestor($d)]} {
9959 foreach id [array names tagloc] {
9960 if {![info exists hastaggedancestor($id)]} {
9961 foreach t $tagloc($id) {
9962 if {[lsearch -exact $tags $t] < 0} {
9968 set t2 [clock clicks -milliseconds]
9971 # remove tags that are descendents of other tags
9972 for {set i 0} {$i < [llength $tags]} {incr i} {
9973 set a [lindex $tags $i]
9974 for {set j 0} {$j < $i} {incr j} {
9975 set b [lindex $tags $j]
9976 set r [anc_or_desc $a $b]
9978 set tags [lreplace $tags $j $j]
9981 } elseif {$r == -1} {
9982 set tags [lreplace $tags $i $i]
9989 if {[array names growing] ne {}} {
9990 # graph isn't finished, need to check if any tag could get
9991 # eclipsed by another tag coming later. Simply ignore any
9992 # tags that could later get eclipsed.
9995 if {[is_certain $t $origid]} {
9999 if {$tags eq $ctags} {
10000 set cached_dtags($origid) $tags
10005 set cached_dtags($origid) $tags
10007 set t3 [clock clicks -milliseconds]
10008 if {0 && $t3 - $t1 >= 100} {
10009 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10010 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10015 proc anctags {id} {
10016 global arcnos arcids arcout arcend arctags idtags allparents
10017 global growing cached_atags
10019 if {![info exists allparents($id)]} {
10022 set t1 [clock clicks -milliseconds]
10024 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10025 # part-way along an arc; check that arc first
10026 set a [lindex $arcnos($id) 0]
10027 if {$arctags($a) ne {}} {
10028 validate_arctags $a
10029 set i [lsearch -exact $arcids($a) $id]
10030 foreach t $arctags($a) {
10031 set j [lsearch -exact $arcids($a) $t]
10037 if {![info exists arcend($a)]} {
10041 if {[info exists idtags($id)]} {
10045 if {[info exists cached_atags($id)]} {
10046 return $cached_atags($id)
10050 set todo [list $id]
10054 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10055 set id [lindex $todo $i]
10057 set td [info exists hastaggeddescendent($id)]
10061 # ignore tags on starting node
10062 if {!$td && $i > 0} {
10063 if {[info exists idtags($id)]} {
10064 set tagloc($id) $id
10066 } elseif {[info exists cached_atags($id)]} {
10067 set tagloc($id) $cached_atags($id)
10071 foreach a $arcout($id) {
10072 if {!$td && $arctags($a) ne {}} {
10073 validate_arctags $a
10074 if {$arctags($a) ne {}} {
10075 lappend tagloc($id) [lindex $arctags($a) 0]
10078 if {![info exists arcend($a)]} continue
10080 if {$td || $arctags($a) ne {}} {
10081 set tomark [list $d]
10082 for {set j 0} {$j < [llength $tomark]} {incr j} {
10083 set dd [lindex $tomark $j]
10084 if {![info exists hastaggeddescendent($dd)]} {
10085 if {[info exists done($dd)]} {
10086 foreach b $arcout($dd) {
10087 if {[info exists arcend($b)]} {
10088 lappend tomark $arcend($b)
10091 if {[info exists tagloc($dd)]} {
10094 } elseif {[info exists queued($dd)]} {
10097 set hastaggeddescendent($dd) 1
10101 if {![info exists queued($d)]} {
10104 if {![info exists hastaggeddescendent($d)]} {
10110 set t2 [clock clicks -milliseconds]
10113 foreach id [array names tagloc] {
10114 if {![info exists hastaggeddescendent($id)]} {
10115 foreach t $tagloc($id) {
10116 if {[lsearch -exact $tags $t] < 0} {
10123 # remove tags that are ancestors of other tags
10124 for {set i 0} {$i < [llength $tags]} {incr i} {
10125 set a [lindex $tags $i]
10126 for {set j 0} {$j < $i} {incr j} {
10127 set b [lindex $tags $j]
10128 set r [anc_or_desc $a $b]
10130 set tags [lreplace $tags $j $j]
10133 } elseif {$r == 1} {
10134 set tags [lreplace $tags $i $i]
10141 if {[array names growing] ne {}} {
10142 # graph isn't finished, need to check if any tag could get
10143 # eclipsed by another tag coming later. Simply ignore any
10144 # tags that could later get eclipsed.
10147 if {[is_certain $origid $t]} {
10151 if {$tags eq $ctags} {
10152 set cached_atags($origid) $tags
10157 set cached_atags($origid) $tags
10159 set t3 [clock clicks -milliseconds]
10160 if {0 && $t3 - $t1 >= 100} {
10161 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10162 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10167 # Return the list of IDs that have heads that are descendents of id,
10168 # including id itself if it has a head.
10169 proc descheads {id} {
10170 global arcnos arcstart arcids archeads idheads cached_dheads
10173 if {![info exists allparents($id)]} {
10177 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10178 # part-way along an arc; check it first
10179 set a [lindex $arcnos($id) 0]
10180 if {$archeads($a) ne {}} {
10181 validate_archeads $a
10182 set i [lsearch -exact $arcids($a) $id]
10183 foreach t $archeads($a) {
10184 set j [lsearch -exact $arcids($a) $t]
10189 set id $arcstart($a)
10192 set todo [list $id]
10195 for {set i 0} {$i < [llength $todo]} {incr i} {
10196 set id [lindex $todo $i]
10197 if {[info exists cached_dheads($id)]} {
10198 set ret [concat $ret $cached_dheads($id)]
10200 if {[info exists idheads($id)]} {
10203 foreach a $arcnos($id) {
10204 if {$archeads($a) ne {}} {
10205 validate_archeads $a
10206 if {$archeads($a) ne {}} {
10207 set ret [concat $ret $archeads($a)]
10210 set d $arcstart($a)
10211 if {![info exists seen($d)]} {
10218 set ret [lsort -unique $ret]
10219 set cached_dheads($origid) $ret
10220 return [concat $ret $aret]
10223 proc addedtag {id} {
10224 global arcnos arcout cached_dtags cached_atags
10226 if {![info exists arcnos($id)]} return
10227 if {![info exists arcout($id)]} {
10228 recalcarc [lindex $arcnos($id) 0]
10230 catch {unset cached_dtags}
10231 catch {unset cached_atags}
10234 proc addedhead {hid head} {
10235 global arcnos arcout cached_dheads
10237 if {![info exists arcnos($hid)]} return
10238 if {![info exists arcout($hid)]} {
10239 recalcarc [lindex $arcnos($hid) 0]
10241 catch {unset cached_dheads}
10244 proc removedhead {hid head} {
10245 global cached_dheads
10247 catch {unset cached_dheads}
10250 proc movedhead {hid head} {
10251 global arcnos arcout cached_dheads
10253 if {![info exists arcnos($hid)]} return
10254 if {![info exists arcout($hid)]} {
10255 recalcarc [lindex $arcnos($hid) 0]
10257 catch {unset cached_dheads}
10260 proc changedrefs {} {
10261 global cached_dheads cached_dtags cached_atags
10262 global arctags archeads arcnos arcout idheads idtags
10264 foreach id [concat [array names idheads] [array names idtags]] {
10265 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10266 set a [lindex $arcnos($id) 0]
10267 if {![info exists donearc($a)]} {
10273 catch {unset cached_dtags}
10274 catch {unset cached_atags}
10275 catch {unset cached_dheads}
10278 proc rereadrefs {} {
10279 global idtags idheads idotherrefs mainheadid
10281 set refids [concat [array names idtags] \
10282 [array names idheads] [array names idotherrefs]]
10283 foreach id $refids {
10284 if {![info exists ref($id)]} {
10285 set ref($id) [listrefs $id]
10288 set oldmainhead $mainheadid
10291 set refids [lsort -unique [concat $refids [array names idtags] \
10292 [array names idheads] [array names idotherrefs]]]
10293 foreach id $refids {
10294 set v [listrefs $id]
10295 if {![info exists ref($id)] || $ref($id) != $v} {
10299 if {$oldmainhead ne $mainheadid} {
10300 redrawtags $oldmainhead
10301 redrawtags $mainheadid
10306 proc listrefs {id} {
10307 global idtags idheads idotherrefs
10310 if {[info exists idtags($id)]} {
10314 if {[info exists idheads($id)]} {
10315 set y $idheads($id)
10318 if {[info exists idotherrefs($id)]} {
10319 set z $idotherrefs($id)
10321 return [list $x $y $z]
10324 proc showtag {tag isnew} {
10325 global ctext tagcontents tagids linknum tagobjid
10328 addtohistory [list showtag $tag 0] savectextpos
10330 $ctext conf -state normal
10334 if {![info exists tagcontents($tag)]} {
10336 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
10339 if {[info exists tagcontents($tag)]} {
10340 set text $tagcontents($tag)
10342 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
10344 appendwithlinks $text {}
10346 $ctext conf -state disabled
10358 if {[info exists gitktmpdir]} {
10359 catch {file delete -force $gitktmpdir}
10363 proc mkfontdisp {font top which} {
10364 global fontattr fontpref $font NS use_ttk
10366 set fontpref($font) [set $font]
10367 ${NS}::button $top.${font}but -text $which \
10368 -command [list choosefont $font $which]
10369 if {!$use_ttk} {$top.${font}but configure -font optionfont}
10370 ${NS}::label $top.$font -relief flat -font $font \
10371 -text $fontattr($font,family) -justify left
10372 grid x $top.${font}but $top.$font -sticky w
10375 proc choosefont {font which} {
10376 global fontparam fontlist fonttop fontattr
10379 set fontparam(which) $which
10380 set fontparam(font) $font
10381 set fontparam(family) [font actual $font -family]
10382 set fontparam(size) $fontattr($font,size)
10383 set fontparam(weight) $fontattr($font,weight)
10384 set fontparam(slant) $fontattr($font,slant)
10387 if {![winfo exists $top]} {
10389 eval font config sample [font actual $font]
10391 make_transient $top $prefstop
10392 wm title $top [mc "Gitk font chooser"]
10393 ${NS}::label $top.l -textvariable fontparam(which)
10394 pack $top.l -side top
10395 set fontlist [lsort [font families]]
10396 ${NS}::frame $top.f
10397 listbox $top.f.fam -listvariable fontlist \
10398 -yscrollcommand [list $top.f.sb set]
10399 bind $top.f.fam <<ListboxSelect>> selfontfam
10400 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
10401 pack $top.f.sb -side right -fill y
10402 pack $top.f.fam -side left -fill both -expand 1
10403 pack $top.f -side top -fill both -expand 1
10404 ${NS}::frame $top.g
10405 spinbox $top.g.size -from 4 -to 40 -width 4 \
10406 -textvariable fontparam(size) \
10407 -validatecommand {string is integer -strict %s}
10408 checkbutton $top.g.bold -padx 5 \
10409 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
10410 -variable fontparam(weight) -onvalue bold -offvalue normal
10411 checkbutton $top.g.ital -padx 5 \
10412 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
10413 -variable fontparam(slant) -onvalue italic -offvalue roman
10414 pack $top.g.size $top.g.bold $top.g.ital -side left
10415 pack $top.g -side top
10416 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
10418 $top.c create text 100 25 -anchor center -text $which -font sample \
10419 -fill black -tags text
10420 bind $top.c <Configure> [list centertext $top.c]
10421 pack $top.c -side top -fill x
10422 ${NS}::frame $top.buts
10423 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
10424 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
10425 bind $top <Key-Return> fontok
10426 bind $top <Key-Escape> fontcan
10427 grid $top.buts.ok $top.buts.can
10428 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10429 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10430 pack $top.buts -side bottom -fill x
10431 trace add variable fontparam write chg_fontparam
10434 $top.c itemconf text -text $which
10436 set i [lsearch -exact $fontlist $fontparam(family)]
10438 $top.f.fam selection set $i
10443 proc centertext {w} {
10444 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
10448 global fontparam fontpref prefstop
10450 set f $fontparam(font)
10451 set fontpref($f) [list $fontparam(family) $fontparam(size)]
10452 if {$fontparam(weight) eq "bold"} {
10453 lappend fontpref($f) "bold"
10455 if {$fontparam(slant) eq "italic"} {
10456 lappend fontpref($f) "italic"
10459 $w conf -text $fontparam(family) -font $fontpref($f)
10465 global fonttop fontparam
10467 if {[info exists fonttop]} {
10468 catch {destroy $fonttop}
10469 catch {font delete sample}
10475 if {[package vsatisfies [package provide Tk] 8.6]} {
10476 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
10477 # function to make use of it.
10478 proc choosefont {font which} {
10479 tk fontchooser configure -title $which -font $font \
10480 -command [list on_choosefont $font $which]
10481 tk fontchooser show
10483 proc on_choosefont {font which newfont} {
10485 puts stderr "$font $newfont"
10486 array set f [font actual $newfont]
10487 set fontparam(which) $which
10488 set fontparam(font) $font
10489 set fontparam(family) $f(-family)
10490 set fontparam(size) $f(-size)
10491 set fontparam(weight) $f(-weight)
10492 set fontparam(slant) $f(-slant)
10497 proc selfontfam {} {
10498 global fonttop fontparam
10500 set i [$fonttop.f.fam curselection]
10502 set fontparam(family) [$fonttop.f.fam get $i]
10506 proc chg_fontparam {v sub op} {
10509 font config sample -$sub $fontparam($sub)
10513 global maxwidth maxgraphpct use_ttk NS
10514 global oldprefs prefstop showneartags showlocalchanges
10515 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
10516 global tabstop limitdiffs autoselect extdifftool perfile_attrs
10520 if {[winfo exists $top]} {
10524 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10525 limitdiffs tabstop perfile_attrs} {
10526 set oldprefs($v) [set $v]
10529 wm title $top [mc "Gitk preferences"]
10530 make_transient $top .
10531 ${NS}::label $top.ldisp -text [mc "Commit list display options"]
10532 grid $top.ldisp - -sticky w -pady 10
10533 ${NS}::label $top.spacer -text " "
10534 ${NS}::label $top.maxwidthl -text [mc "Maximum graph width (lines)"]
10535 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
10536 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
10537 ${NS}::label $top.maxpctl -text [mc "Maximum graph width (% of pane)"]
10538 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
10539 grid x $top.maxpctl $top.maxpct -sticky w
10540 ${NS}::checkbutton $top.showlocal -text [mc "Show local changes"] \
10541 -variable showlocalchanges
10542 grid x $top.showlocal -sticky w
10543 ${NS}::checkbutton $top.autoselect -text [mc "Auto-select SHA1"] \
10544 -variable autoselect
10545 grid x $top.autoselect -sticky w
10547 ${NS}::label $top.ddisp -text [mc "Diff display options"]
10548 grid $top.ddisp - -sticky w -pady 10
10549 ${NS}::label $top.tabstopl -text [mc "Tab spacing"]
10550 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
10551 grid x $top.tabstopl $top.tabstop -sticky w
10552 ${NS}::checkbutton $top.ntag -text [mc "Display nearby tags"] \
10553 -variable showneartags
10554 grid x $top.ntag -sticky w
10555 ${NS}::checkbutton $top.ldiff -text [mc "Limit diffs to listed paths"] \
10556 -variable limitdiffs
10557 grid x $top.ldiff -sticky w
10558 ${NS}::checkbutton $top.lattr -text [mc "Support per-file encodings"] \
10559 -variable perfile_attrs
10560 grid x $top.lattr -sticky w
10562 ${NS}::entry $top.extdifft -textvariable extdifftool
10563 ${NS}::frame $top.extdifff
10564 ${NS}::label $top.extdifff.l -text [mc "External diff tool" ]
10565 ${NS}::button $top.extdifff.b -text [mc "Choose..."] -command choose_extdiff
10566 pack $top.extdifff.l $top.extdifff.b -side left
10567 pack configure $top.extdifff.l -padx 10
10568 grid x $top.extdifff $top.extdifft -sticky ew
10570 ${NS}::label $top.cdisp -text [mc "Colors: press to choose"]
10571 grid $top.cdisp - -sticky w -pady 10
10572 label $top.bg -padx 40 -relief sunk -background $bgcolor
10573 ${NS}::button $top.bgbut -text [mc "Background"] \
10574 -command [list choosecolor bgcolor {} $top.bg [mc "background"] setbg]
10575 grid x $top.bgbut $top.bg -sticky w
10576 label $top.fg -padx 40 -relief sunk -background $fgcolor
10577 ${NS}::button $top.fgbut -text [mc "Foreground"] \
10578 -command [list choosecolor fgcolor {} $top.fg [mc "foreground"] setfg]
10579 grid x $top.fgbut $top.fg -sticky w
10580 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
10581 ${NS}::button $top.diffoldbut -text [mc "Diff: old lines"] \
10582 -command [list choosecolor diffcolors 0 $top.diffold [mc "diff old lines"] \
10583 [list $ctext tag conf d0 -foreground]]
10584 grid x $top.diffoldbut $top.diffold -sticky w
10585 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
10586 ${NS}::button $top.diffnewbut -text [mc "Diff: new lines"] \
10587 -command [list choosecolor diffcolors 1 $top.diffnew [mc "diff new lines"] \
10588 [list $ctext tag conf dresult -foreground]]
10589 grid x $top.diffnewbut $top.diffnew -sticky w
10590 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
10591 ${NS}::button $top.hunksepbut -text [mc "Diff: hunk header"] \
10592 -command [list choosecolor diffcolors 2 $top.hunksep \
10593 [mc "diff hunk header"] \
10594 [list $ctext tag conf hunksep -foreground]]
10595 grid x $top.hunksepbut $top.hunksep -sticky w
10596 label $top.markbgsep -padx 40 -relief sunk -background $markbgcolor
10597 ${NS}::button $top.markbgbut -text [mc "Marked line bg"] \
10598 -command [list choosecolor markbgcolor {} $top.markbgsep \
10599 [mc "marked line background"] \
10600 [list $ctext tag conf omark -background]]
10601 grid x $top.markbgbut $top.markbgsep -sticky w
10602 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
10603 ${NS}::button $top.selbgbut -text [mc "Select bg"] \
10604 -command [list choosecolor selectbgcolor {} $top.selbgsep [mc "background"] setselbg]
10605 grid x $top.selbgbut $top.selbgsep -sticky w
10607 ${NS}::label $top.cfont -text [mc "Fonts: press to choose"]
10608 grid $top.cfont - -sticky w -pady 10
10609 mkfontdisp mainfont $top [mc "Main font"]
10610 mkfontdisp textfont $top [mc "Diff display font"]
10611 mkfontdisp uifont $top [mc "User interface font"]
10614 foreach w {maxpctl maxwidthl showlocal autoselect tabstopl ntag
10615 ldiff lattr extdifff.l extdifff.b bgbut fgbut
10616 diffoldbut diffnewbut hunksepbut markbgbut selbgbut} {
10617 $top.$w configure -font optionfont
10621 ${NS}::frame $top.buts
10622 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
10623 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
10624 bind $top <Key-Return> prefsok
10625 bind $top <Key-Escape> prefscan
10626 grid $top.buts.ok $top.buts.can
10627 grid columnconfigure $top.buts 0 -weight 1 -uniform a
10628 grid columnconfigure $top.buts 1 -weight 1 -uniform a
10629 grid $top.buts - - -pady 10 -sticky ew
10630 grid columnconfigure $top 2 -weight 1
10631 bind $top <Visibility> "focus $top.buts.ok"
10634 proc choose_extdiff {} {
10637 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
10639 set extdifftool $prog
10643 proc choosecolor {v vi w x cmd} {
10646 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
10647 -title [mc "Gitk: choose color for %s" $x]]
10648 if {$c eq {}} return
10649 $w conf -background $c
10654 proc setselbg {c} {
10655 global bglist cflist
10656 foreach w $bglist {
10657 $w configure -selectbackground $c
10659 $cflist tag configure highlight \
10660 -background [$cflist cget -selectbackground]
10661 allcanvs itemconf secsel -fill $c
10667 foreach w $bglist {
10668 $w conf -background $c
10675 foreach w $fglist {
10676 $w conf -foreground $c
10678 allcanvs itemconf text -fill $c
10679 $canv itemconf circle -outline $c
10680 $canv itemconf markid -outline $c
10684 global oldprefs prefstop
10686 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
10687 limitdiffs tabstop perfile_attrs} {
10689 set $v $oldprefs($v)
10691 catch {destroy $prefstop}
10697 global maxwidth maxgraphpct
10698 global oldprefs prefstop showneartags showlocalchanges
10699 global fontpref mainfont textfont uifont
10700 global limitdiffs treediffs perfile_attrs
10702 catch {destroy $prefstop}
10706 if {$mainfont ne $fontpref(mainfont)} {
10707 set mainfont $fontpref(mainfont)
10708 parsefont mainfont $mainfont
10709 eval font configure mainfont [fontflags mainfont]
10710 eval font configure mainfontbold [fontflags mainfont 1]
10714 if {$textfont ne $fontpref(textfont)} {
10715 set textfont $fontpref(textfont)
10716 parsefont textfont $textfont
10717 eval font configure textfont [fontflags textfont]
10718 eval font configure textfontbold [fontflags textfont 1]
10720 if {$uifont ne $fontpref(uifont)} {
10721 set uifont $fontpref(uifont)
10722 parsefont uifont $uifont
10723 eval font configure uifont [fontflags uifont]
10726 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
10727 if {$showlocalchanges} {
10733 if {$limitdiffs != $oldprefs(limitdiffs) ||
10734 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
10735 # treediffs elements are limited by path;
10736 # won't have encodings cached if perfile_attrs was just turned on
10737 catch {unset treediffs}
10739 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
10740 || $maxgraphpct != $oldprefs(maxgraphpct)} {
10742 } elseif {$showneartags != $oldprefs(showneartags) ||
10743 $limitdiffs != $oldprefs(limitdiffs)} {
10748 proc formatdate {d} {
10749 global datetimeformat
10751 set d [clock format $d -format $datetimeformat]
10756 # This list of encoding names and aliases is distilled from
10757 # http://www.iana.org/assignments/character-sets.
10758 # Not all of them are supported by Tcl.
10759 set encoding_aliases {
10760 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
10761 ISO646-US US-ASCII us IBM367 cp367 csASCII }
10762 { ISO-10646-UTF-1 csISO10646UTF1 }
10763 { ISO_646.basic:1983 ref csISO646basic1983 }
10764 { INVARIANT csINVARIANT }
10765 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
10766 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
10767 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
10768 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
10769 { NATS-DANO iso-ir-9-1 csNATSDANO }
10770 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
10771 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
10772 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
10773 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
10774 { ISO-2022-KR csISO2022KR }
10776 { ISO-2022-JP csISO2022JP }
10777 { ISO-2022-JP-2 csISO2022JP2 }
10778 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
10779 csISO13JISC6220jp }
10780 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
10781 { IT iso-ir-15 ISO646-IT csISO15Italian }
10782 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
10783 { ES iso-ir-17 ISO646-ES csISO17Spanish }
10784 { greek7-old iso-ir-18 csISO18Greek7Old }
10785 { latin-greek iso-ir-19 csISO19LatinGreek }
10786 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
10787 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
10788 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
10789 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
10790 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
10791 { BS_viewdata iso-ir-47 csISO47BSViewdata }
10792 { INIS iso-ir-49 csISO49INIS }
10793 { INIS-8 iso-ir-50 csISO50INIS8 }
10794 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
10795 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
10796 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
10797 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
10798 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
10799 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
10800 csISO60Norwegian1 }
10801 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
10802 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
10803 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
10804 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
10805 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
10806 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
10807 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
10808 { greek7 iso-ir-88 csISO88Greek7 }
10809 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
10810 { iso-ir-90 csISO90 }
10811 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
10812 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
10813 csISO92JISC62991984b }
10814 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
10815 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
10816 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
10817 csISO95JIS62291984handadd }
10818 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
10819 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
10820 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
10821 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
10822 CP819 csISOLatin1 }
10823 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
10824 { T.61-7bit iso-ir-102 csISO102T617bit }
10825 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
10826 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
10827 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
10828 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
10829 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
10830 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
10831 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
10832 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
10833 arabic csISOLatinArabic }
10834 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
10835 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
10836 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
10837 greek greek8 csISOLatinGreek }
10838 { T.101-G2 iso-ir-128 csISO128T101G2 }
10839 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
10841 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
10842 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
10843 { CSN_369103 iso-ir-139 csISO139CSN369103 }
10844 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
10845 { ISO_6937-2-add iso-ir-142 csISOTextComm }
10846 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
10847 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
10848 csISOLatinCyrillic }
10849 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
10850 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
10851 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
10852 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
10853 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
10854 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
10855 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
10856 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
10857 { ISO_10367-box iso-ir-155 csISO10367Box }
10858 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
10859 { latin-lap lap iso-ir-158 csISO158Lap }
10860 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
10861 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
10864 { JIS_X0201 X0201 csHalfWidthKatakana }
10865 { KSC5636 ISO646-KR csKSC5636 }
10866 { ISO-10646-UCS-2 csUnicode }
10867 { ISO-10646-UCS-4 csUCS4 }
10868 { DEC-MCS dec csDECMCS }
10869 { hp-roman8 roman8 r8 csHPRoman8 }
10870 { macintosh mac csMacintosh }
10871 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
10873 { IBM038 EBCDIC-INT cp038 csIBM038 }
10874 { IBM273 CP273 csIBM273 }
10875 { IBM274 EBCDIC-BE CP274 csIBM274 }
10876 { IBM275 EBCDIC-BR cp275 csIBM275 }
10877 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
10878 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
10879 { IBM280 CP280 ebcdic-cp-it csIBM280 }
10880 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
10881 { IBM284 CP284 ebcdic-cp-es csIBM284 }
10882 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
10883 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
10884 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
10885 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
10886 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
10887 { IBM424 cp424 ebcdic-cp-he csIBM424 }
10888 { IBM437 cp437 437 csPC8CodePage437 }
10889 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
10890 { IBM775 cp775 csPC775Baltic }
10891 { IBM850 cp850 850 csPC850Multilingual }
10892 { IBM851 cp851 851 csIBM851 }
10893 { IBM852 cp852 852 csPCp852 }
10894 { IBM855 cp855 855 csIBM855 }
10895 { IBM857 cp857 857 csIBM857 }
10896 { IBM860 cp860 860 csIBM860 }
10897 { IBM861 cp861 861 cp-is csIBM861 }
10898 { IBM862 cp862 862 csPC862LatinHebrew }
10899 { IBM863 cp863 863 csIBM863 }
10900 { IBM864 cp864 csIBM864 }
10901 { IBM865 cp865 865 csIBM865 }
10902 { IBM866 cp866 866 csIBM866 }
10903 { IBM868 CP868 cp-ar csIBM868 }
10904 { IBM869 cp869 869 cp-gr csIBM869 }
10905 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
10906 { IBM871 CP871 ebcdic-cp-is csIBM871 }
10907 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
10908 { IBM891 cp891 csIBM891 }
10909 { IBM903 cp903 csIBM903 }
10910 { IBM904 cp904 904 csIBBM904 }
10911 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
10912 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
10913 { IBM1026 CP1026 csIBM1026 }
10914 { EBCDIC-AT-DE csIBMEBCDICATDE }
10915 { EBCDIC-AT-DE-A csEBCDICATDEA }
10916 { EBCDIC-CA-FR csEBCDICCAFR }
10917 { EBCDIC-DK-NO csEBCDICDKNO }
10918 { EBCDIC-DK-NO-A csEBCDICDKNOA }
10919 { EBCDIC-FI-SE csEBCDICFISE }
10920 { EBCDIC-FI-SE-A csEBCDICFISEA }
10921 { EBCDIC-FR csEBCDICFR }
10922 { EBCDIC-IT csEBCDICIT }
10923 { EBCDIC-PT csEBCDICPT }
10924 { EBCDIC-ES csEBCDICES }
10925 { EBCDIC-ES-A csEBCDICESA }
10926 { EBCDIC-ES-S csEBCDICESS }
10927 { EBCDIC-UK csEBCDICUK }
10928 { EBCDIC-US csEBCDICUS }
10929 { UNKNOWN-8BIT csUnknown8BiT }
10930 { MNEMONIC csMnemonic }
10932 { VISCII csVISCII }
10935 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
10936 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
10937 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
10938 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
10939 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
10940 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
10941 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
10942 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
10943 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
10944 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
10945 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
10946 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
10947 { IBM1047 IBM-1047 }
10948 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
10949 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
10950 { UNICODE-1-1 csUnicode11 }
10951 { CESU-8 csCESU-8 }
10952 { BOCU-1 csBOCU-1 }
10953 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
10954 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
10956 { ISO-8859-15 ISO_8859-15 Latin-9 }
10957 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
10958 { GBK CP936 MS936 windows-936 }
10959 { JIS_Encoding csJISEncoding }
10960 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
10961 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
10963 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
10964 { ISO-10646-UCS-Basic csUnicodeASCII }
10965 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
10966 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
10967 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
10968 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
10969 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
10970 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
10971 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
10972 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
10973 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
10974 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
10975 { Adobe-Standard-Encoding csAdobeStandardEncoding }
10976 { Ventura-US csVenturaUS }
10977 { Ventura-International csVenturaInternational }
10978 { PC8-Danish-Norwegian csPC8DanishNorwegian }
10979 { PC8-Turkish csPC8Turkish }
10980 { IBM-Symbols csIBMSymbols }
10981 { IBM-Thai csIBMThai }
10982 { HP-Legal csHPLegal }
10983 { HP-Pi-font csHPPiFont }
10984 { HP-Math8 csHPMath8 }
10985 { Adobe-Symbol-Encoding csHPPSMath }
10986 { HP-DeskTop csHPDesktop }
10987 { Ventura-Math csVenturaMath }
10988 { Microsoft-Publishing csMicrosoftPublishing }
10989 { Windows-31J csWindows31J }
10990 { GB2312 csGB2312 }
10994 proc tcl_encoding {enc} {
10995 global encoding_aliases tcl_encoding_cache
10996 if {[info exists tcl_encoding_cache($enc)]} {
10997 return $tcl_encoding_cache($enc)
10999 set names [encoding names]
11000 set lcnames [string tolower $names]
11001 set enc [string tolower $enc]
11002 set i [lsearch -exact $lcnames $enc]
11004 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11005 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11006 set i [lsearch -exact $lcnames $encx]
11010 foreach l $encoding_aliases {
11011 set ll [string tolower $l]
11012 if {[lsearch -exact $ll $enc] < 0} continue
11013 # look through the aliases for one that tcl knows about
11015 set i [lsearch -exact $lcnames $e]
11017 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11018 set i [lsearch -exact $lcnames $ex]
11028 set tclenc [lindex $names $i]
11030 set tcl_encoding_cache($enc) $tclenc
11034 proc gitattr {path attr default} {
11035 global path_attr_cache
11036 if {[info exists path_attr_cache($attr,$path)]} {
11037 set r $path_attr_cache($attr,$path)
11039 set r "unspecified"
11040 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11041 regexp "(.*): encoding: (.*)" $line m f r
11043 set path_attr_cache($attr,$path) $r
11045 if {$r eq "unspecified"} {
11051 proc cache_gitattr {attr pathlist} {
11052 global path_attr_cache
11054 foreach path $pathlist {
11055 if {![info exists path_attr_cache($attr,$path)]} {
11056 lappend newlist $path
11060 if {[tk windowingsystem] == "win32"} {
11061 # windows has a 32k limit on the arguments to a command...
11064 while {$newlist ne {}} {
11065 set head [lrange $newlist 0 [expr {$lim - 1}]]
11066 set newlist [lrange $newlist $lim end]
11067 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11068 foreach row [split $rlist "\n"] {
11069 if {[regexp "(.*): encoding: (.*)" $row m path value]} {
11070 if {[string index $path 0] eq "\""} {
11071 set path [encoding convertfrom [lindex $path 0]]
11073 set path_attr_cache($attr,$path) $value
11080 proc get_path_encoding {path} {
11081 global gui_encoding perfile_attrs
11082 set tcl_enc $gui_encoding
11083 if {$path ne {} && $perfile_attrs} {
11084 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11092 # First check that Tcl/Tk is recent enough
11093 if {[catch {package require Tk 8.4} err]} {
11094 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11095 Gitk requires at least Tcl/Tk 8.4."]
11100 set wrcomcmd "git diff-tree --stdin -p --pretty"
11104 set gitencoding [exec git config --get i18n.commitencoding]
11107 set gitencoding [exec git config --get i18n.logoutputencoding]
11109 if {$gitencoding == ""} {
11110 set gitencoding "utf-8"
11112 set tclencoding [tcl_encoding $gitencoding]
11113 if {$tclencoding == {}} {
11114 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11117 set gui_encoding [encoding system]
11119 set enc [exec git config --get gui.encoding]
11121 set tclenc [tcl_encoding $enc]
11122 if {$tclenc ne {}} {
11123 set gui_encoding $tclenc
11125 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11130 if {[tk windowingsystem] eq "aqua"} {
11131 set mainfont {{Lucida Grande} 9}
11132 set textfont {Monaco 9}
11133 set uifont {{Lucida Grande} 9 bold}
11135 set mainfont {Helvetica 9}
11136 set textfont {Courier 9}
11137 set uifont {Helvetica 9 bold}
11140 set findmergefiles 0
11148 set cmitmode "patch"
11149 set wrapcomment "none"
11153 set showlocalchanges 1
11155 set datetimeformat "%Y-%m-%d %H:%M:%S"
11157 set perfile_attrs 0
11159 if {[tk windowingsystem] eq "aqua"} {
11160 set extdifftool "opendiff"
11162 set extdifftool "meld"
11165 set colors {green red blue magenta darkgrey brown orange}
11168 set diffcolors {red "#00a000" blue}
11171 set selectbgcolor gray85
11172 set markbgcolor "#e0e0ff"
11174 set circlecolors {white blue gray blue blue}
11176 # button for popping up context menus
11177 if {[tk windowingsystem] eq "aqua"} {
11178 set ctxbut <Button-2>
11180 set ctxbut <Button-3>
11183 ## For msgcat loading, first locate the installation location.
11184 if { [info exists ::env(GITK_MSGSDIR)] } {
11185 ## Msgsdir was manually set in the environment.
11186 set gitk_msgsdir $::env(GITK_MSGSDIR)
11188 ## Let's guess the prefix from argv0.
11189 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
11190 set gitk_libdir [file join $gitk_prefix share gitk lib]
11191 set gitk_msgsdir [file join $gitk_libdir msgs]
11195 ## Internationalization (i18n) through msgcat and gettext. See
11196 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
11197 package require msgcat
11198 namespace import ::msgcat::mc
11199 ## And eventually load the actual message catalog
11200 ::msgcat::mcload $gitk_msgsdir
11202 catch {source ~/.gitk}
11204 font create optionfont -family sans-serif -size -12
11206 parsefont mainfont $mainfont
11207 eval font create mainfont [fontflags mainfont]
11208 eval font create mainfontbold [fontflags mainfont 1]
11210 parsefont textfont $textfont
11211 eval font create textfont [fontflags textfont]
11212 eval font create textfontbold [fontflags textfont 1]
11214 parsefont uifont $uifont
11215 eval font create uifont [fontflags uifont]
11219 # check that we can find a .git directory somewhere...
11220 if {[catch {set gitdir [gitdir]}]} {
11221 show_error {} . [mc "Cannot find a git repository here."]
11224 if {![file isdirectory $gitdir]} {
11225 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
11230 set selectheadid {}
11233 set cmdline_files {}
11235 set revtreeargscmd {}
11236 foreach arg $argv {
11237 switch -glob -- $arg {
11240 set cmdline_files [lrange $argv [expr {$i + 1}] end]
11243 "--select-commit=*" {
11244 set selecthead [string range $arg 16 end]
11247 set revtreeargscmd [string range $arg 10 end]
11250 lappend revtreeargs $arg
11256 if {$selecthead eq "HEAD"} {
11260 if {$i >= [llength $argv] && $revtreeargs ne {}} {
11261 # no -- on command line, but some arguments (other than --argscmd)
11263 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
11264 set cmdline_files [split $f "\n"]
11265 set n [llength $cmdline_files]
11266 set revtreeargs [lrange $revtreeargs 0 end-$n]
11267 # Unfortunately git rev-parse doesn't produce an error when
11268 # something is both a revision and a filename. To be consistent
11269 # with git log and git rev-list, check revtreeargs for filenames.
11270 foreach arg $revtreeargs {
11271 if {[file exists $arg]} {
11272 show_error {} . [mc "Ambiguous argument '%s': both revision\
11273 and filename" $arg]
11278 # unfortunately we get both stdout and stderr in $err,
11279 # so look for "fatal:".
11280 set i [string first "fatal:" $err]
11282 set err [string range $err [expr {$i + 6}] end]
11284 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
11289 set nullid "0000000000000000000000000000000000000000"
11290 set nullid2 "0000000000000000000000000000000000000001"
11291 set nullfile "/dev/null"
11293 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
11294 if {![info exists use_ttk]} {
11295 set use_ttk [llength [info commands ::ttk::style]]
11297 set NS [expr {$use_ttk ? "ttk" : ""}]
11304 set highlight_paths {}
11306 set searchdirn -forwards
11309 set diffelide {0 0}
11310 set markingmatches 0
11311 set linkentercount 0
11312 set need_redisplay 0
11319 set selectedhlview [mc "None"]
11320 set highlight_related [mc "None"]
11321 set highlight_files {}
11322 set viewfiles(0) {}
11325 set viewargscmd(0) {}
11327 set selectedline {}
11335 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
11339 image create photo gitlogo -width 16 -height 16
11341 image create photo gitlogominus -width 4 -height 2
11342 gitlogominus put #C00000 -to 0 0 4 2
11343 gitlogo copy gitlogominus -to 1 5
11344 gitlogo copy gitlogominus -to 6 5
11345 gitlogo copy gitlogominus -to 11 5
11346 image delete gitlogominus
11348 image create photo gitlogoplus -width 4 -height 4
11349 gitlogoplus put #008000 -to 1 0 3 4
11350 gitlogoplus put #008000 -to 0 1 4 3
11351 gitlogo copy gitlogoplus -to 1 9
11352 gitlogo copy gitlogoplus -to 6 9
11353 gitlogo copy gitlogoplus -to 11 9
11354 image delete gitlogoplus
11356 image create photo gitlogo32 -width 32 -height 32
11357 gitlogo32 copy gitlogo -zoom 2 2
11359 wm iconphoto . -default gitlogo gitlogo32
11361 # wait for the window to become visible
11362 tkwait visibility .
11363 wm title . "[file tail $argv0]: [file tail [pwd]]"
11367 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
11368 # create a view for the files/dirs specified on the command line
11372 set viewname(1) [mc "Command line"]
11373 set viewfiles(1) $cmdline_files
11374 set viewargs(1) $revtreeargs
11375 set viewargscmd(1) $revtreeargscmd
11379 .bar.view entryconf [mca "Edit view..."] -state normal
11380 .bar.view entryconf [mca "Delete view"] -state normal
11383 if {[info exists permviews]} {
11384 foreach v $permviews {
11387 set viewname($n) [lindex $v 0]
11388 set viewfiles($n) [lindex $v 1]
11389 set viewargs($n) [lindex $v 2]
11390 set viewargscmd($n) [lindex $v 3]
11396 if {[tk windowingsystem] eq "win32"} {