Sync with 2.39.4
[git.git] / gitk-git / gitk
blob0ae7d685904b85f97a69b243e30f010671d050e3
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright © 2005-2016 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 package require Tk
12 proc hasworktree {} {
13 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
14 [exec git rev-parse --is-inside-git-dir] == "false"}]
17 proc reponame {} {
18 global gitdir
19 set n [file normalize $gitdir]
20 if {[string match "*/.git" $n]} {
21 set n [string range $n 0 end-5]
23 return [file tail $n]
26 proc gitworktree {} {
27 variable _gitworktree
28 if {[info exists _gitworktree]} {
29 return $_gitworktree
31 # v1.7.0 introduced --show-toplevel to return the canonical work-tree
32 if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
33 # try to set work tree from environment, core.worktree or use
34 # cdup to obtain a relative path to the top of the worktree. If
35 # run from the top, the ./ prefix ensures normalize expands pwd.
36 if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
37 if {[catch {set _gitworktree [exec git config --get core.worktree]}]} {
38 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
42 return $_gitworktree
45 # A simple scheduler for compute-intensive stuff.
46 # The aim is to make sure that event handlers for GUI actions can
47 # run at least every 50-100 ms. Unfortunately fileevent handlers are
48 # run before X event handlers, so reading from a fast source can
49 # make the GUI completely unresponsive.
50 proc run args {
51 global isonrunq runq currunq
53 set script $args
54 if {[info exists isonrunq($script)]} return
55 if {$runq eq {} && ![info exists currunq]} {
56 after idle dorunq
58 lappend runq [list {} $script]
59 set isonrunq($script) 1
62 proc filerun {fd script} {
63 fileevent $fd readable [list filereadable $fd $script]
66 proc filereadable {fd script} {
67 global runq currunq
69 fileevent $fd readable {}
70 if {$runq eq {} && ![info exists currunq]} {
71 after idle dorunq
73 lappend runq [list $fd $script]
76 proc nukefile {fd} {
77 global runq
79 for {set i 0} {$i < [llength $runq]} {} {
80 if {[lindex $runq $i 0] eq $fd} {
81 set runq [lreplace $runq $i $i]
82 } else {
83 incr i
88 proc dorunq {} {
89 global isonrunq runq currunq
91 set tstart [clock clicks -milliseconds]
92 set t0 $tstart
93 while {[llength $runq] > 0} {
94 set fd [lindex $runq 0 0]
95 set script [lindex $runq 0 1]
96 set currunq [lindex $runq 0]
97 set runq [lrange $runq 1 end]
98 set repeat [eval $script]
99 unset currunq
100 set t1 [clock clicks -milliseconds]
101 set t [expr {$t1 - $t0}]
102 if {$repeat ne {} && $repeat} {
103 if {$fd eq {} || $repeat == 2} {
104 # script returns 1 if it wants to be readded
105 # file readers return 2 if they could do more straight away
106 lappend runq [list $fd $script]
107 } else {
108 fileevent $fd readable [list filereadable $fd $script]
110 } elseif {$fd eq {}} {
111 unset isonrunq($script)
113 set t0 $t1
114 if {$t1 - $tstart >= 80} break
116 if {$runq ne {}} {
117 after idle dorunq
121 proc reg_instance {fd} {
122 global commfd leftover loginstance
124 set i [incr loginstance]
125 set commfd($i) $fd
126 set leftover($i) {}
127 return $i
130 proc unmerged_files {files} {
131 global nr_unmerged
133 # find the list of unmerged files
134 set mlist {}
135 set nr_unmerged 0
136 if {[catch {
137 set fd [open "| git ls-files -u" r]
138 } err]} {
139 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
140 exit 1
142 while {[gets $fd line] >= 0} {
143 set i [string first "\t" $line]
144 if {$i < 0} continue
145 set fname [string range $line [expr {$i+1}] end]
146 if {[lsearch -exact $mlist $fname] >= 0} continue
147 incr nr_unmerged
148 if {$files eq {} || [path_filter $files $fname]} {
149 lappend mlist $fname
152 catch {close $fd}
153 return $mlist
156 proc parseviewargs {n arglist} {
157 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
158 global vinlinediff
159 global worddiff git_version
161 set vdatemode($n) 0
162 set vmergeonly($n) 0
163 set vinlinediff($n) 0
164 set glflags {}
165 set diffargs {}
166 set nextisval 0
167 set revargs {}
168 set origargs $arglist
169 set allknown 1
170 set filtered 0
171 set i -1
172 foreach arg $arglist {
173 incr i
174 if {$nextisval} {
175 lappend glflags $arg
176 set nextisval 0
177 continue
179 switch -glob -- $arg {
180 "-d" -
181 "--date-order" {
182 set vdatemode($n) 1
183 # remove from origargs in case we hit an unknown option
184 set origargs [lreplace $origargs $i $i]
185 incr i -1
187 "-[puabwcrRBMC]" -
188 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
189 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
190 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
191 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
192 "--ignore-space-change" - "-U*" - "--unified=*" {
193 # These request or affect diff output, which we don't want.
194 # Some could be used to set our defaults for diff display.
195 lappend diffargs $arg
197 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
198 "--name-only" - "--name-status" - "--color" -
199 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
200 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
201 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
202 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
203 "--objects" - "--objects-edge" - "--reverse" {
204 # These cause our parsing of git log's output to fail, or else
205 # they're options we want to set ourselves, so ignore them.
207 "--color-words*" - "--word-diff=color" {
208 # These trigger a word diff in the console interface,
209 # so help the user by enabling our own support
210 if {[package vcompare $git_version "1.7.2"] >= 0} {
211 set worddiff [mc "Color words"]
214 "--word-diff*" {
215 if {[package vcompare $git_version "1.7.2"] >= 0} {
216 set worddiff [mc "Markup words"]
219 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
220 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
221 "--full-history" - "--dense" - "--sparse" -
222 "--follow" - "--left-right" - "--encoding=*" {
223 # These are harmless, and some are even useful
224 lappend glflags $arg
226 "--diff-filter=*" - "--no-merges" - "--unpacked" -
227 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
228 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
229 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
230 "--remove-empty" - "--first-parent" - "--cherry-pick" -
231 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
232 "--simplify-by-decoration" {
233 # These mean that we get a subset of the commits
234 set filtered 1
235 lappend glflags $arg
237 "-L*" {
238 # Line-log with 'stuck' argument (unstuck form is
239 # not supported)
240 set filtered 1
241 set vinlinediff($n) 1
242 set allknown 0
243 lappend glflags $arg
245 "-n" {
246 # This appears to be the only one that has a value as a
247 # separate word following it
248 set filtered 1
249 set nextisval 1
250 lappend glflags $arg
252 "--not" - "--all" {
253 lappend revargs $arg
255 "--merge" {
256 set vmergeonly($n) 1
257 # git rev-parse doesn't understand --merge
258 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
260 "--no-replace-objects" {
261 set env(GIT_NO_REPLACE_OBJECTS) "1"
263 "-*" {
264 # Other flag arguments including -<n>
265 if {[string is digit -strict [string range $arg 1 end]]} {
266 set filtered 1
267 } else {
268 # a flag argument that we don't recognize;
269 # that means we can't optimize
270 set allknown 0
272 lappend glflags $arg
274 default {
275 # Non-flag arguments specify commits or ranges of commits
276 if {[string match "*...*" $arg]} {
277 lappend revargs --gitk-symmetric-diff-marker
279 lappend revargs $arg
283 set vdflags($n) $diffargs
284 set vflags($n) $glflags
285 set vrevs($n) $revargs
286 set vfiltered($n) $filtered
287 set vorigargs($n) $origargs
288 return $allknown
291 proc parseviewrevs {view revs} {
292 global vposids vnegids
294 if {$revs eq {}} {
295 set revs HEAD
296 } elseif {[lsearch -exact $revs --all] >= 0} {
297 lappend revs HEAD
299 if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
300 # we get stdout followed by stderr in $err
301 # for an unknown rev, git rev-parse echoes it and then errors out
302 set errlines [split $err "\n"]
303 set badrev {}
304 for {set l 0} {$l < [llength $errlines]} {incr l} {
305 set line [lindex $errlines $l]
306 if {!([string length $line] == 40 && [string is xdigit $line])} {
307 if {[string match "fatal:*" $line]} {
308 if {[string match "fatal: ambiguous argument*" $line]
309 && $badrev ne {}} {
310 if {[llength $badrev] == 1} {
311 set err "unknown revision $badrev"
312 } else {
313 set err "unknown revisions: [join $badrev ", "]"
315 } else {
316 set err [join [lrange $errlines $l end] "\n"]
318 break
320 lappend badrev $line
323 error_popup "[mc "Error parsing revisions:"] $err"
324 return {}
326 set ret {}
327 set pos {}
328 set neg {}
329 set sdm 0
330 foreach id [split $ids "\n"] {
331 if {$id eq "--gitk-symmetric-diff-marker"} {
332 set sdm 4
333 } elseif {[string match "^*" $id]} {
334 if {$sdm != 1} {
335 lappend ret $id
336 if {$sdm == 3} {
337 set sdm 0
340 lappend neg [string range $id 1 end]
341 } else {
342 if {$sdm != 2} {
343 lappend ret $id
344 } else {
345 lset ret end $id...[lindex $ret end]
347 lappend pos $id
349 incr sdm -1
351 set vposids($view) $pos
352 set vnegids($view) $neg
353 return $ret
356 # Start off a git log process and arrange to read its output
357 proc start_rev_list {view} {
358 global startmsecs commitidx viewcomplete curview
359 global tclencoding
360 global viewargs viewargscmd viewfiles vfilelimit
361 global showlocalchanges
362 global viewactive viewinstances vmergeonly
363 global mainheadid viewmainheadid viewmainheadid_orig
364 global vcanopt vflags vrevs vorigargs
365 global show_notes
367 set startmsecs [clock clicks -milliseconds]
368 set commitidx($view) 0
369 # these are set this way for the error exits
370 set viewcomplete($view) 1
371 set viewactive($view) 0
372 varcinit $view
374 set args $viewargs($view)
375 if {$viewargscmd($view) ne {}} {
376 if {[catch {
377 set str [exec sh -c $viewargscmd($view)]
378 } err]} {
379 error_popup "[mc "Error executing --argscmd command:"] $err"
380 return 0
382 set args [concat $args [split $str "\n"]]
384 set vcanopt($view) [parseviewargs $view $args]
386 set files $viewfiles($view)
387 if {$vmergeonly($view)} {
388 set files [unmerged_files $files]
389 if {$files eq {}} {
390 global nr_unmerged
391 if {$nr_unmerged == 0} {
392 error_popup [mc "No files selected: --merge specified but\
393 no files are unmerged."]
394 } else {
395 error_popup [mc "No files selected: --merge specified but\
396 no unmerged files are within file limit."]
398 return 0
401 set vfilelimit($view) $files
403 if {$vcanopt($view)} {
404 set revs [parseviewrevs $view $vrevs($view)]
405 if {$revs eq {}} {
406 return 0
408 set args [concat $vflags($view) $revs]
409 } else {
410 set args $vorigargs($view)
413 if {[catch {
414 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
415 --parents --boundary $args "--" $files] r]
416 } err]} {
417 error_popup "[mc "Error executing git log:"] $err"
418 return 0
420 set i [reg_instance $fd]
421 set viewinstances($view) [list $i]
422 set viewmainheadid($view) $mainheadid
423 set viewmainheadid_orig($view) $mainheadid
424 if {$files ne {} && $mainheadid ne {}} {
425 get_viewmainhead $view
427 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
428 interestedin $viewmainheadid($view) dodiffindex
430 fconfigure $fd -blocking 0 -translation lf -eofchar {}
431 if {$tclencoding != {}} {
432 fconfigure $fd -encoding $tclencoding
434 filerun $fd [list getcommitlines $fd $i $view 0]
435 nowbusy $view [mc "Reading"]
436 set viewcomplete($view) 0
437 set viewactive($view) 1
438 return 1
441 proc stop_instance {inst} {
442 global commfd leftover
444 set fd $commfd($inst)
445 catch {
446 set pid [pid $fd]
448 if {$::tcl_platform(platform) eq {windows}} {
449 exec taskkill /pid $pid
450 } else {
451 exec kill $pid
454 catch {close $fd}
455 nukefile $fd
456 unset commfd($inst)
457 unset leftover($inst)
460 proc stop_backends {} {
461 global commfd
463 foreach inst [array names commfd] {
464 stop_instance $inst
468 proc stop_rev_list {view} {
469 global viewinstances
471 foreach inst $viewinstances($view) {
472 stop_instance $inst
474 set viewinstances($view) {}
477 proc reset_pending_select {selid} {
478 global pending_select mainheadid selectheadid
480 if {$selid ne {}} {
481 set pending_select $selid
482 } elseif {$selectheadid ne {}} {
483 set pending_select $selectheadid
484 } else {
485 set pending_select $mainheadid
489 proc getcommits {selid} {
490 global canv curview need_redisplay viewactive
492 initlayout
493 if {[start_rev_list $curview]} {
494 reset_pending_select $selid
495 show_status [mc "Reading commits..."]
496 set need_redisplay 1
497 } else {
498 show_status [mc "No commits selected"]
502 proc updatecommits {} {
503 global curview vcanopt vorigargs vfilelimit viewinstances
504 global viewactive viewcomplete tclencoding
505 global startmsecs showneartags showlocalchanges
506 global mainheadid viewmainheadid viewmainheadid_orig pending_select
507 global hasworktree
508 global varcid vposids vnegids vflags vrevs
509 global show_notes
511 set hasworktree [hasworktree]
512 rereadrefs
513 set view $curview
514 if {$mainheadid ne $viewmainheadid_orig($view)} {
515 if {$showlocalchanges} {
516 dohidelocalchanges
518 set viewmainheadid($view) $mainheadid
519 set viewmainheadid_orig($view) $mainheadid
520 if {$vfilelimit($view) ne {}} {
521 get_viewmainhead $view
524 if {$showlocalchanges} {
525 doshowlocalchanges
527 if {$vcanopt($view)} {
528 set oldpos $vposids($view)
529 set oldneg $vnegids($view)
530 set revs [parseviewrevs $view $vrevs($view)]
531 if {$revs eq {}} {
532 return
534 # note: getting the delta when negative refs change is hard,
535 # and could require multiple git log invocations, so in that
536 # case we ask git log for all the commits (not just the delta)
537 if {$oldneg eq $vnegids($view)} {
538 set newrevs {}
539 set npos 0
540 # take out positive refs that we asked for before or
541 # that we have already seen
542 foreach rev $revs {
543 if {[string length $rev] == 40} {
544 if {[lsearch -exact $oldpos $rev] < 0
545 && ![info exists varcid($view,$rev)]} {
546 lappend newrevs $rev
547 incr npos
549 } else {
550 lappend $newrevs $rev
553 if {$npos == 0} return
554 set revs $newrevs
555 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
557 set args [concat $vflags($view) $revs --not $oldpos]
558 } else {
559 set args $vorigargs($view)
561 if {[catch {
562 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
563 --parents --boundary $args "--" $vfilelimit($view)] r]
564 } err]} {
565 error_popup "[mc "Error executing git log:"] $err"
566 return
568 if {$viewactive($view) == 0} {
569 set startmsecs [clock clicks -milliseconds]
571 set i [reg_instance $fd]
572 lappend viewinstances($view) $i
573 fconfigure $fd -blocking 0 -translation lf -eofchar {}
574 if {$tclencoding != {}} {
575 fconfigure $fd -encoding $tclencoding
577 filerun $fd [list getcommitlines $fd $i $view 1]
578 incr viewactive($view)
579 set viewcomplete($view) 0
580 reset_pending_select {}
581 nowbusy $view [mc "Reading"]
582 if {$showneartags} {
583 getallcommits
587 proc reloadcommits {} {
588 global curview viewcomplete selectedline currentid thickerline
589 global showneartags treediffs commitinterest cached_commitrow
590 global targetid commitinfo
592 set selid {}
593 if {$selectedline ne {}} {
594 set selid $currentid
597 if {!$viewcomplete($curview)} {
598 stop_rev_list $curview
600 resetvarcs $curview
601 set selectedline {}
602 unset -nocomplain currentid
603 unset -nocomplain thickerline
604 unset -nocomplain treediffs
605 readrefs
606 changedrefs
607 if {$showneartags} {
608 getallcommits
610 clear_display
611 unset -nocomplain commitinfo
612 unset -nocomplain commitinterest
613 unset -nocomplain cached_commitrow
614 unset -nocomplain targetid
615 setcanvscroll
616 getcommits $selid
617 return 0
620 # This makes a string representation of a positive integer which
621 # sorts as a string in numerical order
622 proc strrep {n} {
623 if {$n < 16} {
624 return [format "%x" $n]
625 } elseif {$n < 256} {
626 return [format "x%.2x" $n]
627 } elseif {$n < 65536} {
628 return [format "y%.4x" $n]
630 return [format "z%.8x" $n]
633 # Procedures used in reordering commits from git log (without
634 # --topo-order) into the order for display.
636 proc varcinit {view} {
637 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
638 global vtokmod varcmod vrowmod varcix vlastins
640 set varcstart($view) {{}}
641 set vupptr($view) {0}
642 set vdownptr($view) {0}
643 set vleftptr($view) {0}
644 set vbackptr($view) {0}
645 set varctok($view) {{}}
646 set varcrow($view) {{}}
647 set vtokmod($view) {}
648 set varcmod($view) 0
649 set vrowmod($view) 0
650 set varcix($view) {{}}
651 set vlastins($view) {0}
654 proc resetvarcs {view} {
655 global varcid varccommits parents children vseedcount ordertok
656 global vshortids
658 foreach vid [array names varcid $view,*] {
659 unset varcid($vid)
660 unset children($vid)
661 unset parents($vid)
663 foreach vid [array names vshortids $view,*] {
664 unset vshortids($vid)
666 # some commits might have children but haven't been seen yet
667 foreach vid [array names children $view,*] {
668 unset children($vid)
670 foreach va [array names varccommits $view,*] {
671 unset varccommits($va)
673 foreach vd [array names vseedcount $view,*] {
674 unset vseedcount($vd)
676 unset -nocomplain ordertok
679 # returns a list of the commits with no children
680 proc seeds {v} {
681 global vdownptr vleftptr varcstart
683 set ret {}
684 set a [lindex $vdownptr($v) 0]
685 while {$a != 0} {
686 lappend ret [lindex $varcstart($v) $a]
687 set a [lindex $vleftptr($v) $a]
689 return $ret
692 proc newvarc {view id} {
693 global varcid varctok parents children vdatemode
694 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
695 global commitdata commitinfo vseedcount varccommits vlastins
697 set a [llength $varctok($view)]
698 set vid $view,$id
699 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
700 if {![info exists commitinfo($id)]} {
701 parsecommit $id $commitdata($id) 1
703 set cdate [lindex [lindex $commitinfo($id) 4] 0]
704 if {![string is integer -strict $cdate]} {
705 set cdate 0
707 if {![info exists vseedcount($view,$cdate)]} {
708 set vseedcount($view,$cdate) -1
710 set c [incr vseedcount($view,$cdate)]
711 set cdate [expr {$cdate ^ 0xffffffff}]
712 set tok "s[strrep $cdate][strrep $c]"
713 } else {
714 set tok {}
716 set ka 0
717 if {[llength $children($vid)] > 0} {
718 set kid [lindex $children($vid) end]
719 set k $varcid($view,$kid)
720 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
721 set ki $kid
722 set ka $k
723 set tok [lindex $varctok($view) $k]
726 if {$ka != 0} {
727 set i [lsearch -exact $parents($view,$ki) $id]
728 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
729 append tok [strrep $j]
731 set c [lindex $vlastins($view) $ka]
732 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
733 set c $ka
734 set b [lindex $vdownptr($view) $ka]
735 } else {
736 set b [lindex $vleftptr($view) $c]
738 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
739 set c $b
740 set b [lindex $vleftptr($view) $c]
742 if {$c == $ka} {
743 lset vdownptr($view) $ka $a
744 lappend vbackptr($view) 0
745 } else {
746 lset vleftptr($view) $c $a
747 lappend vbackptr($view) $c
749 lset vlastins($view) $ka $a
750 lappend vupptr($view) $ka
751 lappend vleftptr($view) $b
752 if {$b != 0} {
753 lset vbackptr($view) $b $a
755 lappend varctok($view) $tok
756 lappend varcstart($view) $id
757 lappend vdownptr($view) 0
758 lappend varcrow($view) {}
759 lappend varcix($view) {}
760 set varccommits($view,$a) {}
761 lappend vlastins($view) 0
762 return $a
765 proc splitvarc {p v} {
766 global varcid varcstart varccommits varctok vtokmod
767 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
769 set oa $varcid($v,$p)
770 set otok [lindex $varctok($v) $oa]
771 set ac $varccommits($v,$oa)
772 set i [lsearch -exact $varccommits($v,$oa) $p]
773 if {$i <= 0} return
774 set na [llength $varctok($v)]
775 # "%" sorts before "0"...
776 set tok "$otok%[strrep $i]"
777 lappend varctok($v) $tok
778 lappend varcrow($v) {}
779 lappend varcix($v) {}
780 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
781 set varccommits($v,$na) [lrange $ac $i end]
782 lappend varcstart($v) $p
783 foreach id $varccommits($v,$na) {
784 set varcid($v,$id) $na
786 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
787 lappend vlastins($v) [lindex $vlastins($v) $oa]
788 lset vdownptr($v) $oa $na
789 lset vlastins($v) $oa 0
790 lappend vupptr($v) $oa
791 lappend vleftptr($v) 0
792 lappend vbackptr($v) 0
793 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
794 lset vupptr($v) $b $na
796 if {[string compare $otok $vtokmod($v)] <= 0} {
797 modify_arc $v $oa
801 proc renumbervarc {a v} {
802 global parents children varctok varcstart varccommits
803 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
805 set t1 [clock clicks -milliseconds]
806 set todo {}
807 set isrelated($a) 1
808 set kidchanged($a) 1
809 set ntot 0
810 while {$a != 0} {
811 if {[info exists isrelated($a)]} {
812 lappend todo $a
813 set id [lindex $varccommits($v,$a) end]
814 foreach p $parents($v,$id) {
815 if {[info exists varcid($v,$p)]} {
816 set isrelated($varcid($v,$p)) 1
820 incr ntot
821 set b [lindex $vdownptr($v) $a]
822 if {$b == 0} {
823 while {$a != 0} {
824 set b [lindex $vleftptr($v) $a]
825 if {$b != 0} break
826 set a [lindex $vupptr($v) $a]
829 set a $b
831 foreach a $todo {
832 if {![info exists kidchanged($a)]} continue
833 set id [lindex $varcstart($v) $a]
834 if {[llength $children($v,$id)] > 1} {
835 set children($v,$id) [lsort -command [list vtokcmp $v] \
836 $children($v,$id)]
838 set oldtok [lindex $varctok($v) $a]
839 if {!$vdatemode($v)} {
840 set tok {}
841 } else {
842 set tok $oldtok
844 set ka 0
845 set kid [last_real_child $v,$id]
846 if {$kid ne {}} {
847 set k $varcid($v,$kid)
848 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
849 set ki $kid
850 set ka $k
851 set tok [lindex $varctok($v) $k]
854 if {$ka != 0} {
855 set i [lsearch -exact $parents($v,$ki) $id]
856 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
857 append tok [strrep $j]
859 if {$tok eq $oldtok} {
860 continue
862 set id [lindex $varccommits($v,$a) end]
863 foreach p $parents($v,$id) {
864 if {[info exists varcid($v,$p)]} {
865 set kidchanged($varcid($v,$p)) 1
866 } else {
867 set sortkids($p) 1
870 lset varctok($v) $a $tok
871 set b [lindex $vupptr($v) $a]
872 if {$b != $ka} {
873 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
874 modify_arc $v $ka
876 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
877 modify_arc $v $b
879 set c [lindex $vbackptr($v) $a]
880 set d [lindex $vleftptr($v) $a]
881 if {$c == 0} {
882 lset vdownptr($v) $b $d
883 } else {
884 lset vleftptr($v) $c $d
886 if {$d != 0} {
887 lset vbackptr($v) $d $c
889 if {[lindex $vlastins($v) $b] == $a} {
890 lset vlastins($v) $b $c
892 lset vupptr($v) $a $ka
893 set c [lindex $vlastins($v) $ka]
894 if {$c == 0 || \
895 [string compare $tok [lindex $varctok($v) $c]] < 0} {
896 set c $ka
897 set b [lindex $vdownptr($v) $ka]
898 } else {
899 set b [lindex $vleftptr($v) $c]
901 while {$b != 0 && \
902 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
903 set c $b
904 set b [lindex $vleftptr($v) $c]
906 if {$c == $ka} {
907 lset vdownptr($v) $ka $a
908 lset vbackptr($v) $a 0
909 } else {
910 lset vleftptr($v) $c $a
911 lset vbackptr($v) $a $c
913 lset vleftptr($v) $a $b
914 if {$b != 0} {
915 lset vbackptr($v) $b $a
917 lset vlastins($v) $ka $a
920 foreach id [array names sortkids] {
921 if {[llength $children($v,$id)] > 1} {
922 set children($v,$id) [lsort -command [list vtokcmp $v] \
923 $children($v,$id)]
926 set t2 [clock clicks -milliseconds]
927 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
930 # Fix up the graph after we have found out that in view $v,
931 # $p (a commit that we have already seen) is actually the parent
932 # of the last commit in arc $a.
933 proc fix_reversal {p a v} {
934 global varcid varcstart varctok vupptr
936 set pa $varcid($v,$p)
937 if {$p ne [lindex $varcstart($v) $pa]} {
938 splitvarc $p $v
939 set pa $varcid($v,$p)
941 # seeds always need to be renumbered
942 if {[lindex $vupptr($v) $pa] == 0 ||
943 [string compare [lindex $varctok($v) $a] \
944 [lindex $varctok($v) $pa]] > 0} {
945 renumbervarc $pa $v
949 proc insertrow {id p v} {
950 global cmitlisted children parents varcid varctok vtokmod
951 global varccommits ordertok commitidx numcommits curview
952 global targetid targetrow vshortids
954 readcommit $id
955 set vid $v,$id
956 set cmitlisted($vid) 1
957 set children($vid) {}
958 set parents($vid) [list $p]
959 set a [newvarc $v $id]
960 set varcid($vid) $a
961 lappend vshortids($v,[string range $id 0 3]) $id
962 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
963 modify_arc $v $a
965 lappend varccommits($v,$a) $id
966 set vp $v,$p
967 if {[llength [lappend children($vp) $id]] > 1} {
968 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
969 unset -nocomplain ordertok
971 fix_reversal $p $a $v
972 incr commitidx($v)
973 if {$v == $curview} {
974 set numcommits $commitidx($v)
975 setcanvscroll
976 if {[info exists targetid]} {
977 if {![comes_before $targetid $p]} {
978 incr targetrow
984 proc insertfakerow {id p} {
985 global varcid varccommits parents children cmitlisted
986 global commitidx varctok vtokmod targetid targetrow curview numcommits
988 set v $curview
989 set a $varcid($v,$p)
990 set i [lsearch -exact $varccommits($v,$a) $p]
991 if {$i < 0} {
992 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
993 return
995 set children($v,$id) {}
996 set parents($v,$id) [list $p]
997 set varcid($v,$id) $a
998 lappend children($v,$p) $id
999 set cmitlisted($v,$id) 1
1000 set numcommits [incr commitidx($v)]
1001 # note we deliberately don't update varcstart($v) even if $i == 0
1002 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1003 modify_arc $v $a $i
1004 if {[info exists targetid]} {
1005 if {![comes_before $targetid $p]} {
1006 incr targetrow
1009 setcanvscroll
1010 drawvisible
1013 proc removefakerow {id} {
1014 global varcid varccommits parents children commitidx
1015 global varctok vtokmod cmitlisted currentid selectedline
1016 global targetid curview numcommits
1018 set v $curview
1019 if {[llength $parents($v,$id)] != 1} {
1020 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1021 return
1023 set p [lindex $parents($v,$id) 0]
1024 set a $varcid($v,$id)
1025 set i [lsearch -exact $varccommits($v,$a) $id]
1026 if {$i < 0} {
1027 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1028 return
1030 unset varcid($v,$id)
1031 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1032 unset parents($v,$id)
1033 unset children($v,$id)
1034 unset cmitlisted($v,$id)
1035 set numcommits [incr commitidx($v) -1]
1036 set j [lsearch -exact $children($v,$p) $id]
1037 if {$j >= 0} {
1038 set children($v,$p) [lreplace $children($v,$p) $j $j]
1040 modify_arc $v $a $i
1041 if {[info exist currentid] && $id eq $currentid} {
1042 unset currentid
1043 set selectedline {}
1045 if {[info exists targetid] && $targetid eq $id} {
1046 set targetid $p
1048 setcanvscroll
1049 drawvisible
1052 proc real_children {vp} {
1053 global children nullid nullid2
1055 set kids {}
1056 foreach id $children($vp) {
1057 if {$id ne $nullid && $id ne $nullid2} {
1058 lappend kids $id
1061 return $kids
1064 proc first_real_child {vp} {
1065 global children nullid nullid2
1067 foreach id $children($vp) {
1068 if {$id ne $nullid && $id ne $nullid2} {
1069 return $id
1072 return {}
1075 proc last_real_child {vp} {
1076 global children nullid nullid2
1078 set kids $children($vp)
1079 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1080 set id [lindex $kids $i]
1081 if {$id ne $nullid && $id ne $nullid2} {
1082 return $id
1085 return {}
1088 proc vtokcmp {v a b} {
1089 global varctok varcid
1091 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1092 [lindex $varctok($v) $varcid($v,$b)]]
1095 # This assumes that if lim is not given, the caller has checked that
1096 # arc a's token is less than $vtokmod($v)
1097 proc modify_arc {v a {lim {}}} {
1098 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1100 if {$lim ne {}} {
1101 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1102 if {$c > 0} return
1103 if {$c == 0} {
1104 set r [lindex $varcrow($v) $a]
1105 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1108 set vtokmod($v) [lindex $varctok($v) $a]
1109 set varcmod($v) $a
1110 if {$v == $curview} {
1111 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1112 set a [lindex $vupptr($v) $a]
1113 set lim {}
1115 set r 0
1116 if {$a != 0} {
1117 if {$lim eq {}} {
1118 set lim [llength $varccommits($v,$a)]
1120 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1122 set vrowmod($v) $r
1123 undolayout $r
1127 proc update_arcrows {v} {
1128 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1129 global varcid vrownum varcorder varcix varccommits
1130 global vupptr vdownptr vleftptr varctok
1131 global displayorder parentlist curview cached_commitrow
1133 if {$vrowmod($v) == $commitidx($v)} return
1134 if {$v == $curview} {
1135 if {[llength $displayorder] > $vrowmod($v)} {
1136 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1137 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1139 unset -nocomplain cached_commitrow
1141 set narctot [expr {[llength $varctok($v)] - 1}]
1142 set a $varcmod($v)
1143 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1144 # go up the tree until we find something that has a row number,
1145 # or we get to a seed
1146 set a [lindex $vupptr($v) $a]
1148 if {$a == 0} {
1149 set a [lindex $vdownptr($v) 0]
1150 if {$a == 0} return
1151 set vrownum($v) {0}
1152 set varcorder($v) [list $a]
1153 lset varcix($v) $a 0
1154 lset varcrow($v) $a 0
1155 set arcn 0
1156 set row 0
1157 } else {
1158 set arcn [lindex $varcix($v) $a]
1159 if {[llength $vrownum($v)] > $arcn + 1} {
1160 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1161 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1163 set row [lindex $varcrow($v) $a]
1165 while {1} {
1166 set p $a
1167 incr row [llength $varccommits($v,$a)]
1168 # go down if possible
1169 set b [lindex $vdownptr($v) $a]
1170 if {$b == 0} {
1171 # if not, go left, or go up until we can go left
1172 while {$a != 0} {
1173 set b [lindex $vleftptr($v) $a]
1174 if {$b != 0} break
1175 set a [lindex $vupptr($v) $a]
1177 if {$a == 0} break
1179 set a $b
1180 incr arcn
1181 lappend vrownum($v) $row
1182 lappend varcorder($v) $a
1183 lset varcix($v) $a $arcn
1184 lset varcrow($v) $a $row
1186 set vtokmod($v) [lindex $varctok($v) $p]
1187 set varcmod($v) $p
1188 set vrowmod($v) $row
1189 if {[info exists currentid]} {
1190 set selectedline [rowofcommit $currentid]
1194 # Test whether view $v contains commit $id
1195 proc commitinview {id v} {
1196 global varcid
1198 return [info exists varcid($v,$id)]
1201 # Return the row number for commit $id in the current view
1202 proc rowofcommit {id} {
1203 global varcid varccommits varcrow curview cached_commitrow
1204 global varctok vtokmod
1206 set v $curview
1207 if {![info exists varcid($v,$id)]} {
1208 puts "oops rowofcommit no arc for [shortids $id]"
1209 return {}
1211 set a $varcid($v,$id)
1212 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1213 update_arcrows $v
1215 if {[info exists cached_commitrow($id)]} {
1216 return $cached_commitrow($id)
1218 set i [lsearch -exact $varccommits($v,$a) $id]
1219 if {$i < 0} {
1220 puts "oops didn't find commit [shortids $id] in arc $a"
1221 return {}
1223 incr i [lindex $varcrow($v) $a]
1224 set cached_commitrow($id) $i
1225 return $i
1228 # Returns 1 if a is on an earlier row than b, otherwise 0
1229 proc comes_before {a b} {
1230 global varcid varctok curview
1232 set v $curview
1233 if {$a eq $b || ![info exists varcid($v,$a)] || \
1234 ![info exists varcid($v,$b)]} {
1235 return 0
1237 if {$varcid($v,$a) != $varcid($v,$b)} {
1238 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1239 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1241 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1244 proc bsearch {l elt} {
1245 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1246 return 0
1248 set lo 0
1249 set hi [llength $l]
1250 while {$hi - $lo > 1} {
1251 set mid [expr {int(($lo + $hi) / 2)}]
1252 set t [lindex $l $mid]
1253 if {$elt < $t} {
1254 set hi $mid
1255 } elseif {$elt > $t} {
1256 set lo $mid
1257 } else {
1258 return $mid
1261 return $lo
1264 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1265 proc make_disporder {start end} {
1266 global vrownum curview commitidx displayorder parentlist
1267 global varccommits varcorder parents vrowmod varcrow
1268 global d_valid_start d_valid_end
1270 if {$end > $vrowmod($curview)} {
1271 update_arcrows $curview
1273 set ai [bsearch $vrownum($curview) $start]
1274 set start [lindex $vrownum($curview) $ai]
1275 set narc [llength $vrownum($curview)]
1276 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1277 set a [lindex $varcorder($curview) $ai]
1278 set l [llength $displayorder]
1279 set al [llength $varccommits($curview,$a)]
1280 if {$l < $r + $al} {
1281 if {$l < $r} {
1282 set pad [ntimes [expr {$r - $l}] {}]
1283 set displayorder [concat $displayorder $pad]
1284 set parentlist [concat $parentlist $pad]
1285 } elseif {$l > $r} {
1286 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1287 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1289 foreach id $varccommits($curview,$a) {
1290 lappend displayorder $id
1291 lappend parentlist $parents($curview,$id)
1293 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1294 set i $r
1295 foreach id $varccommits($curview,$a) {
1296 lset displayorder $i $id
1297 lset parentlist $i $parents($curview,$id)
1298 incr i
1301 incr r $al
1305 proc commitonrow {row} {
1306 global displayorder
1308 set id [lindex $displayorder $row]
1309 if {$id eq {}} {
1310 make_disporder $row [expr {$row + 1}]
1311 set id [lindex $displayorder $row]
1313 return $id
1316 proc closevarcs {v} {
1317 global varctok varccommits varcid parents children
1318 global cmitlisted commitidx vtokmod curview numcommits
1320 set missing_parents 0
1321 set scripts {}
1322 set narcs [llength $varctok($v)]
1323 for {set a 1} {$a < $narcs} {incr a} {
1324 set id [lindex $varccommits($v,$a) end]
1325 foreach p $parents($v,$id) {
1326 if {[info exists varcid($v,$p)]} continue
1327 # add p as a new commit
1328 incr missing_parents
1329 set cmitlisted($v,$p) 0
1330 set parents($v,$p) {}
1331 if {[llength $children($v,$p)] == 1 &&
1332 [llength $parents($v,$id)] == 1} {
1333 set b $a
1334 } else {
1335 set b [newvarc $v $p]
1337 set varcid($v,$p) $b
1338 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1339 modify_arc $v $b
1341 lappend varccommits($v,$b) $p
1342 incr commitidx($v)
1343 if {$v == $curview} {
1344 set numcommits $commitidx($v)
1346 set scripts [check_interest $p $scripts]
1349 if {$missing_parents > 0} {
1350 foreach s $scripts {
1351 eval $s
1356 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1357 # Assumes we already have an arc for $rwid.
1358 proc rewrite_commit {v id rwid} {
1359 global children parents varcid varctok vtokmod varccommits
1361 foreach ch $children($v,$id) {
1362 # make $rwid be $ch's parent in place of $id
1363 set i [lsearch -exact $parents($v,$ch) $id]
1364 if {$i < 0} {
1365 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1367 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1368 # add $ch to $rwid's children and sort the list if necessary
1369 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1370 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1371 $children($v,$rwid)]
1373 # fix the graph after joining $id to $rwid
1374 set a $varcid($v,$ch)
1375 fix_reversal $rwid $a $v
1376 # parentlist is wrong for the last element of arc $a
1377 # even if displayorder is right, hence the 3rd arg here
1378 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1382 # Mechanism for registering a command to be executed when we come
1383 # across a particular commit. To handle the case when only the
1384 # prefix of the commit is known, the commitinterest array is now
1385 # indexed by the first 4 characters of the ID. Each element is a
1386 # list of id, cmd pairs.
1387 proc interestedin {id cmd} {
1388 global commitinterest
1390 lappend commitinterest([string range $id 0 3]) $id $cmd
1393 proc check_interest {id scripts} {
1394 global commitinterest
1396 set prefix [string range $id 0 3]
1397 if {[info exists commitinterest($prefix)]} {
1398 set newlist {}
1399 foreach {i script} $commitinterest($prefix) {
1400 if {[string match "$i*" $id]} {
1401 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1402 } else {
1403 lappend newlist $i $script
1406 if {$newlist ne {}} {
1407 set commitinterest($prefix) $newlist
1408 } else {
1409 unset commitinterest($prefix)
1412 return $scripts
1415 proc getcommitlines {fd inst view updating} {
1416 global cmitlisted leftover
1417 global commitidx commitdata vdatemode
1418 global parents children curview hlview
1419 global idpending ordertok
1420 global varccommits varcid varctok vtokmod vfilelimit vshortids
1422 set stuff [read $fd 500000]
1423 # git log doesn't terminate the last commit with a null...
1424 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1425 set stuff "\0"
1427 if {$stuff == {}} {
1428 if {![eof $fd]} {
1429 return 1
1431 global commfd viewcomplete viewactive viewname
1432 global viewinstances
1433 unset commfd($inst)
1434 set i [lsearch -exact $viewinstances($view) $inst]
1435 if {$i >= 0} {
1436 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1438 # set it blocking so we wait for the process to terminate
1439 fconfigure $fd -blocking 1
1440 if {[catch {close $fd} err]} {
1441 set fv {}
1442 if {$view != $curview} {
1443 set fv " for the \"$viewname($view)\" view"
1445 if {[string range $err 0 4] == "usage"} {
1446 set err "Gitk: error reading commits$fv:\
1447 bad arguments to git log."
1448 if {$viewname($view) eq [mc "Command line"]} {
1449 append err \
1450 " (Note: arguments to gitk are passed to git log\
1451 to allow selection of commits to be displayed.)"
1453 } else {
1454 set err "Error reading commits$fv: $err"
1456 error_popup $err
1458 if {[incr viewactive($view) -1] <= 0} {
1459 set viewcomplete($view) 1
1460 # Check if we have seen any ids listed as parents that haven't
1461 # appeared in the list
1462 closevarcs $view
1463 notbusy $view
1465 if {$view == $curview} {
1466 run chewcommits
1468 return 0
1470 set start 0
1471 set gotsome 0
1472 set scripts {}
1473 while 1 {
1474 set i [string first "\0" $stuff $start]
1475 if {$i < 0} {
1476 append leftover($inst) [string range $stuff $start end]
1477 break
1479 if {$start == 0} {
1480 set cmit $leftover($inst)
1481 append cmit [string range $stuff 0 [expr {$i - 1}]]
1482 set leftover($inst) {}
1483 } else {
1484 set cmit [string range $stuff $start [expr {$i - 1}]]
1486 set start [expr {$i + 1}]
1487 set j [string first "\n" $cmit]
1488 set ok 0
1489 set listed 1
1490 if {$j >= 0 && [string match "commit *" $cmit]} {
1491 set ids [string range $cmit 7 [expr {$j - 1}]]
1492 if {[string match {[-^<>]*} $ids]} {
1493 switch -- [string index $ids 0] {
1494 "-" {set listed 0}
1495 "^" {set listed 2}
1496 "<" {set listed 3}
1497 ">" {set listed 4}
1499 set ids [string range $ids 1 end]
1501 set ok 1
1502 foreach id $ids {
1503 if {[string length $id] != 40} {
1504 set ok 0
1505 break
1509 if {!$ok} {
1510 set shortcmit $cmit
1511 if {[string length $shortcmit] > 80} {
1512 set shortcmit "[string range $shortcmit 0 80]..."
1514 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1515 exit 1
1517 set id [lindex $ids 0]
1518 set vid $view,$id
1520 lappend vshortids($view,[string range $id 0 3]) $id
1522 if {!$listed && $updating && ![info exists varcid($vid)] &&
1523 $vfilelimit($view) ne {}} {
1524 # git log doesn't rewrite parents for unlisted commits
1525 # when doing path limiting, so work around that here
1526 # by working out the rewritten parent with git rev-list
1527 # and if we already know about it, using the rewritten
1528 # parent as a substitute parent for $id's children.
1529 if {![catch {
1530 set rwid [exec git rev-list --first-parent --max-count=1 \
1531 $id -- $vfilelimit($view)]
1532 }]} {
1533 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1534 # use $rwid in place of $id
1535 rewrite_commit $view $id $rwid
1536 continue
1541 set a 0
1542 if {[info exists varcid($vid)]} {
1543 if {$cmitlisted($vid) || !$listed} continue
1544 set a $varcid($vid)
1546 if {$listed} {
1547 set olds [lrange $ids 1 end]
1548 } else {
1549 set olds {}
1551 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1552 set cmitlisted($vid) $listed
1553 set parents($vid) $olds
1554 if {![info exists children($vid)]} {
1555 set children($vid) {}
1556 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1557 set k [lindex $children($vid) 0]
1558 if {[llength $parents($view,$k)] == 1 &&
1559 (!$vdatemode($view) ||
1560 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1561 set a $varcid($view,$k)
1564 if {$a == 0} {
1565 # new arc
1566 set a [newvarc $view $id]
1568 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1569 modify_arc $view $a
1571 if {![info exists varcid($vid)]} {
1572 set varcid($vid) $a
1573 lappend varccommits($view,$a) $id
1574 incr commitidx($view)
1577 set i 0
1578 foreach p $olds {
1579 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1580 set vp $view,$p
1581 if {[llength [lappend children($vp) $id]] > 1 &&
1582 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1583 set children($vp) [lsort -command [list vtokcmp $view] \
1584 $children($vp)]
1585 unset -nocomplain ordertok
1587 if {[info exists varcid($view,$p)]} {
1588 fix_reversal $p $a $view
1591 incr i
1594 set scripts [check_interest $id $scripts]
1595 set gotsome 1
1597 if {$gotsome} {
1598 global numcommits hlview
1600 if {$view == $curview} {
1601 set numcommits $commitidx($view)
1602 run chewcommits
1604 if {[info exists hlview] && $view == $hlview} {
1605 # we never actually get here...
1606 run vhighlightmore
1608 foreach s $scripts {
1609 eval $s
1612 return 2
1615 proc chewcommits {} {
1616 global curview hlview viewcomplete
1617 global pending_select
1619 layoutmore
1620 if {$viewcomplete($curview)} {
1621 global commitidx varctok
1622 global numcommits startmsecs
1624 if {[info exists pending_select]} {
1625 update
1626 reset_pending_select {}
1628 if {[commitinview $pending_select $curview]} {
1629 selectline [rowofcommit $pending_select] 1
1630 } else {
1631 set row [first_real_row]
1632 selectline $row 1
1635 if {$commitidx($curview) > 0} {
1636 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1637 #puts "overall $ms ms for $numcommits commits"
1638 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1639 } else {
1640 show_status [mc "No commits selected"]
1642 notbusy layout
1644 return 0
1647 proc do_readcommit {id} {
1648 global tclencoding
1650 # Invoke git-log to handle automatic encoding conversion
1651 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1652 # Read the results using i18n.logoutputencoding
1653 fconfigure $fd -translation lf -eofchar {}
1654 if {$tclencoding != {}} {
1655 fconfigure $fd -encoding $tclencoding
1657 set contents [read $fd]
1658 close $fd
1659 # Remove the heading line
1660 regsub {^commit [0-9a-f]+\n} $contents {} contents
1662 return $contents
1665 proc readcommit {id} {
1666 if {[catch {set contents [do_readcommit $id]}]} return
1667 parsecommit $id $contents 1
1670 proc parsecommit {id contents listed} {
1671 global commitinfo
1673 set inhdr 1
1674 set comment {}
1675 set headline {}
1676 set auname {}
1677 set audate {}
1678 set comname {}
1679 set comdate {}
1680 set hdrend [string first "\n\n" $contents]
1681 if {$hdrend < 0} {
1682 # should never happen...
1683 set hdrend [string length $contents]
1685 set header [string range $contents 0 [expr {$hdrend - 1}]]
1686 set comment [string range $contents [expr {$hdrend + 2}] end]
1687 foreach line [split $header "\n"] {
1688 set line [split $line " "]
1689 set tag [lindex $line 0]
1690 if {$tag == "author"} {
1691 set audate [lrange $line end-1 end]
1692 set auname [join [lrange $line 1 end-2] " "]
1693 } elseif {$tag == "committer"} {
1694 set comdate [lrange $line end-1 end]
1695 set comname [join [lrange $line 1 end-2] " "]
1698 set headline {}
1699 # take the first non-blank line of the comment as the headline
1700 set headline [string trimleft $comment]
1701 set i [string first "\n" $headline]
1702 if {$i >= 0} {
1703 set headline [string range $headline 0 $i]
1705 set headline [string trimright $headline]
1706 set i [string first "\r" $headline]
1707 if {$i >= 0} {
1708 set headline [string trimright [string range $headline 0 $i]]
1710 if {!$listed} {
1711 # git log indents the comment by 4 spaces;
1712 # if we got this via git cat-file, add the indentation
1713 set newcomment {}
1714 foreach line [split $comment "\n"] {
1715 append newcomment " "
1716 append newcomment $line
1717 append newcomment "\n"
1719 set comment $newcomment
1721 set hasnote [string first "\nNotes:\n" $contents]
1722 set diff ""
1723 # If there is diff output shown in the git-log stream, split it
1724 # out. But get rid of the empty line that always precedes the
1725 # diff.
1726 set i [string first "\n\ndiff" $comment]
1727 if {$i >= 0} {
1728 set diff [string range $comment $i+1 end]
1729 set comment [string range $comment 0 $i-1]
1731 set commitinfo($id) [list $headline $auname $audate \
1732 $comname $comdate $comment $hasnote $diff]
1735 proc getcommit {id} {
1736 global commitdata commitinfo
1738 if {[info exists commitdata($id)]} {
1739 parsecommit $id $commitdata($id) 1
1740 } else {
1741 readcommit $id
1742 if {![info exists commitinfo($id)]} {
1743 set commitinfo($id) [list [mc "No commit information available"]]
1746 return 1
1749 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1750 # and are present in the current view.
1751 # This is fairly slow...
1752 proc longid {prefix} {
1753 global varcid curview vshortids
1755 set ids {}
1756 if {[string length $prefix] >= 4} {
1757 set vshortid $curview,[string range $prefix 0 3]
1758 if {[info exists vshortids($vshortid)]} {
1759 foreach id $vshortids($vshortid) {
1760 if {[string match "$prefix*" $id]} {
1761 if {[lsearch -exact $ids $id] < 0} {
1762 lappend ids $id
1763 if {[llength $ids] >= 2} break
1768 } else {
1769 foreach match [array names varcid "$curview,$prefix*"] {
1770 lappend ids [lindex [split $match ","] 1]
1771 if {[llength $ids] >= 2} break
1774 return $ids
1777 proc readrefs {} {
1778 global tagids idtags headids idheads tagobjid
1779 global otherrefids idotherrefs mainhead mainheadid
1780 global selecthead selectheadid
1781 global hideremotes
1782 global tclencoding
1784 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1785 unset -nocomplain $v
1787 set refd [open [list | git show-ref -d] r]
1788 if {$tclencoding != {}} {
1789 fconfigure $refd -encoding $tclencoding
1791 while {[gets $refd line] >= 0} {
1792 if {[string index $line 40] ne " "} continue
1793 set id [string range $line 0 39]
1794 set ref [string range $line 41 end]
1795 if {![string match "refs/*" $ref]} continue
1796 set name [string range $ref 5 end]
1797 if {[string match "remotes/*" $name]} {
1798 if {![string match "*/HEAD" $name] && !$hideremotes} {
1799 set headids($name) $id
1800 lappend idheads($id) $name
1802 } elseif {[string match "heads/*" $name]} {
1803 set name [string range $name 6 end]
1804 set headids($name) $id
1805 lappend idheads($id) $name
1806 } elseif {[string match "tags/*" $name]} {
1807 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1808 # which is what we want since the former is the commit ID
1809 set name [string range $name 5 end]
1810 if {[string match "*^{}" $name]} {
1811 set name [string range $name 0 end-3]
1812 } else {
1813 set tagobjid($name) $id
1815 set tagids($name) $id
1816 lappend idtags($id) $name
1817 } else {
1818 set otherrefids($name) $id
1819 lappend idotherrefs($id) $name
1822 catch {close $refd}
1823 set mainhead {}
1824 set mainheadid {}
1825 catch {
1826 set mainheadid [exec git rev-parse HEAD]
1827 set thehead [exec git symbolic-ref HEAD]
1828 if {[string match "refs/heads/*" $thehead]} {
1829 set mainhead [string range $thehead 11 end]
1832 set selectheadid {}
1833 if {$selecthead ne {}} {
1834 catch {
1835 set selectheadid [exec git rev-parse --verify $selecthead]
1840 # skip over fake commits
1841 proc first_real_row {} {
1842 global nullid nullid2 numcommits
1844 for {set row 0} {$row < $numcommits} {incr row} {
1845 set id [commitonrow $row]
1846 if {$id ne $nullid && $id ne $nullid2} {
1847 break
1850 return $row
1853 # update things for a head moved to a child of its previous location
1854 proc movehead {id name} {
1855 global headids idheads
1857 removehead $headids($name) $name
1858 set headids($name) $id
1859 lappend idheads($id) $name
1862 # update things when a head has been removed
1863 proc removehead {id name} {
1864 global headids idheads
1866 if {$idheads($id) eq $name} {
1867 unset idheads($id)
1868 } else {
1869 set i [lsearch -exact $idheads($id) $name]
1870 if {$i >= 0} {
1871 set idheads($id) [lreplace $idheads($id) $i $i]
1874 unset headids($name)
1877 proc ttk_toplevel {w args} {
1878 global use_ttk
1879 eval [linsert $args 0 ::toplevel $w]
1880 if {$use_ttk} {
1881 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1883 return $w
1886 proc make_transient {window origin} {
1887 global have_tk85
1889 # In MacOS Tk 8.4 transient appears to work by setting
1890 # overrideredirect, which is utterly useless, since the
1891 # windows get no border, and are not even kept above
1892 # the parent.
1893 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1895 wm transient $window $origin
1897 # Windows fails to place transient windows normally, so
1898 # schedule a callback to center them on the parent.
1899 if {[tk windowingsystem] eq {win32}} {
1900 after idle [list tk::PlaceWindow $window widget $origin]
1904 proc show_error {w top msg} {
1905 global NS
1906 if {![info exists NS]} {set NS ""}
1907 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1908 message $w.m -text $msg -justify center -aspect 400
1909 pack $w.m -side top -fill x -padx 20 -pady 20
1910 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1911 pack $w.ok -side bottom -fill x
1912 bind $top <Visibility> "grab $top; focus $top"
1913 bind $top <Key-Return> "destroy $top"
1914 bind $top <Key-space> "destroy $top"
1915 bind $top <Key-Escape> "destroy $top"
1916 tkwait window $top
1919 proc error_popup {msg {owner .}} {
1920 if {[tk windowingsystem] eq "win32"} {
1921 tk_messageBox -icon error -type ok -title [wm title .] \
1922 -parent $owner -message $msg
1923 } else {
1924 set w .error
1925 ttk_toplevel $w
1926 make_transient $w $owner
1927 show_error $w $w $msg
1931 proc confirm_popup {msg {owner .}} {
1932 global confirm_ok NS
1933 set confirm_ok 0
1934 set w .confirm
1935 ttk_toplevel $w
1936 make_transient $w $owner
1937 message $w.m -text $msg -justify center -aspect 400
1938 pack $w.m -side top -fill x -padx 20 -pady 20
1939 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1940 pack $w.ok -side left -fill x
1941 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1942 pack $w.cancel -side right -fill x
1943 bind $w <Visibility> "grab $w; focus $w"
1944 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1945 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1946 bind $w <Key-Escape> "destroy $w"
1947 tk::PlaceWindow $w widget $owner
1948 tkwait window $w
1949 return $confirm_ok
1952 proc setoptions {} {
1953 global use_ttk
1955 if {[tk windowingsystem] ne "win32"} {
1956 option add *Panedwindow.showHandle 1 startupFile
1957 option add *Panedwindow.sashRelief raised startupFile
1958 if {[tk windowingsystem] ne "aqua"} {
1959 option add *Menu.font uifont startupFile
1961 } else {
1962 option add *Menu.TearOff 0 startupFile
1964 option add *Button.font uifont startupFile
1965 option add *Checkbutton.font uifont startupFile
1966 option add *Radiobutton.font uifont startupFile
1967 option add *Menubutton.font uifont startupFile
1968 option add *Label.font uifont startupFile
1969 option add *Message.font uifont startupFile
1970 option add *Entry.font textfont startupFile
1971 option add *Text.font textfont startupFile
1972 option add *Labelframe.font uifont startupFile
1973 option add *Spinbox.font textfont startupFile
1974 option add *Listbox.font mainfont startupFile
1977 proc setttkstyle {} {
1978 eval font configure TkDefaultFont [fontflags mainfont]
1979 eval font configure TkTextFont [fontflags textfont]
1980 eval font configure TkHeadingFont [fontflags mainfont]
1981 eval font configure TkCaptionFont [fontflags mainfont] -weight bold
1982 eval font configure TkTooltipFont [fontflags uifont]
1983 eval font configure TkFixedFont [fontflags textfont]
1984 eval font configure TkIconFont [fontflags uifont]
1985 eval font configure TkMenuFont [fontflags uifont]
1986 eval font configure TkSmallCaptionFont [fontflags uifont]
1989 # Make a menu and submenus.
1990 # m is the window name for the menu, items is the list of menu items to add.
1991 # Each item is a list {mc label type description options...}
1992 # mc is ignored; it's so we can put mc there to alert xgettext
1993 # label is the string that appears in the menu
1994 # type is cascade, command or radiobutton (should add checkbutton)
1995 # description depends on type; it's the sublist for cascade, the
1996 # command to invoke for command, or {variable value} for radiobutton
1997 proc makemenu {m items} {
1998 menu $m
1999 if {[tk windowingsystem] eq {aqua}} {
2000 set Meta1 Cmd
2001 } else {
2002 set Meta1 Ctrl
2004 foreach i $items {
2005 set name [mc [lindex $i 1]]
2006 set type [lindex $i 2]
2007 set thing [lindex $i 3]
2008 set params [list $type]
2009 if {$name ne {}} {
2010 set u [string first "&" [string map {&& x} $name]]
2011 lappend params -label [string map {&& & & {}} $name]
2012 if {$u >= 0} {
2013 lappend params -underline $u
2016 switch -- $type {
2017 "cascade" {
2018 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
2019 lappend params -menu $m.$submenu
2021 "command" {
2022 lappend params -command $thing
2024 "radiobutton" {
2025 lappend params -variable [lindex $thing 0] \
2026 -value [lindex $thing 1]
2029 set tail [lrange $i 4 end]
2030 regsub -all {\yMeta1\y} $tail $Meta1 tail
2031 eval $m add $params $tail
2032 if {$type eq "cascade"} {
2033 makemenu $m.$submenu $thing
2038 # translate string and remove ampersands
2039 proc mca {str} {
2040 return [string map {&& & & {}} [mc $str]]
2043 proc cleardropsel {w} {
2044 $w selection clear
2046 proc makedroplist {w varname args} {
2047 global use_ttk
2048 if {$use_ttk} {
2049 set width 0
2050 foreach label $args {
2051 set cx [string length $label]
2052 if {$cx > $width} {set width $cx}
2054 set gm [ttk::combobox $w -width $width -state readonly\
2055 -textvariable $varname -values $args \
2056 -exportselection false]
2057 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2058 } else {
2059 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2061 return $gm
2064 proc makewindow {} {
2065 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2066 global tabstop
2067 global findtype findtypemenu findloc findstring fstring geometry
2068 global entries sha1entry sha1string sha1but
2069 global diffcontextstring diffcontext
2070 global ignorespace
2071 global maincursor textcursor curtextcursor
2072 global rowctxmenu fakerowmenu mergemax wrapcomment
2073 global highlight_files gdttype
2074 global searchstring sstring
2075 global bgcolor fgcolor bglist fglist diffcolors diffbgcolors selectbgcolor
2076 global uifgcolor uifgdisabledcolor
2077 global filesepbgcolor filesepfgcolor
2078 global mergecolors foundbgcolor currentsearchhitbgcolor
2079 global headctxmenu progresscanv progressitem progresscoords statusw
2080 global fprogitem fprogcoord lastprogupdate progupdatepending
2081 global rprogitem rprogcoord rownumsel numcommits
2082 global have_tk85 use_ttk NS
2083 global git_version
2084 global worddiff
2086 # The "mc" arguments here are purely so that xgettext
2087 # sees the following string as needing to be translated
2088 set file {
2089 mc "&File" cascade {
2090 {mc "&Update" command updatecommits -accelerator F5}
2091 {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2092 {mc "Reread re&ferences" command rereadrefs}
2093 {mc "&List references" command showrefs -accelerator F2}
2094 {xx "" separator}
2095 {mc "Start git &gui" command {exec git gui &}}
2096 {xx "" separator}
2097 {mc "&Quit" command doquit -accelerator Meta1-Q}
2099 set edit {
2100 mc "&Edit" cascade {
2101 {mc "&Preferences" command doprefs}
2103 set view {
2104 mc "&View" cascade {
2105 {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2106 {mc "&Edit view..." command editview -state disabled -accelerator F4}
2107 {mc "&Delete view" command delview -state disabled}
2108 {xx "" separator}
2109 {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2111 if {[tk windowingsystem] ne "aqua"} {
2112 set help {
2113 mc "&Help" cascade {
2114 {mc "&About gitk" command about}
2115 {mc "&Key bindings" command keys}
2117 set bar [list $file $edit $view $help]
2118 } else {
2119 proc ::tk::mac::ShowPreferences {} {doprefs}
2120 proc ::tk::mac::Quit {} {doquit}
2121 lset file end [lreplace [lindex $file end] end-1 end]
2122 set apple {
2123 xx "&Apple" cascade {
2124 {mc "&About gitk" command about}
2125 {xx "" separator}
2127 set help {
2128 mc "&Help" cascade {
2129 {mc "&Key bindings" command keys}
2131 set bar [list $apple $file $view $help]
2133 makemenu .bar $bar
2134 . configure -menu .bar
2136 if {$use_ttk} {
2137 # cover the non-themed toplevel with a themed frame.
2138 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2141 # the gui has upper and lower half, parts of a paned window.
2142 ${NS}::panedwindow .ctop -orient vertical
2144 # possibly use assumed geometry
2145 if {![info exists geometry(pwsash0)]} {
2146 set geometry(topheight) [expr {15 * $linespc}]
2147 set geometry(topwidth) [expr {80 * $charspc}]
2148 set geometry(botheight) [expr {15 * $linespc}]
2149 set geometry(botwidth) [expr {50 * $charspc}]
2150 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2151 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2154 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2155 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2156 ${NS}::frame .tf.histframe
2157 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2158 if {!$use_ttk} {
2159 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2162 # create three canvases
2163 set cscroll .tf.histframe.csb
2164 set canv .tf.histframe.pwclist.canv
2165 canvas $canv \
2166 -selectbackground $selectbgcolor \
2167 -background $bgcolor -bd 0 \
2168 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2169 .tf.histframe.pwclist add $canv
2170 set canv2 .tf.histframe.pwclist.canv2
2171 canvas $canv2 \
2172 -selectbackground $selectbgcolor \
2173 -background $bgcolor -bd 0 -yscrollincr $linespc
2174 .tf.histframe.pwclist add $canv2
2175 set canv3 .tf.histframe.pwclist.canv3
2176 canvas $canv3 \
2177 -selectbackground $selectbgcolor \
2178 -background $bgcolor -bd 0 -yscrollincr $linespc
2179 .tf.histframe.pwclist add $canv3
2180 if {$use_ttk} {
2181 bind .tf.histframe.pwclist <Map> {
2182 bind %W <Map> {}
2183 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2184 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2186 } else {
2187 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2188 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2191 # a scroll bar to rule them
2192 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2193 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2194 pack $cscroll -side right -fill y
2195 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2196 lappend bglist $canv $canv2 $canv3
2197 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2199 # we have two button bars at bottom of top frame. Bar 1
2200 ${NS}::frame .tf.bar
2201 ${NS}::frame .tf.lbar -height 15
2203 set sha1entry .tf.bar.sha1
2204 set entries $sha1entry
2205 set sha1but .tf.bar.sha1label
2206 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2207 -command gotocommit -width 8
2208 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2209 pack .tf.bar.sha1label -side left
2210 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2211 trace add variable sha1string write sha1change
2212 pack $sha1entry -side left -pady 2
2214 set bm_left_data {
2215 #define left_width 16
2216 #define left_height 16
2217 static unsigned char left_bits[] = {
2218 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2219 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2220 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2222 set bm_right_data {
2223 #define right_width 16
2224 #define right_height 16
2225 static unsigned char right_bits[] = {
2226 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2227 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2228 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2230 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2231 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2232 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2233 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2235 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2236 if {$use_ttk} {
2237 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2238 } else {
2239 .tf.bar.leftbut configure -image bm-left
2241 pack .tf.bar.leftbut -side left -fill y
2242 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2243 if {$use_ttk} {
2244 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2245 } else {
2246 .tf.bar.rightbut configure -image bm-right
2248 pack .tf.bar.rightbut -side left -fill y
2250 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2251 set rownumsel {}
2252 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2253 -relief sunken -anchor e
2254 ${NS}::label .tf.bar.rowlabel2 -text "/"
2255 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2256 -relief sunken -anchor e
2257 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2258 -side left
2259 if {!$use_ttk} {
2260 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2262 global selectedline
2263 trace add variable selectedline write selectedline_change
2265 # Status label and progress bar
2266 set statusw .tf.bar.status
2267 ${NS}::label $statusw -width 15 -relief sunken
2268 pack $statusw -side left -padx 5
2269 if {$use_ttk} {
2270 set progresscanv [ttk::progressbar .tf.bar.progress]
2271 } else {
2272 set h [expr {[font metrics uifont -linespace] + 2}]
2273 set progresscanv .tf.bar.progress
2274 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2275 set progressitem [$progresscanv create rect -1 0 0 $h -fill "#00ff00"]
2276 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2277 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2279 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2280 set progresscoords {0 0}
2281 set fprogcoord 0
2282 set rprogcoord 0
2283 bind $progresscanv <Configure> adjustprogress
2284 set lastprogupdate [clock clicks -milliseconds]
2285 set progupdatepending 0
2287 # build up the bottom bar of upper window
2288 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2290 set bm_down_data {
2291 #define down_width 16
2292 #define down_height 16
2293 static unsigned char down_bits[] = {
2294 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2295 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2296 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2297 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2299 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2300 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2301 .tf.lbar.fnext configure -image bm-down
2303 set bm_up_data {
2304 #define up_width 16
2305 #define up_height 16
2306 static unsigned char up_bits[] = {
2307 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2308 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2309 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2310 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2312 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2313 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2314 .tf.lbar.fprev configure -image bm-up
2316 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2318 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2319 -side left -fill y
2320 set gdttype [mc "containing:"]
2321 set gm [makedroplist .tf.lbar.gdttype gdttype \
2322 [mc "containing:"] \
2323 [mc "touching paths:"] \
2324 [mc "adding/removing string:"] \
2325 [mc "changing lines matching:"]]
2326 trace add variable gdttype write gdttype_change
2327 pack .tf.lbar.gdttype -side left -fill y
2329 set findstring {}
2330 set fstring .tf.lbar.findstring
2331 lappend entries $fstring
2332 ${NS}::entry $fstring -width 30 -textvariable findstring
2333 trace add variable findstring write find_change
2334 set findtype [mc "Exact"]
2335 set findtypemenu [makedroplist .tf.lbar.findtype \
2336 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2337 trace add variable findtype write findcom_change
2338 set findloc [mc "All fields"]
2339 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2340 [mc "Comments"] [mc "Author"] [mc "Committer"]
2341 trace add variable findloc write find_change
2342 pack .tf.lbar.findloc -side right
2343 pack .tf.lbar.findtype -side right
2344 pack $fstring -side left -expand 1 -fill x
2346 # Finish putting the upper half of the viewer together
2347 pack .tf.lbar -in .tf -side bottom -fill x
2348 pack .tf.bar -in .tf -side bottom -fill x
2349 pack .tf.histframe -fill both -side top -expand 1
2350 .ctop add .tf
2351 if {!$use_ttk} {
2352 .ctop paneconfigure .tf -height $geometry(topheight)
2353 .ctop paneconfigure .tf -width $geometry(topwidth)
2356 # now build up the bottom
2357 ${NS}::panedwindow .pwbottom -orient horizontal
2359 # lower left, a text box over search bar, scroll bar to the right
2360 # if we know window height, then that will set the lower text height, otherwise
2361 # we set lower text height which will drive window height
2362 if {[info exists geometry(main)]} {
2363 ${NS}::frame .bleft -width $geometry(botwidth)
2364 } else {
2365 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2367 ${NS}::frame .bleft.top
2368 ${NS}::frame .bleft.mid
2369 ${NS}::frame .bleft.bottom
2371 # gap between sub-widgets
2372 set wgap [font measure uifont "i"]
2374 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2375 pack .bleft.top.search -side left -padx 5
2376 set sstring .bleft.top.sstring
2377 set searchstring ""
2378 ${NS}::entry $sstring -width 20 -textvariable searchstring
2379 lappend entries $sstring
2380 trace add variable searchstring write incrsearch
2381 pack $sstring -side left -expand 1 -fill x
2382 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2383 -command changediffdisp -variable diffelide -value {0 0}
2384 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2385 -command changediffdisp -variable diffelide -value {0 1}
2386 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2387 -command changediffdisp -variable diffelide -value {1 0}
2389 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2390 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left -ipadx $wgap
2391 spinbox .bleft.mid.diffcontext -width 5 \
2392 -from 0 -increment 1 -to 10000000 \
2393 -validate all -validatecommand "diffcontextvalidate %P" \
2394 -textvariable diffcontextstring
2395 .bleft.mid.diffcontext set $diffcontext
2396 trace add variable diffcontextstring write diffcontextchange
2397 lappend entries .bleft.mid.diffcontext
2398 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left -ipadx $wgap
2399 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2400 -command changeignorespace -variable ignorespace
2401 pack .bleft.mid.ignspace -side left -padx 5
2403 set worddiff [mc "Line diff"]
2404 if {[package vcompare $git_version "1.7.2"] >= 0} {
2405 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2406 [mc "Markup words"] [mc "Color words"]
2407 trace add variable worddiff write changeworddiff
2408 pack .bleft.mid.worddiff -side left -padx 5
2411 set ctext .bleft.bottom.ctext
2412 text $ctext -background $bgcolor -foreground $fgcolor \
2413 -state disabled -undo 0 -font textfont \
2414 -yscrollcommand scrolltext -wrap none \
2415 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2416 if {$have_tk85} {
2417 $ctext conf -tabstyle wordprocessor
2419 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2420 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2421 pack .bleft.top -side top -fill x
2422 pack .bleft.mid -side top -fill x
2423 grid $ctext .bleft.bottom.sb -sticky nsew
2424 grid .bleft.bottom.sbhorizontal -sticky ew
2425 grid columnconfigure .bleft.bottom 0 -weight 1
2426 grid rowconfigure .bleft.bottom 0 -weight 1
2427 grid rowconfigure .bleft.bottom 1 -weight 0
2428 pack .bleft.bottom -side top -fill both -expand 1
2429 lappend bglist $ctext
2430 lappend fglist $ctext
2432 $ctext tag conf comment -wrap $wrapcomment
2433 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2434 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2435 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2436 $ctext tag conf d0 -back [lindex $diffbgcolors 0]
2437 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2438 $ctext tag conf dresult -back [lindex $diffbgcolors 1]
2439 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2440 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2441 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2442 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2443 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2444 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2445 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2446 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2447 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2448 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2449 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2450 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2451 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2452 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2453 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2454 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2455 $ctext tag conf mmax -fore darkgrey
2456 set mergemax 16
2457 $ctext tag conf mresult -font textfontbold
2458 $ctext tag conf msep -font textfontbold
2459 $ctext tag conf found -back $foundbgcolor
2460 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2461 $ctext tag conf wwrap -wrap word -lmargin2 1c
2462 $ctext tag conf bold -font textfontbold
2463 # set these to the lowest priority:
2464 $ctext tag lower currentsearchhit
2465 $ctext tag lower found
2466 $ctext tag lower filesep
2467 $ctext tag lower dresult
2468 $ctext tag lower d0
2470 .pwbottom add .bleft
2471 if {!$use_ttk} {
2472 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2475 # lower right
2476 ${NS}::frame .bright
2477 ${NS}::frame .bright.mode
2478 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2479 -command reselectline -variable cmitmode -value "patch"
2480 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2481 -command reselectline -variable cmitmode -value "tree"
2482 grid .bright.mode.patch .bright.mode.tree -sticky ew
2483 pack .bright.mode -side top -fill x
2484 set cflist .bright.cfiles
2485 set indent [font measure mainfont "nn"]
2486 text $cflist \
2487 -selectbackground $selectbgcolor \
2488 -background $bgcolor -foreground $fgcolor \
2489 -font mainfont \
2490 -tabs [list $indent [expr {2 * $indent}]] \
2491 -yscrollcommand ".bright.sb set" \
2492 -cursor [. cget -cursor] \
2493 -spacing1 1 -spacing3 1
2494 lappend bglist $cflist
2495 lappend fglist $cflist
2496 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2497 pack .bright.sb -side right -fill y
2498 pack $cflist -side left -fill both -expand 1
2499 $cflist tag configure highlight \
2500 -background [$cflist cget -selectbackground]
2501 $cflist tag configure bold -font mainfontbold
2503 .pwbottom add .bright
2504 .ctop add .pwbottom
2506 # restore window width & height if known
2507 if {[info exists geometry(main)]} {
2508 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2509 if {$w > [winfo screenwidth .]} {
2510 set w [winfo screenwidth .]
2512 if {$h > [winfo screenheight .]} {
2513 set h [winfo screenheight .]
2515 wm geometry . "${w}x$h"
2519 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2520 wm state . $geometry(state)
2523 if {[tk windowingsystem] eq {aqua}} {
2524 set M1B M1
2525 set ::BM "3"
2526 } else {
2527 set M1B Control
2528 set ::BM "2"
2531 if {$use_ttk} {
2532 bind .ctop <Map> {
2533 bind %W <Map> {}
2534 %W sashpos 0 $::geometry(topheight)
2536 bind .pwbottom <Map> {
2537 bind %W <Map> {}
2538 %W sashpos 0 $::geometry(botwidth)
2540 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2543 pack .ctop -fill both -expand 1
2544 bindall <1> {selcanvline %W %x %y}
2545 #bindall <B1-Motion> {selcanvline %W %x %y}
2546 if {[tk windowingsystem] == "win32"} {
2547 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2548 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2549 } else {
2550 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2551 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2552 bind $ctext <Button> {
2553 if {"%b" eq 6} {
2554 $ctext xview scroll -5 units
2555 } elseif {"%b" eq 7} {
2556 $ctext xview scroll 5 units
2559 if {[tk windowingsystem] eq "aqua"} {
2560 bindall <MouseWheel> {
2561 set delta [expr {- (%D)}]
2562 allcanvs yview scroll $delta units
2564 bindall <Shift-MouseWheel> {
2565 set delta [expr {- (%D)}]
2566 $canv xview scroll $delta units
2570 bindall <$::BM> "canvscan mark %W %x %y"
2571 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2572 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2573 bind . <$M1B-Key-w> doquit
2574 bindkey <Home> selfirstline
2575 bindkey <End> sellastline
2576 bind . <Key-Up> "selnextline -1"
2577 bind . <Key-Down> "selnextline 1"
2578 bind . <Shift-Key-Up> "dofind -1 0"
2579 bind . <Shift-Key-Down> "dofind 1 0"
2580 bindkey <Key-Right> "goforw"
2581 bindkey <Key-Left> "goback"
2582 bind . <Key-Prior> "selnextpage -1"
2583 bind . <Key-Next> "selnextpage 1"
2584 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2585 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2586 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2587 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2588 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2589 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2590 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2591 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2592 bindkey <Key-space> "$ctext yview scroll 1 pages"
2593 bindkey p "selnextline -1"
2594 bindkey n "selnextline 1"
2595 bindkey z "goback"
2596 bindkey x "goforw"
2597 bindkey k "selnextline -1"
2598 bindkey j "selnextline 1"
2599 bindkey h "goback"
2600 bindkey l "goforw"
2601 bindkey b prevfile
2602 bindkey d "$ctext yview scroll 18 units"
2603 bindkey u "$ctext yview scroll -18 units"
2604 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2605 bindkey / {focus $fstring}
2606 bindkey <Key-KP_Divide> {focus $fstring}
2607 bindkey <Key-Return> {dofind 1 1}
2608 bindkey ? {dofind -1 1}
2609 bindkey f nextfile
2610 bind . <F5> updatecommits
2611 bindmodfunctionkey Shift 5 reloadcommits
2612 bind . <F2> showrefs
2613 bindmodfunctionkey Shift 4 {newview 0}
2614 bind . <F4> edit_or_newview
2615 bind . <$M1B-q> doquit
2616 bind . <$M1B-f> {dofind 1 1}
2617 bind . <$M1B-g> {dofind 1 0}
2618 bind . <$M1B-r> dosearchback
2619 bind . <$M1B-s> dosearch
2620 bind . <$M1B-equal> {incrfont 1}
2621 bind . <$M1B-plus> {incrfont 1}
2622 bind . <$M1B-KP_Add> {incrfont 1}
2623 bind . <$M1B-minus> {incrfont -1}
2624 bind . <$M1B-KP_Subtract> {incrfont -1}
2625 wm protocol . WM_DELETE_WINDOW doquit
2626 bind . <Destroy> {stop_backends}
2627 bind . <Button-1> "click %W"
2628 bind $fstring <Key-Return> {dofind 1 1}
2629 bind $sha1entry <Key-Return> {gotocommit; break}
2630 bind $sha1entry <<PasteSelection>> clearsha1
2631 bind $sha1entry <<Paste>> clearsha1
2632 bind $cflist <1> {sel_flist %W %x %y; break}
2633 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2634 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2635 global ctxbut
2636 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2637 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2638 bind $ctext <Button-1> {focus %W}
2639 bind $ctext <<Selection>> rehighlight_search_results
2640 for {set i 1} {$i < 10} {incr i} {
2641 bind . <$M1B-Key-$i> [list go_to_parent $i]
2644 set maincursor [. cget -cursor]
2645 set textcursor [$ctext cget -cursor]
2646 set curtextcursor $textcursor
2648 set rowctxmenu .rowctxmenu
2649 makemenu $rowctxmenu {
2650 {mc "Diff this -> selected" command {diffvssel 0}}
2651 {mc "Diff selected -> this" command {diffvssel 1}}
2652 {mc "Make patch" command mkpatch}
2653 {mc "Create tag" command mktag}
2654 {mc "Copy commit reference" command copyreference}
2655 {mc "Write commit to file" command writecommit}
2656 {mc "Create new branch" command mkbranch}
2657 {mc "Cherry-pick this commit" command cherrypick}
2658 {mc "Reset HEAD branch to here" command resethead}
2659 {mc "Mark this commit" command markhere}
2660 {mc "Return to mark" command gotomark}
2661 {mc "Find descendant of this and mark" command find_common_desc}
2662 {mc "Compare with marked commit" command compare_commits}
2663 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2664 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2665 {mc "Revert this commit" command revert}
2667 $rowctxmenu configure -tearoff 0
2669 set fakerowmenu .fakerowmenu
2670 makemenu $fakerowmenu {
2671 {mc "Diff this -> selected" command {diffvssel 0}}
2672 {mc "Diff selected -> this" command {diffvssel 1}}
2673 {mc "Make patch" command mkpatch}
2674 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2675 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2677 $fakerowmenu configure -tearoff 0
2679 set headctxmenu .headctxmenu
2680 makemenu $headctxmenu {
2681 {mc "Check out this branch" command cobranch}
2682 {mc "Rename this branch" command mvbranch}
2683 {mc "Remove this branch" command rmbranch}
2684 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2686 $headctxmenu configure -tearoff 0
2688 global flist_menu
2689 set flist_menu .flistctxmenu
2690 makemenu $flist_menu {
2691 {mc "Highlight this too" command {flist_hl 0}}
2692 {mc "Highlight this only" command {flist_hl 1}}
2693 {mc "External diff" command {external_diff}}
2694 {mc "Blame parent commit" command {external_blame 1}}
2695 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2697 $flist_menu configure -tearoff 0
2699 global diff_menu
2700 set diff_menu .diffctxmenu
2701 makemenu $diff_menu {
2702 {mc "Show origin of this line" command show_line_source}
2703 {mc "Run git gui blame on this line" command {external_blame_diff}}
2705 $diff_menu configure -tearoff 0
2708 # Windows sends all mouse wheel events to the current focused window, not
2709 # the one where the mouse hovers, so bind those events here and redirect
2710 # to the correct window
2711 proc windows_mousewheel_redirector {W X Y D} {
2712 global canv canv2 canv3
2713 set w [winfo containing -displayof $W $X $Y]
2714 if {$w ne ""} {
2715 set u [expr {$D < 0 ? 5 : -5}]
2716 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2717 allcanvs yview scroll $u units
2718 } else {
2719 catch {
2720 $w yview scroll $u units
2726 # Update row number label when selectedline changes
2727 proc selectedline_change {n1 n2 op} {
2728 global selectedline rownumsel
2730 if {$selectedline eq {}} {
2731 set rownumsel {}
2732 } else {
2733 set rownumsel [expr {$selectedline + 1}]
2737 # mouse-2 makes all windows scan vertically, but only the one
2738 # the cursor is in scans horizontally
2739 proc canvscan {op w x y} {
2740 global canv canv2 canv3
2741 foreach c [list $canv $canv2 $canv3] {
2742 if {$c == $w} {
2743 $c scan $op $x $y
2744 } else {
2745 $c scan $op 0 $y
2750 proc scrollcanv {cscroll f0 f1} {
2751 $cscroll set $f0 $f1
2752 drawvisible
2753 flushhighlights
2756 # when we make a key binding for the toplevel, make sure
2757 # it doesn't get triggered when that key is pressed in the
2758 # find string entry widget.
2759 proc bindkey {ev script} {
2760 global entries
2761 bind . $ev $script
2762 set escript [bind Entry $ev]
2763 if {$escript == {}} {
2764 set escript [bind Entry <Key>]
2766 foreach e $entries {
2767 bind $e $ev "$escript; break"
2771 proc bindmodfunctionkey {mod n script} {
2772 bind . <$mod-F$n> $script
2773 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2776 # set the focus back to the toplevel for any click outside
2777 # the entry widgets
2778 proc click {w} {
2779 global ctext entries
2780 foreach e [concat $entries $ctext] {
2781 if {$w == $e} return
2783 focus .
2786 # Adjust the progress bar for a change in requested extent or canvas size
2787 proc adjustprogress {} {
2788 global progresscanv progressitem progresscoords
2789 global fprogitem fprogcoord lastprogupdate progupdatepending
2790 global rprogitem rprogcoord use_ttk
2792 if {$use_ttk} {
2793 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2794 return
2797 set w [expr {[winfo width $progresscanv] - 4}]
2798 set x0 [expr {$w * [lindex $progresscoords 0]}]
2799 set x1 [expr {$w * [lindex $progresscoords 1]}]
2800 set h [winfo height $progresscanv]
2801 $progresscanv coords $progressitem $x0 0 $x1 $h
2802 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2803 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2804 set now [clock clicks -milliseconds]
2805 if {$now >= $lastprogupdate + 100} {
2806 set progupdatepending 0
2807 update
2808 } elseif {!$progupdatepending} {
2809 set progupdatepending 1
2810 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2814 proc doprogupdate {} {
2815 global lastprogupdate progupdatepending
2817 if {$progupdatepending} {
2818 set progupdatepending 0
2819 set lastprogupdate [clock clicks -milliseconds]
2820 update
2824 proc config_check_tmp_exists {tries_left} {
2825 global config_file_tmp
2827 if {[file exists $config_file_tmp]} {
2828 incr tries_left -1
2829 if {$tries_left > 0} {
2830 after 100 [list config_check_tmp_exists $tries_left]
2831 } else {
2832 error_popup "There appears to be a stale $config_file_tmp\
2833 file, which will prevent gitk from saving its configuration on exit.\
2834 Please remove it if it is not being used by any existing gitk process."
2839 proc config_init_trace {name} {
2840 global config_variable_changed config_variable_original
2842 upvar #0 $name var
2843 set config_variable_changed($name) 0
2844 set config_variable_original($name) $var
2847 proc config_variable_change_cb {name name2 op} {
2848 global config_variable_changed config_variable_original
2850 upvar #0 $name var
2851 if {$op eq "write" &&
2852 (![info exists config_variable_original($name)] ||
2853 $config_variable_original($name) ne $var)} {
2854 set config_variable_changed($name) 1
2858 proc savestuff {w} {
2859 global stuffsaved
2860 global config_file config_file_tmp
2861 global config_variables config_variable_changed
2862 global viewchanged
2864 upvar #0 viewname current_viewname
2865 upvar #0 viewfiles current_viewfiles
2866 upvar #0 viewargs current_viewargs
2867 upvar #0 viewargscmd current_viewargscmd
2868 upvar #0 viewperm current_viewperm
2869 upvar #0 nextviewnum current_nextviewnum
2870 upvar #0 use_ttk current_use_ttk
2872 if {$stuffsaved} return
2873 if {![winfo viewable .]} return
2874 set remove_tmp 0
2875 if {[catch {
2876 set try_count 0
2877 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2878 if {[incr try_count] > 50} {
2879 error "Unable to write config file: $config_file_tmp exists"
2881 after 100
2883 set remove_tmp 1
2884 if {$::tcl_platform(platform) eq {windows}} {
2885 file attributes $config_file_tmp -hidden true
2887 if {[file exists $config_file]} {
2888 source $config_file
2890 foreach var_name $config_variables {
2891 upvar #0 $var_name var
2892 upvar 0 $var_name old_var
2893 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2894 puts $f [list set $var_name $old_var]
2895 } else {
2896 puts $f [list set $var_name $var]
2900 puts $f "set geometry(main) [wm geometry .]"
2901 puts $f "set geometry(state) [wm state .]"
2902 puts $f "set geometry(topwidth) [winfo width .tf]"
2903 puts $f "set geometry(topheight) [winfo height .tf]"
2904 if {$current_use_ttk} {
2905 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2906 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2907 } else {
2908 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2909 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2911 puts $f "set geometry(botwidth) [winfo width .bleft]"
2912 puts $f "set geometry(botheight) [winfo height .bleft]"
2914 array set view_save {}
2915 array set views {}
2916 if {![info exists permviews]} { set permviews {} }
2917 foreach view $permviews {
2918 set view_save([lindex $view 0]) 1
2919 set views([lindex $view 0]) $view
2921 puts -nonewline $f "set permviews {"
2922 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2923 if {$viewchanged($v)} {
2924 if {$current_viewperm($v)} {
2925 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2926 } else {
2927 set view_save($current_viewname($v)) 0
2931 # write old and updated view to their places and append remaining to the end
2932 foreach view $permviews {
2933 set view_name [lindex $view 0]
2934 if {$view_save($view_name)} {
2935 puts $f "{$views($view_name)}"
2937 unset views($view_name)
2939 foreach view_name [array names views] {
2940 puts $f "{$views($view_name)}"
2942 puts $f "}"
2943 close $f
2944 file rename -force $config_file_tmp $config_file
2945 set remove_tmp 0
2946 } err]} {
2947 puts "Error saving config: $err"
2949 if {$remove_tmp} {
2950 file delete -force $config_file_tmp
2952 set stuffsaved 1
2955 proc resizeclistpanes {win w} {
2956 global oldwidth oldsash use_ttk
2957 if {[info exists oldwidth($win)]} {
2958 if {[info exists oldsash($win)]} {
2959 set s0 [lindex $oldsash($win) 0]
2960 set s1 [lindex $oldsash($win) 1]
2961 } elseif {$use_ttk} {
2962 set s0 [$win sashpos 0]
2963 set s1 [$win sashpos 1]
2964 } else {
2965 set s0 [$win sash coord 0]
2966 set s1 [$win sash coord 1]
2968 if {$w < 60} {
2969 set sash0 [expr {int($w/2 - 2)}]
2970 set sash1 [expr {int($w*5/6 - 2)}]
2971 } else {
2972 set factor [expr {1.0 * $w / $oldwidth($win)}]
2973 set sash0 [expr {int($factor * [lindex $s0 0])}]
2974 set sash1 [expr {int($factor * [lindex $s1 0])}]
2975 if {$sash0 < 30} {
2976 set sash0 30
2978 if {$sash1 < $sash0 + 20} {
2979 set sash1 [expr {$sash0 + 20}]
2981 if {$sash1 > $w - 10} {
2982 set sash1 [expr {$w - 10}]
2983 if {$sash0 > $sash1 - 20} {
2984 set sash0 [expr {$sash1 - 20}]
2988 if {$use_ttk} {
2989 $win sashpos 0 $sash0
2990 $win sashpos 1 $sash1
2991 } else {
2992 $win sash place 0 $sash0 [lindex $s0 1]
2993 $win sash place 1 $sash1 [lindex $s1 1]
2994 set sash0 [list $sash0 [lindex $s0 1]]
2995 set sash1 [list $sash1 [lindex $s1 1]]
2997 set oldsash($win) [list $sash0 $sash1]
2999 set oldwidth($win) $w
3002 proc resizecdetpanes {win w} {
3003 global oldwidth oldsash use_ttk
3004 if {[info exists oldwidth($win)]} {
3005 if {[info exists oldsash($win)]} {
3006 set s0 $oldsash($win)
3007 } elseif {$use_ttk} {
3008 set s0 [$win sashpos 0]
3009 } else {
3010 set s0 [$win sash coord 0]
3012 if {$w < 60} {
3013 set sash0 [expr {int($w*3/4 - 2)}]
3014 } else {
3015 set factor [expr {1.0 * $w / $oldwidth($win)}]
3016 set sash0 [expr {int($factor * [lindex $s0 0])}]
3017 if {$sash0 < 45} {
3018 set sash0 45
3020 if {$sash0 > $w - 15} {
3021 set sash0 [expr {$w - 15}]
3024 if {$use_ttk} {
3025 $win sashpos 0 $sash0
3026 } else {
3027 $win sash place 0 $sash0 [lindex $s0 1]
3028 set sash0 [list $sash0 [lindex $s0 1]]
3030 set oldsash($win) $sash0
3032 set oldwidth($win) $w
3035 proc allcanvs args {
3036 global canv canv2 canv3
3037 eval $canv $args
3038 eval $canv2 $args
3039 eval $canv3 $args
3042 proc bindall {event action} {
3043 global canv canv2 canv3
3044 bind $canv $event $action
3045 bind $canv2 $event $action
3046 bind $canv3 $event $action
3049 proc about {} {
3050 global bgcolor NS
3051 set w .about
3052 if {[winfo exists $w]} {
3053 raise $w
3054 return
3056 ttk_toplevel $w
3057 wm title $w [mc "About gitk"]
3058 make_transient $w .
3059 message $w.m -text [mc "
3060 Gitk - a commit viewer for git
3062 Copyright \u00a9 2005-2016 Paul Mackerras
3064 Use and redistribute under the terms of the GNU General Public License"] \
3065 -justify center -aspect 400 -border 2 -bg $bgcolor -relief groove
3066 pack $w.m -side top -fill x -padx 2 -pady 2
3067 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3068 pack $w.ok -side bottom
3069 bind $w <Visibility> "focus $w.ok"
3070 bind $w <Key-Escape> "destroy $w"
3071 bind $w <Key-Return> "destroy $w"
3072 tk::PlaceWindow $w widget .
3075 proc keys {} {
3076 global bgcolor NS
3077 set w .keys
3078 if {[winfo exists $w]} {
3079 raise $w
3080 return
3082 if {[tk windowingsystem] eq {aqua}} {
3083 set M1T Cmd
3084 } else {
3085 set M1T Ctrl
3087 ttk_toplevel $w
3088 wm title $w [mc "Gitk key bindings"]
3089 make_transient $w .
3090 message $w.m -text "
3091 [mc "Gitk key bindings:"]
3093 [mc "<%s-Q> Quit" $M1T]
3094 [mc "<%s-W> Close window" $M1T]
3095 [mc "<Home> Move to first commit"]
3096 [mc "<End> Move to last commit"]
3097 [mc "<Up>, p, k Move up one commit"]
3098 [mc "<Down>, n, j Move down one commit"]
3099 [mc "<Left>, z, h Go back in history list"]
3100 [mc "<Right>, x, l Go forward in history list"]
3101 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3102 [mc "<PageUp> Move up one page in commit list"]
3103 [mc "<PageDown> Move down one page in commit list"]
3104 [mc "<%s-Home> Scroll to top of commit list" $M1T]
3105 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
3106 [mc "<%s-Up> Scroll commit list up one line" $M1T]
3107 [mc "<%s-Down> Scroll commit list down one line" $M1T]
3108 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3109 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3110 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3111 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3112 [mc "<Delete>, b Scroll diff view up one page"]
3113 [mc "<Backspace> Scroll diff view up one page"]
3114 [mc "<Space> Scroll diff view down one page"]
3115 [mc "u Scroll diff view up 18 lines"]
3116 [mc "d Scroll diff view down 18 lines"]
3117 [mc "<%s-F> Find" $M1T]
3118 [mc "<%s-G> Move to next find hit" $M1T]
3119 [mc "<Return> Move to next find hit"]
3120 [mc "g Go to commit"]
3121 [mc "/ Focus the search box"]
3122 [mc "? Move to previous find hit"]
3123 [mc "f Scroll diff view to next file"]
3124 [mc "<%s-S> Search for next hit in diff view" $M1T]
3125 [mc "<%s-R> Search for previous hit in diff view" $M1T]
3126 [mc "<%s-KP+> Increase font size" $M1T]
3127 [mc "<%s-plus> Increase font size" $M1T]
3128 [mc "<%s-KP-> Decrease font size" $M1T]
3129 [mc "<%s-minus> Decrease font size" $M1T]
3130 [mc "<F5> Update"]
3132 -justify left -bg $bgcolor -border 2 -relief groove
3133 pack $w.m -side top -fill both -padx 2 -pady 2
3134 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3135 bind $w <Key-Escape> [list destroy $w]
3136 pack $w.ok -side bottom
3137 bind $w <Visibility> "focus $w.ok"
3138 bind $w <Key-Escape> "destroy $w"
3139 bind $w <Key-Return> "destroy $w"
3142 # Procedures for manipulating the file list window at the
3143 # bottom right of the overall window.
3145 proc treeview {w l openlevs} {
3146 global treecontents treediropen treeheight treeparent treeindex
3148 set ix 0
3149 set treeindex() 0
3150 set lev 0
3151 set prefix {}
3152 set prefixend -1
3153 set prefendstack {}
3154 set htstack {}
3155 set ht 0
3156 set treecontents() {}
3157 $w conf -state normal
3158 foreach f $l {
3159 while {[string range $f 0 $prefixend] ne $prefix} {
3160 if {$lev <= $openlevs} {
3161 $w mark set e:$treeindex($prefix) "end -1c"
3162 $w mark gravity e:$treeindex($prefix) left
3164 set treeheight($prefix) $ht
3165 incr ht [lindex $htstack end]
3166 set htstack [lreplace $htstack end end]
3167 set prefixend [lindex $prefendstack end]
3168 set prefendstack [lreplace $prefendstack end end]
3169 set prefix [string range $prefix 0 $prefixend]
3170 incr lev -1
3172 set tail [string range $f [expr {$prefixend+1}] end]
3173 while {[set slash [string first "/" $tail]] >= 0} {
3174 lappend htstack $ht
3175 set ht 0
3176 lappend prefendstack $prefixend
3177 incr prefixend [expr {$slash + 1}]
3178 set d [string range $tail 0 $slash]
3179 lappend treecontents($prefix) $d
3180 set oldprefix $prefix
3181 append prefix $d
3182 set treecontents($prefix) {}
3183 set treeindex($prefix) [incr ix]
3184 set treeparent($prefix) $oldprefix
3185 set tail [string range $tail [expr {$slash+1}] end]
3186 if {$lev <= $openlevs} {
3187 set ht 1
3188 set treediropen($prefix) [expr {$lev < $openlevs}]
3189 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3190 $w mark set d:$ix "end -1c"
3191 $w mark gravity d:$ix left
3192 set str "\n"
3193 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3194 $w insert end $str
3195 $w image create end -align center -image $bm -padx 1 \
3196 -name a:$ix
3197 $w insert end $d [highlight_tag $prefix]
3198 $w mark set s:$ix "end -1c"
3199 $w mark gravity s:$ix left
3201 incr lev
3203 if {$tail ne {}} {
3204 if {$lev <= $openlevs} {
3205 incr ht
3206 set str "\n"
3207 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3208 $w insert end $str
3209 $w insert end $tail [highlight_tag $f]
3211 lappend treecontents($prefix) $tail
3214 while {$htstack ne {}} {
3215 set treeheight($prefix) $ht
3216 incr ht [lindex $htstack end]
3217 set htstack [lreplace $htstack end end]
3218 set prefixend [lindex $prefendstack end]
3219 set prefendstack [lreplace $prefendstack end end]
3220 set prefix [string range $prefix 0 $prefixend]
3222 $w conf -state disabled
3225 proc linetoelt {l} {
3226 global treeheight treecontents
3228 set y 2
3229 set prefix {}
3230 while {1} {
3231 foreach e $treecontents($prefix) {
3232 if {$y == $l} {
3233 return "$prefix$e"
3235 set n 1
3236 if {[string index $e end] eq "/"} {
3237 set n $treeheight($prefix$e)
3238 if {$y + $n > $l} {
3239 append prefix $e
3240 incr y
3241 break
3244 incr y $n
3249 proc highlight_tree {y prefix} {
3250 global treeheight treecontents cflist
3252 foreach e $treecontents($prefix) {
3253 set path $prefix$e
3254 if {[highlight_tag $path] ne {}} {
3255 $cflist tag add bold $y.0 "$y.0 lineend"
3257 incr y
3258 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3259 set y [highlight_tree $y $path]
3262 return $y
3265 proc treeclosedir {w dir} {
3266 global treediropen treeheight treeparent treeindex
3268 set ix $treeindex($dir)
3269 $w conf -state normal
3270 $w delete s:$ix e:$ix
3271 set treediropen($dir) 0
3272 $w image configure a:$ix -image tri-rt
3273 $w conf -state disabled
3274 set n [expr {1 - $treeheight($dir)}]
3275 while {$dir ne {}} {
3276 incr treeheight($dir) $n
3277 set dir $treeparent($dir)
3281 proc treeopendir {w dir} {
3282 global treediropen treeheight treeparent treecontents treeindex
3284 set ix $treeindex($dir)
3285 $w conf -state normal
3286 $w image configure a:$ix -image tri-dn
3287 $w mark set e:$ix s:$ix
3288 $w mark gravity e:$ix right
3289 set lev 0
3290 set str "\n"
3291 set n [llength $treecontents($dir)]
3292 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3293 incr lev
3294 append str "\t"
3295 incr treeheight($x) $n
3297 foreach e $treecontents($dir) {
3298 set de $dir$e
3299 if {[string index $e end] eq "/"} {
3300 set iy $treeindex($de)
3301 $w mark set d:$iy e:$ix
3302 $w mark gravity d:$iy left
3303 $w insert e:$ix $str
3304 set treediropen($de) 0
3305 $w image create e:$ix -align center -image tri-rt -padx 1 \
3306 -name a:$iy
3307 $w insert e:$ix $e [highlight_tag $de]
3308 $w mark set s:$iy e:$ix
3309 $w mark gravity s:$iy left
3310 set treeheight($de) 1
3311 } else {
3312 $w insert e:$ix $str
3313 $w insert e:$ix $e [highlight_tag $de]
3316 $w mark gravity e:$ix right
3317 $w conf -state disabled
3318 set treediropen($dir) 1
3319 set top [lindex [split [$w index @0,0] .] 0]
3320 set ht [$w cget -height]
3321 set l [lindex [split [$w index s:$ix] .] 0]
3322 if {$l < $top} {
3323 $w yview $l.0
3324 } elseif {$l + $n + 1 > $top + $ht} {
3325 set top [expr {$l + $n + 2 - $ht}]
3326 if {$l < $top} {
3327 set top $l
3329 $w yview $top.0
3333 proc treeclick {w x y} {
3334 global treediropen cmitmode ctext cflist cflist_top
3336 if {$cmitmode ne "tree"} return
3337 if {![info exists cflist_top]} return
3338 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3339 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3340 $cflist tag add highlight $l.0 "$l.0 lineend"
3341 set cflist_top $l
3342 if {$l == 1} {
3343 $ctext yview 1.0
3344 return
3346 set e [linetoelt $l]
3347 if {[string index $e end] ne "/"} {
3348 showfile $e
3349 } elseif {$treediropen($e)} {
3350 treeclosedir $w $e
3351 } else {
3352 treeopendir $w $e
3356 proc setfilelist {id} {
3357 global treefilelist cflist jump_to_here
3359 treeview $cflist $treefilelist($id) 0
3360 if {$jump_to_here ne {}} {
3361 set f [lindex $jump_to_here 0]
3362 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3363 showfile $f
3368 image create bitmap tri-rt -background black -foreground blue -data {
3369 #define tri-rt_width 13
3370 #define tri-rt_height 13
3371 static unsigned char tri-rt_bits[] = {
3372 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3373 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3374 0x00, 0x00};
3375 } -maskdata {
3376 #define tri-rt-mask_width 13
3377 #define tri-rt-mask_height 13
3378 static unsigned char tri-rt-mask_bits[] = {
3379 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3380 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3381 0x08, 0x00};
3383 image create bitmap tri-dn -background black -foreground blue -data {
3384 #define tri-dn_width 13
3385 #define tri-dn_height 13
3386 static unsigned char tri-dn_bits[] = {
3387 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3388 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3389 0x00, 0x00};
3390 } -maskdata {
3391 #define tri-dn-mask_width 13
3392 #define tri-dn-mask_height 13
3393 static unsigned char tri-dn-mask_bits[] = {
3394 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3395 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3396 0x00, 0x00};
3399 image create bitmap reficon-T -background black -foreground yellow -data {
3400 #define tagicon_width 13
3401 #define tagicon_height 9
3402 static unsigned char tagicon_bits[] = {
3403 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3404 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3405 } -maskdata {
3406 #define tagicon-mask_width 13
3407 #define tagicon-mask_height 9
3408 static unsigned char tagicon-mask_bits[] = {
3409 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3410 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3412 set rectdata {
3413 #define headicon_width 13
3414 #define headicon_height 9
3415 static unsigned char headicon_bits[] = {
3416 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3417 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3419 set rectmask {
3420 #define headicon-mask_width 13
3421 #define headicon-mask_height 9
3422 static unsigned char headicon-mask_bits[] = {
3423 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3424 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3426 image create bitmap reficon-H -background black -foreground "#00ff00" \
3427 -data $rectdata -maskdata $rectmask
3428 image create bitmap reficon-R -background black -foreground "#ffddaa" \
3429 -data $rectdata -maskdata $rectmask
3430 image create bitmap reficon-o -background black -foreground "#ddddff" \
3431 -data $rectdata -maskdata $rectmask
3433 proc init_flist {first} {
3434 global cflist cflist_top difffilestart
3436 $cflist conf -state normal
3437 $cflist delete 0.0 end
3438 if {$first ne {}} {
3439 $cflist insert end $first
3440 set cflist_top 1
3441 $cflist tag add highlight 1.0 "1.0 lineend"
3442 } else {
3443 unset -nocomplain cflist_top
3445 $cflist conf -state disabled
3446 set difffilestart {}
3449 proc highlight_tag {f} {
3450 global highlight_paths
3452 foreach p $highlight_paths {
3453 if {[string match $p $f]} {
3454 return "bold"
3457 return {}
3460 proc highlight_filelist {} {
3461 global cmitmode cflist
3463 $cflist conf -state normal
3464 if {$cmitmode ne "tree"} {
3465 set end [lindex [split [$cflist index end] .] 0]
3466 for {set l 2} {$l < $end} {incr l} {
3467 set line [$cflist get $l.0 "$l.0 lineend"]
3468 if {[highlight_tag $line] ne {}} {
3469 $cflist tag add bold $l.0 "$l.0 lineend"
3472 } else {
3473 highlight_tree 2 {}
3475 $cflist conf -state disabled
3478 proc unhighlight_filelist {} {
3479 global cflist
3481 $cflist conf -state normal
3482 $cflist tag remove bold 1.0 end
3483 $cflist conf -state disabled
3486 proc add_flist {fl} {
3487 global cflist
3489 $cflist conf -state normal
3490 foreach f $fl {
3491 $cflist insert end "\n"
3492 $cflist insert end $f [highlight_tag $f]
3494 $cflist conf -state disabled
3497 proc sel_flist {w x y} {
3498 global ctext difffilestart cflist cflist_top cmitmode
3500 if {$cmitmode eq "tree"} return
3501 if {![info exists cflist_top]} return
3502 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3503 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3504 $cflist tag add highlight $l.0 "$l.0 lineend"
3505 set cflist_top $l
3506 if {$l == 1} {
3507 $ctext yview 1.0
3508 } else {
3509 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3511 suppress_highlighting_file_for_current_scrollpos
3514 proc pop_flist_menu {w X Y x y} {
3515 global ctext cflist cmitmode flist_menu flist_menu_file
3516 global treediffs diffids
3518 stopfinding
3519 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3520 if {$l <= 1} return
3521 if {$cmitmode eq "tree"} {
3522 set e [linetoelt $l]
3523 if {[string index $e end] eq "/"} return
3524 } else {
3525 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3527 set flist_menu_file $e
3528 set xdiffstate "normal"
3529 if {$cmitmode eq "tree"} {
3530 set xdiffstate "disabled"
3532 # Disable "External diff" item in tree mode
3533 $flist_menu entryconf 2 -state $xdiffstate
3534 tk_popup $flist_menu $X $Y
3537 proc find_ctext_fileinfo {line} {
3538 global ctext_file_names ctext_file_lines
3540 set ok [bsearch $ctext_file_lines $line]
3541 set tline [lindex $ctext_file_lines $ok]
3543 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3544 return {}
3545 } else {
3546 return [list [lindex $ctext_file_names $ok] $tline]
3550 proc pop_diff_menu {w X Y x y} {
3551 global ctext diff_menu flist_menu_file
3552 global diff_menu_txtpos diff_menu_line
3553 global diff_menu_filebase
3555 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3556 set diff_menu_line [lindex $diff_menu_txtpos 0]
3557 # don't pop up the menu on hunk-separator or file-separator lines
3558 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3559 return
3561 stopfinding
3562 set f [find_ctext_fileinfo $diff_menu_line]
3563 if {$f eq {}} return
3564 set flist_menu_file [lindex $f 0]
3565 set diff_menu_filebase [lindex $f 1]
3566 tk_popup $diff_menu $X $Y
3569 proc flist_hl {only} {
3570 global flist_menu_file findstring gdttype
3572 set x [shellquote $flist_menu_file]
3573 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3574 set findstring $x
3575 } else {
3576 append findstring " " $x
3578 set gdttype [mc "touching paths:"]
3581 proc gitknewtmpdir {} {
3582 global diffnum gitktmpdir gitdir env
3584 if {![info exists gitktmpdir]} {
3585 if {[info exists env(GITK_TMPDIR)]} {
3586 set tmpdir $env(GITK_TMPDIR)
3587 } elseif {[info exists env(TMPDIR)]} {
3588 set tmpdir $env(TMPDIR)
3589 } else {
3590 set tmpdir $gitdir
3592 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3593 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3594 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3596 if {[catch {file mkdir $gitktmpdir} err]} {
3597 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3598 unset gitktmpdir
3599 return {}
3601 set diffnum 0
3603 incr diffnum
3604 set diffdir [file join $gitktmpdir $diffnum]
3605 if {[catch {file mkdir $diffdir} err]} {
3606 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3607 return {}
3609 return $diffdir
3612 proc save_file_from_commit {filename output what} {
3613 global nullfile
3615 if {[catch {exec git show $filename -- > $output} err]} {
3616 if {[string match "fatal: bad revision *" $err]} {
3617 return $nullfile
3619 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3620 return {}
3622 return $output
3625 proc external_diff_get_one_file {diffid filename diffdir} {
3626 global nullid nullid2 nullfile
3627 global worktree
3629 if {$diffid == $nullid} {
3630 set difffile [file join $worktree $filename]
3631 if {[file exists $difffile]} {
3632 return $difffile
3634 return $nullfile
3636 if {$diffid == $nullid2} {
3637 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3638 return [save_file_from_commit :$filename $difffile index]
3640 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3641 return [save_file_from_commit $diffid:$filename $difffile \
3642 "revision $diffid"]
3645 proc external_diff {} {
3646 global nullid nullid2
3647 global flist_menu_file
3648 global diffids
3649 global extdifftool
3651 if {[llength $diffids] == 1} {
3652 # no reference commit given
3653 set diffidto [lindex $diffids 0]
3654 if {$diffidto eq $nullid} {
3655 # diffing working copy with index
3656 set diffidfrom $nullid2
3657 } elseif {$diffidto eq $nullid2} {
3658 # diffing index with HEAD
3659 set diffidfrom "HEAD"
3660 } else {
3661 # use first parent commit
3662 global parentlist selectedline
3663 set diffidfrom [lindex $parentlist $selectedline 0]
3665 } else {
3666 set diffidfrom [lindex $diffids 0]
3667 set diffidto [lindex $diffids 1]
3670 # make sure that several diffs wont collide
3671 set diffdir [gitknewtmpdir]
3672 if {$diffdir eq {}} return
3674 # gather files to diff
3675 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3676 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3678 if {$difffromfile ne {} && $difftofile ne {}} {
3679 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3680 if {[catch {set fl [open |$cmd r]} err]} {
3681 file delete -force $diffdir
3682 error_popup "$extdifftool: [mc "command failed:"] $err"
3683 } else {
3684 fconfigure $fl -blocking 0
3685 filerun $fl [list delete_at_eof $fl $diffdir]
3690 proc find_hunk_blamespec {base line} {
3691 global ctext
3693 # Find and parse the hunk header
3694 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3695 if {$s_lix eq {}} return
3697 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3698 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3699 s_line old_specs osz osz1 new_line nsz]} {
3700 return
3703 # base lines for the parents
3704 set base_lines [list $new_line]
3705 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3706 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3707 old_spec old_line osz]} {
3708 return
3710 lappend base_lines $old_line
3713 # Now scan the lines to determine offset within the hunk
3714 set max_parent [expr {[llength $base_lines]-2}]
3715 set dline 0
3716 set s_lno [lindex [split $s_lix "."] 0]
3718 # Determine if the line is removed
3719 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3720 if {[string match {[-+ ]*} $chunk]} {
3721 set removed_idx [string first "-" $chunk]
3722 # Choose a parent index
3723 if {$removed_idx >= 0} {
3724 set parent $removed_idx
3725 } else {
3726 set unchanged_idx [string first " " $chunk]
3727 if {$unchanged_idx >= 0} {
3728 set parent $unchanged_idx
3729 } else {
3730 # blame the current commit
3731 set parent -1
3734 # then count other lines that belong to it
3735 for {set i $line} {[incr i -1] > $s_lno} {} {
3736 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3737 # Determine if the line is removed
3738 set removed_idx [string first "-" $chunk]
3739 if {$parent >= 0} {
3740 set code [string index $chunk $parent]
3741 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3742 incr dline
3744 } else {
3745 if {$removed_idx < 0} {
3746 incr dline
3750 incr parent
3751 } else {
3752 set parent 0
3755 incr dline [lindex $base_lines $parent]
3756 return [list $parent $dline]
3759 proc external_blame_diff {} {
3760 global currentid cmitmode
3761 global diff_menu_txtpos diff_menu_line
3762 global diff_menu_filebase flist_menu_file
3764 if {$cmitmode eq "tree"} {
3765 set parent_idx 0
3766 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3767 } else {
3768 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3769 if {$hinfo ne {}} {
3770 set parent_idx [lindex $hinfo 0]
3771 set line [lindex $hinfo 1]
3772 } else {
3773 set parent_idx 0
3774 set line 0
3778 external_blame $parent_idx $line
3781 # Find the SHA1 ID of the blob for file $fname in the index
3782 # at stage 0 or 2
3783 proc index_sha1 {fname} {
3784 set f [open [list | git ls-files -s $fname] r]
3785 while {[gets $f line] >= 0} {
3786 set info [lindex [split $line "\t"] 0]
3787 set stage [lindex $info 2]
3788 if {$stage eq "0" || $stage eq "2"} {
3789 close $f
3790 return [lindex $info 1]
3793 close $f
3794 return {}
3797 # Turn an absolute path into one relative to the current directory
3798 proc make_relative {f} {
3799 if {[file pathtype $f] eq "relative"} {
3800 return $f
3802 set elts [file split $f]
3803 set here [file split [pwd]]
3804 set ei 0
3805 set hi 0
3806 set res {}
3807 foreach d $here {
3808 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3809 lappend res ".."
3810 } else {
3811 incr ei
3813 incr hi
3815 set elts [concat $res [lrange $elts $ei end]]
3816 return [eval file join $elts]
3819 proc external_blame {parent_idx {line {}}} {
3820 global flist_menu_file cdup
3821 global nullid nullid2
3822 global parentlist selectedline currentid
3824 if {$parent_idx > 0} {
3825 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3826 } else {
3827 set base_commit $currentid
3830 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3831 error_popup [mc "No such commit"]
3832 return
3835 set cmdline [list git gui blame]
3836 if {$line ne {} && $line > 1} {
3837 lappend cmdline "--line=$line"
3839 set f [file join $cdup $flist_menu_file]
3840 # Unfortunately it seems git gui blame doesn't like
3841 # being given an absolute path...
3842 set f [make_relative $f]
3843 lappend cmdline $base_commit $f
3844 if {[catch {eval exec $cmdline &} err]} {
3845 error_popup "[mc "git gui blame: command failed:"] $err"
3849 proc show_line_source {} {
3850 global cmitmode currentid parents curview blamestuff blameinst
3851 global diff_menu_line diff_menu_filebase flist_menu_file
3852 global nullid nullid2 gitdir cdup
3854 set from_index {}
3855 if {$cmitmode eq "tree"} {
3856 set id $currentid
3857 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3858 } else {
3859 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3860 if {$h eq {}} return
3861 set pi [lindex $h 0]
3862 if {$pi == 0} {
3863 mark_ctext_line $diff_menu_line
3864 return
3866 incr pi -1
3867 if {$currentid eq $nullid} {
3868 if {$pi > 0} {
3869 # must be a merge in progress...
3870 if {[catch {
3871 # get the last line from .git/MERGE_HEAD
3872 set f [open [file join $gitdir MERGE_HEAD] r]
3873 set id [lindex [split [read $f] "\n"] end-1]
3874 close $f
3875 } err]} {
3876 error_popup [mc "Couldn't read merge head: %s" $err]
3877 return
3879 } elseif {$parents($curview,$currentid) eq $nullid2} {
3880 # need to do the blame from the index
3881 if {[catch {
3882 set from_index [index_sha1 $flist_menu_file]
3883 } err]} {
3884 error_popup [mc "Error reading index: %s" $err]
3885 return
3887 } else {
3888 set id $parents($curview,$currentid)
3890 } else {
3891 set id [lindex $parents($curview,$currentid) $pi]
3893 set line [lindex $h 1]
3895 set blameargs {}
3896 if {$from_index ne {}} {
3897 lappend blameargs | git cat-file blob $from_index
3899 lappend blameargs | git blame -p -L$line,+1
3900 if {$from_index ne {}} {
3901 lappend blameargs --contents -
3902 } else {
3903 lappend blameargs $id
3905 lappend blameargs -- [file join $cdup $flist_menu_file]
3906 if {[catch {
3907 set f [open $blameargs r]
3908 } err]} {
3909 error_popup [mc "Couldn't start git blame: %s" $err]
3910 return
3912 nowbusy blaming [mc "Searching"]
3913 fconfigure $f -blocking 0
3914 set i [reg_instance $f]
3915 set blamestuff($i) {}
3916 set blameinst $i
3917 filerun $f [list read_line_source $f $i]
3920 proc stopblaming {} {
3921 global blameinst
3923 if {[info exists blameinst]} {
3924 stop_instance $blameinst
3925 unset blameinst
3926 notbusy blaming
3930 proc read_line_source {fd inst} {
3931 global blamestuff curview commfd blameinst nullid nullid2
3933 while {[gets $fd line] >= 0} {
3934 lappend blamestuff($inst) $line
3936 if {![eof $fd]} {
3937 return 1
3939 unset commfd($inst)
3940 unset blameinst
3941 notbusy blaming
3942 fconfigure $fd -blocking 1
3943 if {[catch {close $fd} err]} {
3944 error_popup [mc "Error running git blame: %s" $err]
3945 return 0
3948 set fname {}
3949 set line [split [lindex $blamestuff($inst) 0] " "]
3950 set id [lindex $line 0]
3951 set lnum [lindex $line 1]
3952 if {[string length $id] == 40 && [string is xdigit $id] &&
3953 [string is digit -strict $lnum]} {
3954 # look for "filename" line
3955 foreach l $blamestuff($inst) {
3956 if {[string match "filename *" $l]} {
3957 set fname [string range $l 9 end]
3958 break
3962 if {$fname ne {}} {
3963 # all looks good, select it
3964 if {$id eq $nullid} {
3965 # blame uses all-zeroes to mean not committed,
3966 # which would mean a change in the index
3967 set id $nullid2
3969 if {[commitinview $id $curview]} {
3970 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3971 } else {
3972 error_popup [mc "That line comes from commit %s, \
3973 which is not in this view" [shortids $id]]
3975 } else {
3976 puts "oops couldn't parse git blame output"
3978 return 0
3981 # delete $dir when we see eof on $f (presumably because the child has exited)
3982 proc delete_at_eof {f dir} {
3983 while {[gets $f line] >= 0} {}
3984 if {[eof $f]} {
3985 if {[catch {close $f} err]} {
3986 error_popup "[mc "External diff viewer failed:"] $err"
3988 file delete -force $dir
3989 return 0
3991 return 1
3994 # Functions for adding and removing shell-type quoting
3996 proc shellquote {str} {
3997 if {![string match "*\['\"\\ \t]*" $str]} {
3998 return $str
4000 if {![string match "*\['\"\\]*" $str]} {
4001 return "\"$str\""
4003 if {![string match "*'*" $str]} {
4004 return "'$str'"
4006 return "\"[string map {\" \\\" \\ \\\\} $str]\""
4009 proc shellarglist {l} {
4010 set str {}
4011 foreach a $l {
4012 if {$str ne {}} {
4013 append str " "
4015 append str [shellquote $a]
4017 return $str
4020 proc shelldequote {str} {
4021 set ret {}
4022 set used -1
4023 while {1} {
4024 incr used
4025 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
4026 append ret [string range $str $used end]
4027 set used [string length $str]
4028 break
4030 set first [lindex $first 0]
4031 set ch [string index $str $first]
4032 if {$first > $used} {
4033 append ret [string range $str $used [expr {$first - 1}]]
4034 set used $first
4036 if {$ch eq " " || $ch eq "\t"} break
4037 incr used
4038 if {$ch eq "'"} {
4039 set first [string first "'" $str $used]
4040 if {$first < 0} {
4041 error "unmatched single-quote"
4043 append ret [string range $str $used [expr {$first - 1}]]
4044 set used $first
4045 continue
4047 if {$ch eq "\\"} {
4048 if {$used >= [string length $str]} {
4049 error "trailing backslash"
4051 append ret [string index $str $used]
4052 continue
4054 # here ch == "\""
4055 while {1} {
4056 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4057 error "unmatched double-quote"
4059 set first [lindex $first 0]
4060 set ch [string index $str $first]
4061 if {$first > $used} {
4062 append ret [string range $str $used [expr {$first - 1}]]
4063 set used $first
4065 if {$ch eq "\""} break
4066 incr used
4067 append ret [string index $str $used]
4068 incr used
4071 return [list $used $ret]
4074 proc shellsplit {str} {
4075 set l {}
4076 while {1} {
4077 set str [string trimleft $str]
4078 if {$str eq {}} break
4079 set dq [shelldequote $str]
4080 set n [lindex $dq 0]
4081 set word [lindex $dq 1]
4082 set str [string range $str $n end]
4083 lappend l $word
4085 return $l
4088 proc set_window_title {} {
4089 global appname curview viewname vrevs
4090 set rev [mc "All files"]
4091 if {$curview ne 0} {
4092 if {$viewname($curview) eq [mc "Command line"]} {
4093 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4094 } else {
4095 set rev $viewname($curview)
4098 wm title . "[reponame]: $rev - $appname"
4101 # Code to implement multiple views
4103 proc newview {ishighlight} {
4104 global nextviewnum newviewname newishighlight
4105 global revtreeargs viewargscmd newviewopts curview
4107 set newishighlight $ishighlight
4108 set top .gitkview
4109 if {[winfo exists $top]} {
4110 raise $top
4111 return
4113 decode_view_opts $nextviewnum $revtreeargs
4114 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4115 set newviewopts($nextviewnum,perm) 0
4116 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4117 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4120 set known_view_options {
4121 {perm b . {} {mc "Remember this view"}}
4122 {reflabel l + {} {mc "References (space separated list):"}}
4123 {refs t15 .. {} {mc "Branches & tags:"}}
4124 {allrefs b *. "--all" {mc "All refs"}}
4125 {branches b . "--branches" {mc "All (local) branches"}}
4126 {tags b . "--tags" {mc "All tags"}}
4127 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4128 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4129 {author t15 .. "--author=*" {mc "Author:"}}
4130 {committer t15 . "--committer=*" {mc "Committer:"}}
4131 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4132 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4133 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4134 {changes_l l + {} {mc "Changes to Files:"}}
4135 {pickaxe_s r0 . {} {mc "Fixed String"}}
4136 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4137 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4138 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4139 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4140 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4141 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4142 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4143 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4144 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4145 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4146 {lright b . "--left-right" {mc "Mark branch sides"}}
4147 {first b . "--first-parent" {mc "Limit to first parent"}}
4148 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4149 {args t50 *. {} {mc "Additional arguments to git log:"}}
4150 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4151 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4154 # Convert $newviewopts($n, ...) into args for git log.
4155 proc encode_view_opts {n} {
4156 global known_view_options newviewopts
4158 set rargs [list]
4159 foreach opt $known_view_options {
4160 set patterns [lindex $opt 3]
4161 if {$patterns eq {}} continue
4162 set pattern [lindex $patterns 0]
4164 if {[lindex $opt 1] eq "b"} {
4165 set val $newviewopts($n,[lindex $opt 0])
4166 if {$val} {
4167 lappend rargs $pattern
4169 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4170 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4171 set val $newviewopts($n,$button_id)
4172 if {$val eq $value} {
4173 lappend rargs $pattern
4175 } else {
4176 set val $newviewopts($n,[lindex $opt 0])
4177 set val [string trim $val]
4178 if {$val ne {}} {
4179 set pfix [string range $pattern 0 end-1]
4180 lappend rargs $pfix$val
4184 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4185 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4188 # Fill $newviewopts($n, ...) based on args for git log.
4189 proc decode_view_opts {n view_args} {
4190 global known_view_options newviewopts
4192 foreach opt $known_view_options {
4193 set id [lindex $opt 0]
4194 if {[lindex $opt 1] eq "b"} {
4195 # Checkboxes
4196 set val 0
4197 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4198 # Radiobuttons
4199 regexp {^(.*_)} $id uselessvar id
4200 set val 0
4201 } else {
4202 # Text fields
4203 set val {}
4205 set newviewopts($n,$id) $val
4207 set oargs [list]
4208 set refargs [list]
4209 foreach arg $view_args {
4210 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4211 && ![info exists found(limit)]} {
4212 set newviewopts($n,limit) $cnt
4213 set found(limit) 1
4214 continue
4216 catch { unset val }
4217 foreach opt $known_view_options {
4218 set id [lindex $opt 0]
4219 if {[info exists found($id)]} continue
4220 foreach pattern [lindex $opt 3] {
4221 if {![string match $pattern $arg]} continue
4222 if {[lindex $opt 1] eq "b"} {
4223 # Check buttons
4224 set val 1
4225 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4226 # Radio buttons
4227 regexp {^(.*_)} $id uselessvar id
4228 set val $num
4229 } else {
4230 # Text input fields
4231 set size [string length $pattern]
4232 set val [string range $arg [expr {$size-1}] end]
4234 set newviewopts($n,$id) $val
4235 set found($id) 1
4236 break
4238 if {[info exists val]} break
4240 if {[info exists val]} continue
4241 if {[regexp {^-} $arg]} {
4242 lappend oargs $arg
4243 } else {
4244 lappend refargs $arg
4247 set newviewopts($n,refs) [shellarglist $refargs]
4248 set newviewopts($n,args) [shellarglist $oargs]
4251 proc edit_or_newview {} {
4252 global curview
4254 if {$curview > 0} {
4255 editview
4256 } else {
4257 newview 0
4261 proc editview {} {
4262 global curview
4263 global viewname viewperm newviewname newviewopts
4264 global viewargs viewargscmd
4266 set top .gitkvedit-$curview
4267 if {[winfo exists $top]} {
4268 raise $top
4269 return
4271 decode_view_opts $curview $viewargs($curview)
4272 set newviewname($curview) $viewname($curview)
4273 set newviewopts($curview,perm) $viewperm($curview)
4274 set newviewopts($curview,cmd) $viewargscmd($curview)
4275 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4278 proc vieweditor {top n title} {
4279 global newviewname newviewopts viewfiles bgcolor
4280 global known_view_options NS
4282 ttk_toplevel $top
4283 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4284 make_transient $top .
4286 # View name
4287 ${NS}::frame $top.nfr
4288 ${NS}::label $top.nl -text [mc "View Name"]
4289 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4290 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4291 pack $top.nl -in $top.nfr -side left -padx {0 5}
4292 pack $top.name -in $top.nfr -side left -padx {0 25}
4294 # View options
4295 set cframe $top.nfr
4296 set cexpand 0
4297 set cnt 0
4298 foreach opt $known_view_options {
4299 set id [lindex $opt 0]
4300 set type [lindex $opt 1]
4301 set flags [lindex $opt 2]
4302 set title [eval [lindex $opt 4]]
4303 set lxpad 0
4305 if {$flags eq "+" || $flags eq "*"} {
4306 set cframe $top.fr$cnt
4307 incr cnt
4308 ${NS}::frame $cframe
4309 pack $cframe -in $top -fill x -pady 3 -padx 3
4310 set cexpand [expr {$flags eq "*"}]
4311 } elseif {$flags eq ".." || $flags eq "*."} {
4312 set cframe $top.fr$cnt
4313 incr cnt
4314 ${NS}::frame $cframe
4315 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4316 set cexpand [expr {$flags eq "*."}]
4317 } else {
4318 set lxpad 5
4321 if {$type eq "l"} {
4322 ${NS}::label $cframe.l_$id -text $title
4323 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4324 } elseif {$type eq "b"} {
4325 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4326 pack $cframe.c_$id -in $cframe -side left \
4327 -padx [list $lxpad 0] -expand $cexpand -anchor w
4328 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4329 regexp {^(.*_)} $id uselessvar button_id
4330 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4331 pack $cframe.c_$id -in $cframe -side left \
4332 -padx [list $lxpad 0] -expand $cexpand -anchor w
4333 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4334 ${NS}::label $cframe.l_$id -text $title
4335 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4336 -textvariable newviewopts($n,$id)
4337 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4338 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4339 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4340 ${NS}::label $cframe.l_$id -text $title
4341 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4342 -textvariable newviewopts($n,$id)
4343 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4344 pack $cframe.e_$id -in $cframe -side top -fill x
4345 } elseif {$type eq "path"} {
4346 ${NS}::label $top.l -text $title
4347 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4348 text $top.t -width 40 -height 5 -background $bgcolor
4349 if {[info exists viewfiles($n)]} {
4350 foreach f $viewfiles($n) {
4351 $top.t insert end $f
4352 $top.t insert end "\n"
4354 $top.t delete {end - 1c} end
4355 $top.t mark set insert 0.0
4357 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4361 ${NS}::frame $top.buts
4362 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4363 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4364 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4365 bind $top <Control-Return> [list newviewok $top $n]
4366 bind $top <F5> [list newviewok $top $n 1]
4367 bind $top <Escape> [list destroy $top]
4368 grid $top.buts.ok $top.buts.apply $top.buts.can
4369 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4370 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4371 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4372 pack $top.buts -in $top -side top -fill x
4373 focus $top.t
4376 proc doviewmenu {m first cmd op argv} {
4377 set nmenu [$m index end]
4378 for {set i $first} {$i <= $nmenu} {incr i} {
4379 if {[$m entrycget $i -command] eq $cmd} {
4380 eval $m $op $i $argv
4381 break
4386 proc allviewmenus {n op args} {
4387 # global viewhlmenu
4389 doviewmenu .bar.view 5 [list showview $n] $op $args
4390 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4393 proc newviewok {top n {apply 0}} {
4394 global nextviewnum newviewperm newviewname newishighlight
4395 global viewname viewfiles viewperm viewchanged selectedview curview
4396 global viewargs viewargscmd newviewopts viewhlmenu
4398 if {[catch {
4399 set newargs [encode_view_opts $n]
4400 } err]} {
4401 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4402 return
4404 set files {}
4405 foreach f [split [$top.t get 0.0 end] "\n"] {
4406 set ft [string trim $f]
4407 if {$ft ne {}} {
4408 lappend files $ft
4411 if {![info exists viewfiles($n)]} {
4412 # creating a new view
4413 incr nextviewnum
4414 set viewname($n) $newviewname($n)
4415 set viewperm($n) $newviewopts($n,perm)
4416 set viewchanged($n) 1
4417 set viewfiles($n) $files
4418 set viewargs($n) $newargs
4419 set viewargscmd($n) $newviewopts($n,cmd)
4420 addviewmenu $n
4421 if {!$newishighlight} {
4422 run showview $n
4423 } else {
4424 run addvhighlight $n
4426 } else {
4427 # editing an existing view
4428 set viewperm($n) $newviewopts($n,perm)
4429 set viewchanged($n) 1
4430 if {$newviewname($n) ne $viewname($n)} {
4431 set viewname($n) $newviewname($n)
4432 doviewmenu .bar.view 5 [list showview $n] \
4433 entryconf [list -label $viewname($n)]
4434 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4435 # entryconf [list -label $viewname($n) -value $viewname($n)]
4437 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4438 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4439 set viewfiles($n) $files
4440 set viewargs($n) $newargs
4441 set viewargscmd($n) $newviewopts($n,cmd)
4442 if {$curview == $n} {
4443 run reloadcommits
4447 if {$apply} return
4448 catch {destroy $top}
4451 proc delview {} {
4452 global curview viewperm hlview selectedhlview viewchanged
4454 if {$curview == 0} return
4455 if {[info exists hlview] && $hlview == $curview} {
4456 set selectedhlview [mc "None"]
4457 unset hlview
4459 allviewmenus $curview delete
4460 set viewperm($curview) 0
4461 set viewchanged($curview) 1
4462 showview 0
4465 proc addviewmenu {n} {
4466 global viewname viewhlmenu
4468 .bar.view add radiobutton -label $viewname($n) \
4469 -command [list showview $n] -variable selectedview -value $n
4470 #$viewhlmenu add radiobutton -label $viewname($n) \
4471 # -command [list addvhighlight $n] -variable selectedhlview
4474 proc showview {n} {
4475 global curview cached_commitrow ordertok
4476 global displayorder parentlist rowidlist rowisopt rowfinal
4477 global colormap rowtextx nextcolor canvxmax
4478 global numcommits viewcomplete
4479 global selectedline currentid canv canvy0
4480 global treediffs
4481 global pending_select mainheadid
4482 global commitidx
4483 global selectedview
4484 global hlview selectedhlview commitinterest
4486 if {$n == $curview} return
4487 set selid {}
4488 set ymax [lindex [$canv cget -scrollregion] 3]
4489 set span [$canv yview]
4490 set ytop [expr {[lindex $span 0] * $ymax}]
4491 set ybot [expr {[lindex $span 1] * $ymax}]
4492 set yscreen [expr {($ybot - $ytop) / 2}]
4493 if {$selectedline ne {}} {
4494 set selid $currentid
4495 set y [yc $selectedline]
4496 if {$ytop < $y && $y < $ybot} {
4497 set yscreen [expr {$y - $ytop}]
4499 } elseif {[info exists pending_select]} {
4500 set selid $pending_select
4501 unset pending_select
4503 unselectline
4504 normalline
4505 unset -nocomplain treediffs
4506 clear_display
4507 if {[info exists hlview] && $hlview == $n} {
4508 unset hlview
4509 set selectedhlview [mc "None"]
4511 unset -nocomplain commitinterest
4512 unset -nocomplain cached_commitrow
4513 unset -nocomplain ordertok
4515 set curview $n
4516 set selectedview $n
4517 .bar.view entryconf [mca "&Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4518 .bar.view entryconf [mca "&Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4520 run refill_reflist
4521 if {![info exists viewcomplete($n)]} {
4522 getcommits $selid
4523 return
4526 set displayorder {}
4527 set parentlist {}
4528 set rowidlist {}
4529 set rowisopt {}
4530 set rowfinal {}
4531 set numcommits $commitidx($n)
4533 unset -nocomplain colormap
4534 unset -nocomplain rowtextx
4535 set nextcolor 0
4536 set canvxmax [$canv cget -width]
4537 set curview $n
4538 set row 0
4539 setcanvscroll
4540 set yf 0
4541 set row {}
4542 if {$selid ne {} && [commitinview $selid $n]} {
4543 set row [rowofcommit $selid]
4544 # try to get the selected row in the same position on the screen
4545 set ymax [lindex [$canv cget -scrollregion] 3]
4546 set ytop [expr {[yc $row] - $yscreen}]
4547 if {$ytop < 0} {
4548 set ytop 0
4550 set yf [expr {$ytop * 1.0 / $ymax}]
4552 allcanvs yview moveto $yf
4553 drawvisible
4554 if {$row ne {}} {
4555 selectline $row 0
4556 } elseif {!$viewcomplete($n)} {
4557 reset_pending_select $selid
4558 } else {
4559 reset_pending_select {}
4561 if {[commitinview $pending_select $curview]} {
4562 selectline [rowofcommit $pending_select] 1
4563 } else {
4564 set row [first_real_row]
4565 if {$row < $numcommits} {
4566 selectline $row 0
4570 if {!$viewcomplete($n)} {
4571 if {$numcommits == 0} {
4572 show_status [mc "Reading commits..."]
4574 } elseif {$numcommits == 0} {
4575 show_status [mc "No commits selected"]
4577 set_window_title
4580 # Stuff relating to the highlighting facility
4582 proc ishighlighted {id} {
4583 global vhighlights fhighlights nhighlights rhighlights
4585 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4586 return $nhighlights($id)
4588 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4589 return $vhighlights($id)
4591 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4592 return $fhighlights($id)
4594 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4595 return $rhighlights($id)
4597 return 0
4600 proc bolden {id font} {
4601 global canv linehtag currentid boldids need_redisplay markedid
4603 # need_redisplay = 1 means the display is stale and about to be redrawn
4604 if {$need_redisplay} return
4605 lappend boldids $id
4606 $canv itemconf $linehtag($id) -font $font
4607 if {[info exists currentid] && $id eq $currentid} {
4608 $canv delete secsel
4609 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4610 -outline {{}} -tags secsel \
4611 -fill [$canv cget -selectbackground]]
4612 $canv lower $t
4614 if {[info exists markedid] && $id eq $markedid} {
4615 make_idmark $id
4619 proc bolden_name {id font} {
4620 global canv2 linentag currentid boldnameids need_redisplay
4622 if {$need_redisplay} return
4623 lappend boldnameids $id
4624 $canv2 itemconf $linentag($id) -font $font
4625 if {[info exists currentid] && $id eq $currentid} {
4626 $canv2 delete secsel
4627 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4628 -outline {{}} -tags secsel \
4629 -fill [$canv2 cget -selectbackground]]
4630 $canv2 lower $t
4634 proc unbolden {} {
4635 global boldids
4637 set stillbold {}
4638 foreach id $boldids {
4639 if {![ishighlighted $id]} {
4640 bolden $id mainfont
4641 } else {
4642 lappend stillbold $id
4645 set boldids $stillbold
4648 proc addvhighlight {n} {
4649 global hlview viewcomplete curview vhl_done commitidx
4651 if {[info exists hlview]} {
4652 delvhighlight
4654 set hlview $n
4655 if {$n != $curview && ![info exists viewcomplete($n)]} {
4656 start_rev_list $n
4658 set vhl_done $commitidx($hlview)
4659 if {$vhl_done > 0} {
4660 drawvisible
4664 proc delvhighlight {} {
4665 global hlview vhighlights
4667 if {![info exists hlview]} return
4668 unset hlview
4669 unset -nocomplain vhighlights
4670 unbolden
4673 proc vhighlightmore {} {
4674 global hlview vhl_done commitidx vhighlights curview
4676 set max $commitidx($hlview)
4677 set vr [visiblerows]
4678 set r0 [lindex $vr 0]
4679 set r1 [lindex $vr 1]
4680 for {set i $vhl_done} {$i < $max} {incr i} {
4681 set id [commitonrow $i $hlview]
4682 if {[commitinview $id $curview]} {
4683 set row [rowofcommit $id]
4684 if {$r0 <= $row && $row <= $r1} {
4685 if {![highlighted $row]} {
4686 bolden $id mainfontbold
4688 set vhighlights($id) 1
4692 set vhl_done $max
4693 return 0
4696 proc askvhighlight {row id} {
4697 global hlview vhighlights iddrawn
4699 if {[commitinview $id $hlview]} {
4700 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4701 bolden $id mainfontbold
4703 set vhighlights($id) 1
4704 } else {
4705 set vhighlights($id) 0
4709 proc hfiles_change {} {
4710 global highlight_files filehighlight fhighlights fh_serial
4711 global highlight_paths
4713 if {[info exists filehighlight]} {
4714 # delete previous highlights
4715 catch {close $filehighlight}
4716 unset filehighlight
4717 unset -nocomplain fhighlights
4718 unbolden
4719 unhighlight_filelist
4721 set highlight_paths {}
4722 after cancel do_file_hl $fh_serial
4723 incr fh_serial
4724 if {$highlight_files ne {}} {
4725 after 300 do_file_hl $fh_serial
4729 proc gdttype_change {name ix op} {
4730 global gdttype highlight_files findstring findpattern
4732 stopfinding
4733 if {$findstring ne {}} {
4734 if {$gdttype eq [mc "containing:"]} {
4735 if {$highlight_files ne {}} {
4736 set highlight_files {}
4737 hfiles_change
4739 findcom_change
4740 } else {
4741 if {$findpattern ne {}} {
4742 set findpattern {}
4743 findcom_change
4745 set highlight_files $findstring
4746 hfiles_change
4748 drawvisible
4750 # enable/disable findtype/findloc menus too
4753 proc find_change {name ix op} {
4754 global gdttype findstring highlight_files
4756 stopfinding
4757 if {$gdttype eq [mc "containing:"]} {
4758 findcom_change
4759 } else {
4760 if {$highlight_files ne $findstring} {
4761 set highlight_files $findstring
4762 hfiles_change
4765 drawvisible
4768 proc findcom_change args {
4769 global nhighlights boldnameids
4770 global findpattern findtype findstring gdttype
4772 stopfinding
4773 # delete previous highlights, if any
4774 foreach id $boldnameids {
4775 bolden_name $id mainfont
4777 set boldnameids {}
4778 unset -nocomplain nhighlights
4779 unbolden
4780 unmarkmatches
4781 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4782 set findpattern {}
4783 } elseif {$findtype eq [mc "Regexp"]} {
4784 set findpattern $findstring
4785 } else {
4786 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4787 $findstring]
4788 set findpattern "*$e*"
4792 proc makepatterns {l} {
4793 set ret {}
4794 foreach e $l {
4795 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4796 if {[string index $ee end] eq "/"} {
4797 lappend ret "$ee*"
4798 } else {
4799 lappend ret $ee
4800 lappend ret "$ee/*"
4803 return $ret
4806 proc do_file_hl {serial} {
4807 global highlight_files filehighlight highlight_paths gdttype fhl_list
4808 global cdup findtype
4810 if {$gdttype eq [mc "touching paths:"]} {
4811 # If "exact" match then convert backslashes to forward slashes.
4812 # Most useful to support Windows-flavoured file paths.
4813 if {$findtype eq [mc "Exact"]} {
4814 set highlight_files [string map {"\\" "/"} $highlight_files]
4816 if {[catch {set paths [shellsplit $highlight_files]}]} return
4817 set highlight_paths [makepatterns $paths]
4818 highlight_filelist
4819 set relative_paths {}
4820 foreach path $paths {
4821 lappend relative_paths [file join $cdup $path]
4823 set gdtargs [concat -- $relative_paths]
4824 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4825 set gdtargs [list "-S$highlight_files"]
4826 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4827 set gdtargs [list "-G$highlight_files"]
4828 } else {
4829 # must be "containing:", i.e. we're searching commit info
4830 return
4832 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4833 set filehighlight [open $cmd r+]
4834 fconfigure $filehighlight -blocking 0
4835 filerun $filehighlight readfhighlight
4836 set fhl_list {}
4837 drawvisible
4838 flushhighlights
4841 proc flushhighlights {} {
4842 global filehighlight fhl_list
4844 if {[info exists filehighlight]} {
4845 lappend fhl_list {}
4846 puts $filehighlight ""
4847 flush $filehighlight
4851 proc askfilehighlight {row id} {
4852 global filehighlight fhighlights fhl_list
4854 lappend fhl_list $id
4855 set fhighlights($id) -1
4856 puts $filehighlight $id
4859 proc readfhighlight {} {
4860 global filehighlight fhighlights curview iddrawn
4861 global fhl_list find_dirn
4863 if {![info exists filehighlight]} {
4864 return 0
4866 set nr 0
4867 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4868 set line [string trim $line]
4869 set i [lsearch -exact $fhl_list $line]
4870 if {$i < 0} continue
4871 for {set j 0} {$j < $i} {incr j} {
4872 set id [lindex $fhl_list $j]
4873 set fhighlights($id) 0
4875 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4876 if {$line eq {}} continue
4877 if {![commitinview $line $curview]} continue
4878 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4879 bolden $line mainfontbold
4881 set fhighlights($line) 1
4883 if {[eof $filehighlight]} {
4884 # strange...
4885 puts "oops, git diff-tree died"
4886 catch {close $filehighlight}
4887 unset filehighlight
4888 return 0
4890 if {[info exists find_dirn]} {
4891 run findmore
4893 return 1
4896 proc doesmatch {f} {
4897 global findtype findpattern
4899 if {$findtype eq [mc "Regexp"]} {
4900 return [regexp $findpattern $f]
4901 } elseif {$findtype eq [mc "IgnCase"]} {
4902 return [string match -nocase $findpattern $f]
4903 } else {
4904 return [string match $findpattern $f]
4908 proc askfindhighlight {row id} {
4909 global nhighlights commitinfo iddrawn
4910 global findloc
4911 global markingmatches
4913 if {![info exists commitinfo($id)]} {
4914 getcommit $id
4916 set info $commitinfo($id)
4917 set isbold 0
4918 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4919 foreach f $info ty $fldtypes {
4920 if {$ty eq ""} continue
4921 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4922 [doesmatch $f]} {
4923 if {$ty eq [mc "Author"]} {
4924 set isbold 2
4925 break
4927 set isbold 1
4930 if {$isbold && [info exists iddrawn($id)]} {
4931 if {![ishighlighted $id]} {
4932 bolden $id mainfontbold
4933 if {$isbold > 1} {
4934 bolden_name $id mainfontbold
4937 if {$markingmatches} {
4938 markrowmatches $row $id
4941 set nhighlights($id) $isbold
4944 proc markrowmatches {row id} {
4945 global canv canv2 linehtag linentag commitinfo findloc
4947 set headline [lindex $commitinfo($id) 0]
4948 set author [lindex $commitinfo($id) 1]
4949 $canv delete match$row
4950 $canv2 delete match$row
4951 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4952 set m [findmatches $headline]
4953 if {$m ne {}} {
4954 markmatches $canv $row $headline $linehtag($id) $m \
4955 [$canv itemcget $linehtag($id) -font] $row
4958 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4959 set m [findmatches $author]
4960 if {$m ne {}} {
4961 markmatches $canv2 $row $author $linentag($id) $m \
4962 [$canv2 itemcget $linentag($id) -font] $row
4967 proc vrel_change {name ix op} {
4968 global highlight_related
4970 rhighlight_none
4971 if {$highlight_related ne [mc "None"]} {
4972 run drawvisible
4976 # prepare for testing whether commits are descendents or ancestors of a
4977 proc rhighlight_sel {a} {
4978 global descendent desc_todo ancestor anc_todo
4979 global highlight_related
4981 unset -nocomplain descendent
4982 set desc_todo [list $a]
4983 unset -nocomplain ancestor
4984 set anc_todo [list $a]
4985 if {$highlight_related ne [mc "None"]} {
4986 rhighlight_none
4987 run drawvisible
4991 proc rhighlight_none {} {
4992 global rhighlights
4994 unset -nocomplain rhighlights
4995 unbolden
4998 proc is_descendent {a} {
4999 global curview children descendent desc_todo
5001 set v $curview
5002 set la [rowofcommit $a]
5003 set todo $desc_todo
5004 set leftover {}
5005 set done 0
5006 for {set i 0} {$i < [llength $todo]} {incr i} {
5007 set do [lindex $todo $i]
5008 if {[rowofcommit $do] < $la} {
5009 lappend leftover $do
5010 continue
5012 foreach nk $children($v,$do) {
5013 if {![info exists descendent($nk)]} {
5014 set descendent($nk) 1
5015 lappend todo $nk
5016 if {$nk eq $a} {
5017 set done 1
5021 if {$done} {
5022 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5023 return
5026 set descendent($a) 0
5027 set desc_todo $leftover
5030 proc is_ancestor {a} {
5031 global curview parents ancestor anc_todo
5033 set v $curview
5034 set la [rowofcommit $a]
5035 set todo $anc_todo
5036 set leftover {}
5037 set done 0
5038 for {set i 0} {$i < [llength $todo]} {incr i} {
5039 set do [lindex $todo $i]
5040 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
5041 lappend leftover $do
5042 continue
5044 foreach np $parents($v,$do) {
5045 if {![info exists ancestor($np)]} {
5046 set ancestor($np) 1
5047 lappend todo $np
5048 if {$np eq $a} {
5049 set done 1
5053 if {$done} {
5054 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5055 return
5058 set ancestor($a) 0
5059 set anc_todo $leftover
5062 proc askrelhighlight {row id} {
5063 global descendent highlight_related iddrawn rhighlights
5064 global selectedline ancestor
5066 if {$selectedline eq {}} return
5067 set isbold 0
5068 if {$highlight_related eq [mc "Descendant"] ||
5069 $highlight_related eq [mc "Not descendant"]} {
5070 if {![info exists descendent($id)]} {
5071 is_descendent $id
5073 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5074 set isbold 1
5076 } elseif {$highlight_related eq [mc "Ancestor"] ||
5077 $highlight_related eq [mc "Not ancestor"]} {
5078 if {![info exists ancestor($id)]} {
5079 is_ancestor $id
5081 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5082 set isbold 1
5085 if {[info exists iddrawn($id)]} {
5086 if {$isbold && ![ishighlighted $id]} {
5087 bolden $id mainfontbold
5090 set rhighlights($id) $isbold
5093 # Graph layout functions
5095 proc shortids {ids} {
5096 set res {}
5097 foreach id $ids {
5098 if {[llength $id] > 1} {
5099 lappend res [shortids $id]
5100 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5101 lappend res [string range $id 0 7]
5102 } else {
5103 lappend res $id
5106 return $res
5109 proc ntimes {n o} {
5110 set ret {}
5111 set o [list $o]
5112 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5113 if {($n & $mask) != 0} {
5114 set ret [concat $ret $o]
5116 set o [concat $o $o]
5118 return $ret
5121 proc ordertoken {id} {
5122 global ordertok curview varcid varcstart varctok curview parents children
5123 global nullid nullid2
5125 if {[info exists ordertok($id)]} {
5126 return $ordertok($id)
5128 set origid $id
5129 set todo {}
5130 while {1} {
5131 if {[info exists varcid($curview,$id)]} {
5132 set a $varcid($curview,$id)
5133 set p [lindex $varcstart($curview) $a]
5134 } else {
5135 set p [lindex $children($curview,$id) 0]
5137 if {[info exists ordertok($p)]} {
5138 set tok $ordertok($p)
5139 break
5141 set id [first_real_child $curview,$p]
5142 if {$id eq {}} {
5143 # it's a root
5144 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5145 break
5147 if {[llength $parents($curview,$id)] == 1} {
5148 lappend todo [list $p {}]
5149 } else {
5150 set j [lsearch -exact $parents($curview,$id) $p]
5151 if {$j < 0} {
5152 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5154 lappend todo [list $p [strrep $j]]
5157 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5158 set p [lindex $todo $i 0]
5159 append tok [lindex $todo $i 1]
5160 set ordertok($p) $tok
5162 set ordertok($origid) $tok
5163 return $tok
5166 # Work out where id should go in idlist so that order-token
5167 # values increase from left to right
5168 proc idcol {idlist id {i 0}} {
5169 set t [ordertoken $id]
5170 if {$i < 0} {
5171 set i 0
5173 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5174 if {$i > [llength $idlist]} {
5175 set i [llength $idlist]
5177 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5178 incr i
5179 } else {
5180 if {$t > [ordertoken [lindex $idlist $i]]} {
5181 while {[incr i] < [llength $idlist] &&
5182 $t >= [ordertoken [lindex $idlist $i]]} {}
5185 return $i
5188 proc initlayout {} {
5189 global rowidlist rowisopt rowfinal displayorder parentlist
5190 global numcommits canvxmax canv
5191 global nextcolor
5192 global colormap rowtextx
5194 set numcommits 0
5195 set displayorder {}
5196 set parentlist {}
5197 set nextcolor 0
5198 set rowidlist {}
5199 set rowisopt {}
5200 set rowfinal {}
5201 set canvxmax [$canv cget -width]
5202 unset -nocomplain colormap
5203 unset -nocomplain rowtextx
5204 setcanvscroll
5207 proc setcanvscroll {} {
5208 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5209 global lastscrollset lastscrollrows
5211 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5212 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5213 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5214 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5215 set lastscrollset [clock clicks -milliseconds]
5216 set lastscrollrows $numcommits
5219 proc visiblerows {} {
5220 global canv numcommits linespc
5222 set ymax [lindex [$canv cget -scrollregion] 3]
5223 if {$ymax eq {} || $ymax == 0} return
5224 set f [$canv yview]
5225 set y0 [expr {int([lindex $f 0] * $ymax)}]
5226 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5227 if {$r0 < 0} {
5228 set r0 0
5230 set y1 [expr {int([lindex $f 1] * $ymax)}]
5231 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5232 if {$r1 >= $numcommits} {
5233 set r1 [expr {$numcommits - 1}]
5235 return [list $r0 $r1]
5238 proc layoutmore {} {
5239 global commitidx viewcomplete curview
5240 global numcommits pending_select curview
5241 global lastscrollset lastscrollrows
5243 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5244 [clock clicks -milliseconds] - $lastscrollset > 500} {
5245 setcanvscroll
5247 if {[info exists pending_select] &&
5248 [commitinview $pending_select $curview]} {
5249 update
5250 selectline [rowofcommit $pending_select] 1
5252 drawvisible
5255 # With path limiting, we mightn't get the actual HEAD commit,
5256 # so ask git rev-list what is the first ancestor of HEAD that
5257 # touches a file in the path limit.
5258 proc get_viewmainhead {view} {
5259 global viewmainheadid vfilelimit viewinstances mainheadid
5261 catch {
5262 set rfd [open [concat | git rev-list -1 $mainheadid \
5263 -- $vfilelimit($view)] r]
5264 set j [reg_instance $rfd]
5265 lappend viewinstances($view) $j
5266 fconfigure $rfd -blocking 0
5267 filerun $rfd [list getviewhead $rfd $j $view]
5268 set viewmainheadid($curview) {}
5272 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5273 proc getviewhead {fd inst view} {
5274 global viewmainheadid commfd curview viewinstances showlocalchanges
5276 set id {}
5277 if {[gets $fd line] < 0} {
5278 if {![eof $fd]} {
5279 return 1
5281 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5282 set id $line
5284 set viewmainheadid($view) $id
5285 close $fd
5286 unset commfd($inst)
5287 set i [lsearch -exact $viewinstances($view) $inst]
5288 if {$i >= 0} {
5289 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5291 if {$showlocalchanges && $id ne {} && $view == $curview} {
5292 doshowlocalchanges
5294 return 0
5297 proc doshowlocalchanges {} {
5298 global curview viewmainheadid
5300 if {$viewmainheadid($curview) eq {}} return
5301 if {[commitinview $viewmainheadid($curview) $curview]} {
5302 dodiffindex
5303 } else {
5304 interestedin $viewmainheadid($curview) dodiffindex
5308 proc dohidelocalchanges {} {
5309 global nullid nullid2 lserial curview
5311 if {[commitinview $nullid $curview]} {
5312 removefakerow $nullid
5314 if {[commitinview $nullid2 $curview]} {
5315 removefakerow $nullid2
5317 incr lserial
5320 # spawn off a process to do git diff-index --cached HEAD
5321 proc dodiffindex {} {
5322 global lserial showlocalchanges vfilelimit curview
5323 global hasworktree git_version
5325 if {!$showlocalchanges || !$hasworktree} return
5326 incr lserial
5327 if {[package vcompare $git_version "1.7.2"] >= 0} {
5328 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5329 } else {
5330 set cmd "|git diff-index --cached HEAD"
5332 if {$vfilelimit($curview) ne {}} {
5333 set cmd [concat $cmd -- $vfilelimit($curview)]
5335 set fd [open $cmd r]
5336 fconfigure $fd -blocking 0
5337 set i [reg_instance $fd]
5338 filerun $fd [list readdiffindex $fd $lserial $i]
5341 proc readdiffindex {fd serial inst} {
5342 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5343 global vfilelimit
5345 set isdiff 1
5346 if {[gets $fd line] < 0} {
5347 if {![eof $fd]} {
5348 return 1
5350 set isdiff 0
5352 # we only need to see one line and we don't really care what it says...
5353 stop_instance $inst
5355 if {$serial != $lserial} {
5356 return 0
5359 # now see if there are any local changes not checked in to the index
5360 set cmd "|git diff-files"
5361 if {$vfilelimit($curview) ne {}} {
5362 set cmd [concat $cmd -- $vfilelimit($curview)]
5364 set fd [open $cmd r]
5365 fconfigure $fd -blocking 0
5366 set i [reg_instance $fd]
5367 filerun $fd [list readdifffiles $fd $serial $i]
5369 if {$isdiff && ![commitinview $nullid2 $curview]} {
5370 # add the line for the changes in the index to the graph
5371 set hl [mc "Local changes checked in to index but not committed"]
5372 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5373 set commitdata($nullid2) "\n $hl\n"
5374 if {[commitinview $nullid $curview]} {
5375 removefakerow $nullid
5377 insertfakerow $nullid2 $viewmainheadid($curview)
5378 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5379 if {[commitinview $nullid $curview]} {
5380 removefakerow $nullid
5382 removefakerow $nullid2
5384 return 0
5387 proc readdifffiles {fd serial inst} {
5388 global viewmainheadid nullid nullid2 curview
5389 global commitinfo commitdata lserial
5391 set isdiff 1
5392 if {[gets $fd line] < 0} {
5393 if {![eof $fd]} {
5394 return 1
5396 set isdiff 0
5398 # we only need to see one line and we don't really care what it says...
5399 stop_instance $inst
5401 if {$serial != $lserial} {
5402 return 0
5405 if {$isdiff && ![commitinview $nullid $curview]} {
5406 # add the line for the local diff to the graph
5407 set hl [mc "Local uncommitted changes, not checked in to index"]
5408 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5409 set commitdata($nullid) "\n $hl\n"
5410 if {[commitinview $nullid2 $curview]} {
5411 set p $nullid2
5412 } else {
5413 set p $viewmainheadid($curview)
5415 insertfakerow $nullid $p
5416 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5417 removefakerow $nullid
5419 return 0
5422 proc nextuse {id row} {
5423 global curview children
5425 if {[info exists children($curview,$id)]} {
5426 foreach kid $children($curview,$id) {
5427 if {![commitinview $kid $curview]} {
5428 return -1
5430 if {[rowofcommit $kid] > $row} {
5431 return [rowofcommit $kid]
5435 if {[commitinview $id $curview]} {
5436 return [rowofcommit $id]
5438 return -1
5441 proc prevuse {id row} {
5442 global curview children
5444 set ret -1
5445 if {[info exists children($curview,$id)]} {
5446 foreach kid $children($curview,$id) {
5447 if {![commitinview $kid $curview]} break
5448 if {[rowofcommit $kid] < $row} {
5449 set ret [rowofcommit $kid]
5453 return $ret
5456 proc make_idlist {row} {
5457 global displayorder parentlist uparrowlen downarrowlen mingaplen
5458 global commitidx curview children
5460 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5461 if {$r < 0} {
5462 set r 0
5464 set ra [expr {$row - $downarrowlen}]
5465 if {$ra < 0} {
5466 set ra 0
5468 set rb [expr {$row + $uparrowlen}]
5469 if {$rb > $commitidx($curview)} {
5470 set rb $commitidx($curview)
5472 make_disporder $r [expr {$rb + 1}]
5473 set ids {}
5474 for {} {$r < $ra} {incr r} {
5475 set nextid [lindex $displayorder [expr {$r + 1}]]
5476 foreach p [lindex $parentlist $r] {
5477 if {$p eq $nextid} continue
5478 set rn [nextuse $p $r]
5479 if {$rn >= $row &&
5480 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5481 lappend ids [list [ordertoken $p] $p]
5485 for {} {$r < $row} {incr r} {
5486 set nextid [lindex $displayorder [expr {$r + 1}]]
5487 foreach p [lindex $parentlist $r] {
5488 if {$p eq $nextid} continue
5489 set rn [nextuse $p $r]
5490 if {$rn < 0 || $rn >= $row} {
5491 lappend ids [list [ordertoken $p] $p]
5495 set id [lindex $displayorder $row]
5496 lappend ids [list [ordertoken $id] $id]
5497 while {$r < $rb} {
5498 foreach p [lindex $parentlist $r] {
5499 set firstkid [lindex $children($curview,$p) 0]
5500 if {[rowofcommit $firstkid] < $row} {
5501 lappend ids [list [ordertoken $p] $p]
5504 incr r
5505 set id [lindex $displayorder $r]
5506 if {$id ne {}} {
5507 set firstkid [lindex $children($curview,$id) 0]
5508 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5509 lappend ids [list [ordertoken $id] $id]
5513 set idlist {}
5514 foreach idx [lsort -unique $ids] {
5515 lappend idlist [lindex $idx 1]
5517 return $idlist
5520 proc rowsequal {a b} {
5521 while {[set i [lsearch -exact $a {}]] >= 0} {
5522 set a [lreplace $a $i $i]
5524 while {[set i [lsearch -exact $b {}]] >= 0} {
5525 set b [lreplace $b $i $i]
5527 return [expr {$a eq $b}]
5530 proc makeupline {id row rend col} {
5531 global rowidlist uparrowlen downarrowlen mingaplen
5533 for {set r $rend} {1} {set r $rstart} {
5534 set rstart [prevuse $id $r]
5535 if {$rstart < 0} return
5536 if {$rstart < $row} break
5538 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5539 set rstart [expr {$rend - $uparrowlen - 1}]
5541 for {set r $rstart} {[incr r] <= $row} {} {
5542 set idlist [lindex $rowidlist $r]
5543 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5544 set col [idcol $idlist $id $col]
5545 lset rowidlist $r [linsert $idlist $col $id]
5546 changedrow $r
5551 proc layoutrows {row endrow} {
5552 global rowidlist rowisopt rowfinal displayorder
5553 global uparrowlen downarrowlen maxwidth mingaplen
5554 global children parentlist
5555 global commitidx viewcomplete curview
5557 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5558 set idlist {}
5559 if {$row > 0} {
5560 set rm1 [expr {$row - 1}]
5561 foreach id [lindex $rowidlist $rm1] {
5562 if {$id ne {}} {
5563 lappend idlist $id
5566 set final [lindex $rowfinal $rm1]
5568 for {} {$row < $endrow} {incr row} {
5569 set rm1 [expr {$row - 1}]
5570 if {$rm1 < 0 || $idlist eq {}} {
5571 set idlist [make_idlist $row]
5572 set final 1
5573 } else {
5574 set id [lindex $displayorder $rm1]
5575 set col [lsearch -exact $idlist $id]
5576 set idlist [lreplace $idlist $col $col]
5577 foreach p [lindex $parentlist $rm1] {
5578 if {[lsearch -exact $idlist $p] < 0} {
5579 set col [idcol $idlist $p $col]
5580 set idlist [linsert $idlist $col $p]
5581 # if not the first child, we have to insert a line going up
5582 if {$id ne [lindex $children($curview,$p) 0]} {
5583 makeupline $p $rm1 $row $col
5587 set id [lindex $displayorder $row]
5588 if {$row > $downarrowlen} {
5589 set termrow [expr {$row - $downarrowlen - 1}]
5590 foreach p [lindex $parentlist $termrow] {
5591 set i [lsearch -exact $idlist $p]
5592 if {$i < 0} continue
5593 set nr [nextuse $p $termrow]
5594 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5595 set idlist [lreplace $idlist $i $i]
5599 set col [lsearch -exact $idlist $id]
5600 if {$col < 0} {
5601 set col [idcol $idlist $id]
5602 set idlist [linsert $idlist $col $id]
5603 if {$children($curview,$id) ne {}} {
5604 makeupline $id $rm1 $row $col
5607 set r [expr {$row + $uparrowlen - 1}]
5608 if {$r < $commitidx($curview)} {
5609 set x $col
5610 foreach p [lindex $parentlist $r] {
5611 if {[lsearch -exact $idlist $p] >= 0} continue
5612 set fk [lindex $children($curview,$p) 0]
5613 if {[rowofcommit $fk] < $row} {
5614 set x [idcol $idlist $p $x]
5615 set idlist [linsert $idlist $x $p]
5618 if {[incr r] < $commitidx($curview)} {
5619 set p [lindex $displayorder $r]
5620 if {[lsearch -exact $idlist $p] < 0} {
5621 set fk [lindex $children($curview,$p) 0]
5622 if {$fk ne {} && [rowofcommit $fk] < $row} {
5623 set x [idcol $idlist $p $x]
5624 set idlist [linsert $idlist $x $p]
5630 if {$final && !$viewcomplete($curview) &&
5631 $row + $uparrowlen + $mingaplen + $downarrowlen
5632 >= $commitidx($curview)} {
5633 set final 0
5635 set l [llength $rowidlist]
5636 if {$row == $l} {
5637 lappend rowidlist $idlist
5638 lappend rowisopt 0
5639 lappend rowfinal $final
5640 } elseif {$row < $l} {
5641 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5642 lset rowidlist $row $idlist
5643 changedrow $row
5645 lset rowfinal $row $final
5646 } else {
5647 set pad [ntimes [expr {$row - $l}] {}]
5648 set rowidlist [concat $rowidlist $pad]
5649 lappend rowidlist $idlist
5650 set rowfinal [concat $rowfinal $pad]
5651 lappend rowfinal $final
5652 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5655 return $row
5658 proc changedrow {row} {
5659 global displayorder iddrawn rowisopt need_redisplay
5661 set l [llength $rowisopt]
5662 if {$row < $l} {
5663 lset rowisopt $row 0
5664 if {$row + 1 < $l} {
5665 lset rowisopt [expr {$row + 1}] 0
5666 if {$row + 2 < $l} {
5667 lset rowisopt [expr {$row + 2}] 0
5671 set id [lindex $displayorder $row]
5672 if {[info exists iddrawn($id)]} {
5673 set need_redisplay 1
5677 proc insert_pad {row col npad} {
5678 global rowidlist
5680 set pad [ntimes $npad {}]
5681 set idlist [lindex $rowidlist $row]
5682 set bef [lrange $idlist 0 [expr {$col - 1}]]
5683 set aft [lrange $idlist $col end]
5684 set i [lsearch -exact $aft {}]
5685 if {$i > 0} {
5686 set aft [lreplace $aft $i $i]
5688 lset rowidlist $row [concat $bef $pad $aft]
5689 changedrow $row
5692 proc optimize_rows {row col endrow} {
5693 global rowidlist rowisopt displayorder curview children
5695 if {$row < 1} {
5696 set row 1
5698 for {} {$row < $endrow} {incr row; set col 0} {
5699 if {[lindex $rowisopt $row]} continue
5700 set haspad 0
5701 set y0 [expr {$row - 1}]
5702 set ym [expr {$row - 2}]
5703 set idlist [lindex $rowidlist $row]
5704 set previdlist [lindex $rowidlist $y0]
5705 if {$idlist eq {} || $previdlist eq {}} continue
5706 if {$ym >= 0} {
5707 set pprevidlist [lindex $rowidlist $ym]
5708 if {$pprevidlist eq {}} continue
5709 } else {
5710 set pprevidlist {}
5712 set x0 -1
5713 set xm -1
5714 for {} {$col < [llength $idlist]} {incr col} {
5715 set id [lindex $idlist $col]
5716 if {[lindex $previdlist $col] eq $id} continue
5717 if {$id eq {}} {
5718 set haspad 1
5719 continue
5721 set x0 [lsearch -exact $previdlist $id]
5722 if {$x0 < 0} continue
5723 set z [expr {$x0 - $col}]
5724 set isarrow 0
5725 set z0 {}
5726 if {$ym >= 0} {
5727 set xm [lsearch -exact $pprevidlist $id]
5728 if {$xm >= 0} {
5729 set z0 [expr {$xm - $x0}]
5732 if {$z0 eq {}} {
5733 # if row y0 is the first child of $id then it's not an arrow
5734 if {[lindex $children($curview,$id) 0] ne
5735 [lindex $displayorder $y0]} {
5736 set isarrow 1
5739 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5740 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5741 set isarrow 1
5743 # Looking at lines from this row to the previous row,
5744 # make them go straight up if they end in an arrow on
5745 # the previous row; otherwise make them go straight up
5746 # or at 45 degrees.
5747 if {$z < -1 || ($z < 0 && $isarrow)} {
5748 # Line currently goes left too much;
5749 # insert pads in the previous row, then optimize it
5750 set npad [expr {-1 - $z + $isarrow}]
5751 insert_pad $y0 $x0 $npad
5752 if {$y0 > 0} {
5753 optimize_rows $y0 $x0 $row
5755 set previdlist [lindex $rowidlist $y0]
5756 set x0 [lsearch -exact $previdlist $id]
5757 set z [expr {$x0 - $col}]
5758 if {$z0 ne {}} {
5759 set pprevidlist [lindex $rowidlist $ym]
5760 set xm [lsearch -exact $pprevidlist $id]
5761 set z0 [expr {$xm - $x0}]
5763 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5764 # Line currently goes right too much;
5765 # insert pads in this line
5766 set npad [expr {$z - 1 + $isarrow}]
5767 insert_pad $row $col $npad
5768 set idlist [lindex $rowidlist $row]
5769 incr col $npad
5770 set z [expr {$x0 - $col}]
5771 set haspad 1
5773 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5774 # this line links to its first child on row $row-2
5775 set id [lindex $displayorder $ym]
5776 set xc [lsearch -exact $pprevidlist $id]
5777 if {$xc >= 0} {
5778 set z0 [expr {$xc - $x0}]
5781 # avoid lines jigging left then immediately right
5782 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5783 insert_pad $y0 $x0 1
5784 incr x0
5785 optimize_rows $y0 $x0 $row
5786 set previdlist [lindex $rowidlist $y0]
5789 if {!$haspad} {
5790 # Find the first column that doesn't have a line going right
5791 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5792 set id [lindex $idlist $col]
5793 if {$id eq {}} break
5794 set x0 [lsearch -exact $previdlist $id]
5795 if {$x0 < 0} {
5796 # check if this is the link to the first child
5797 set kid [lindex $displayorder $y0]
5798 if {[lindex $children($curview,$id) 0] eq $kid} {
5799 # it is, work out offset to child
5800 set x0 [lsearch -exact $previdlist $kid]
5803 if {$x0 <= $col} break
5805 # Insert a pad at that column as long as it has a line and
5806 # isn't the last column
5807 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5808 set idlist [linsert $idlist $col {}]
5809 lset rowidlist $row $idlist
5810 changedrow $row
5816 proc xc {row col} {
5817 global canvx0 linespc
5818 return [expr {$canvx0 + $col * $linespc}]
5821 proc yc {row} {
5822 global canvy0 linespc
5823 return [expr {$canvy0 + $row * $linespc}]
5826 proc linewidth {id} {
5827 global thickerline lthickness
5829 set wid $lthickness
5830 if {[info exists thickerline] && $id eq $thickerline} {
5831 set wid [expr {2 * $lthickness}]
5833 return $wid
5836 proc rowranges {id} {
5837 global curview children uparrowlen downarrowlen
5838 global rowidlist
5840 set kids $children($curview,$id)
5841 if {$kids eq {}} {
5842 return {}
5844 set ret {}
5845 lappend kids $id
5846 foreach child $kids {
5847 if {![commitinview $child $curview]} break
5848 set row [rowofcommit $child]
5849 if {![info exists prev]} {
5850 lappend ret [expr {$row + 1}]
5851 } else {
5852 if {$row <= $prevrow} {
5853 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5855 # see if the line extends the whole way from prevrow to row
5856 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5857 [lsearch -exact [lindex $rowidlist \
5858 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5859 # it doesn't, see where it ends
5860 set r [expr {$prevrow + $downarrowlen}]
5861 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5862 while {[incr r -1] > $prevrow &&
5863 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5864 } else {
5865 while {[incr r] <= $row &&
5866 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5867 incr r -1
5869 lappend ret $r
5870 # see where it starts up again
5871 set r [expr {$row - $uparrowlen}]
5872 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5873 while {[incr r] < $row &&
5874 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5875 } else {
5876 while {[incr r -1] >= $prevrow &&
5877 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5878 incr r
5880 lappend ret $r
5883 if {$child eq $id} {
5884 lappend ret $row
5886 set prev $child
5887 set prevrow $row
5889 return $ret
5892 proc drawlineseg {id row endrow arrowlow} {
5893 global rowidlist displayorder iddrawn linesegs
5894 global canv colormap linespc curview maxlinelen parentlist
5896 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5897 set le [expr {$row + 1}]
5898 set arrowhigh 1
5899 while {1} {
5900 set c [lsearch -exact [lindex $rowidlist $le] $id]
5901 if {$c < 0} {
5902 incr le -1
5903 break
5905 lappend cols $c
5906 set x [lindex $displayorder $le]
5907 if {$x eq $id} {
5908 set arrowhigh 0
5909 break
5911 if {[info exists iddrawn($x)] || $le == $endrow} {
5912 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5913 if {$c >= 0} {
5914 lappend cols $c
5915 set arrowhigh 0
5917 break
5919 incr le
5921 if {$le <= $row} {
5922 return $row
5925 set lines {}
5926 set i 0
5927 set joinhigh 0
5928 if {[info exists linesegs($id)]} {
5929 set lines $linesegs($id)
5930 foreach li $lines {
5931 set r0 [lindex $li 0]
5932 if {$r0 > $row} {
5933 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5934 set joinhigh 1
5936 break
5938 incr i
5941 set joinlow 0
5942 if {$i > 0} {
5943 set li [lindex $lines [expr {$i-1}]]
5944 set r1 [lindex $li 1]
5945 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5946 set joinlow 1
5950 set x [lindex $cols [expr {$le - $row}]]
5951 set xp [lindex $cols [expr {$le - 1 - $row}]]
5952 set dir [expr {$xp - $x}]
5953 if {$joinhigh} {
5954 set ith [lindex $lines $i 2]
5955 set coords [$canv coords $ith]
5956 set ah [$canv itemcget $ith -arrow]
5957 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5958 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5959 if {$x2 ne {} && $x - $x2 == $dir} {
5960 set coords [lrange $coords 0 end-2]
5962 } else {
5963 set coords [list [xc $le $x] [yc $le]]
5965 if {$joinlow} {
5966 set itl [lindex $lines [expr {$i-1}] 2]
5967 set al [$canv itemcget $itl -arrow]
5968 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5969 } elseif {$arrowlow} {
5970 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5971 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5972 set arrowlow 0
5975 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5976 for {set y $le} {[incr y -1] > $row} {} {
5977 set x $xp
5978 set xp [lindex $cols [expr {$y - 1 - $row}]]
5979 set ndir [expr {$xp - $x}]
5980 if {$dir != $ndir || $xp < 0} {
5981 lappend coords [xc $y $x] [yc $y]
5983 set dir $ndir
5985 if {!$joinlow} {
5986 if {$xp < 0} {
5987 # join parent line to first child
5988 set ch [lindex $displayorder $row]
5989 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5990 if {$xc < 0} {
5991 puts "oops: drawlineseg: child $ch not on row $row"
5992 } elseif {$xc != $x} {
5993 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5994 set d [expr {int(0.5 * $linespc)}]
5995 set x1 [xc $row $x]
5996 if {$xc < $x} {
5997 set x2 [expr {$x1 - $d}]
5998 } else {
5999 set x2 [expr {$x1 + $d}]
6001 set y2 [yc $row]
6002 set y1 [expr {$y2 + $d}]
6003 lappend coords $x1 $y1 $x2 $y2
6004 } elseif {$xc < $x - 1} {
6005 lappend coords [xc $row [expr {$x-1}]] [yc $row]
6006 } elseif {$xc > $x + 1} {
6007 lappend coords [xc $row [expr {$x+1}]] [yc $row]
6009 set x $xc
6011 lappend coords [xc $row $x] [yc $row]
6012 } else {
6013 set xn [xc $row $xp]
6014 set yn [yc $row]
6015 lappend coords $xn $yn
6017 if {!$joinhigh} {
6018 assigncolor $id
6019 set t [$canv create line $coords -width [linewidth $id] \
6020 -fill $colormap($id) -tags lines.$id -arrow $arrow]
6021 $canv lower $t
6022 bindline $t $id
6023 set lines [linsert $lines $i [list $row $le $t]]
6024 } else {
6025 $canv coords $ith $coords
6026 if {$arrow ne $ah} {
6027 $canv itemconf $ith -arrow $arrow
6029 lset lines $i 0 $row
6031 } else {
6032 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
6033 set ndir [expr {$xo - $xp}]
6034 set clow [$canv coords $itl]
6035 if {$dir == $ndir} {
6036 set clow [lrange $clow 2 end]
6038 set coords [concat $coords $clow]
6039 if {!$joinhigh} {
6040 lset lines [expr {$i-1}] 1 $le
6041 } else {
6042 # coalesce two pieces
6043 $canv delete $ith
6044 set b [lindex $lines [expr {$i-1}] 0]
6045 set e [lindex $lines $i 1]
6046 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6048 $canv coords $itl $coords
6049 if {$arrow ne $al} {
6050 $canv itemconf $itl -arrow $arrow
6054 set linesegs($id) $lines
6055 return $le
6058 proc drawparentlinks {id row} {
6059 global rowidlist canv colormap curview parentlist
6060 global idpos linespc
6062 set rowids [lindex $rowidlist $row]
6063 set col [lsearch -exact $rowids $id]
6064 if {$col < 0} return
6065 set olds [lindex $parentlist $row]
6066 set row2 [expr {$row + 1}]
6067 set x [xc $row $col]
6068 set y [yc $row]
6069 set y2 [yc $row2]
6070 set d [expr {int(0.5 * $linespc)}]
6071 set ymid [expr {$y + $d}]
6072 set ids [lindex $rowidlist $row2]
6073 # rmx = right-most X coord used
6074 set rmx 0
6075 foreach p $olds {
6076 set i [lsearch -exact $ids $p]
6077 if {$i < 0} {
6078 puts "oops, parent $p of $id not in list"
6079 continue
6081 set x2 [xc $row2 $i]
6082 if {$x2 > $rmx} {
6083 set rmx $x2
6085 set j [lsearch -exact $rowids $p]
6086 if {$j < 0} {
6087 # drawlineseg will do this one for us
6088 continue
6090 assigncolor $p
6091 # should handle duplicated parents here...
6092 set coords [list $x $y]
6093 if {$i != $col} {
6094 # if attaching to a vertical segment, draw a smaller
6095 # slant for visual distinctness
6096 if {$i == $j} {
6097 if {$i < $col} {
6098 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6099 } else {
6100 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6102 } elseif {$i < $col && $i < $j} {
6103 # segment slants towards us already
6104 lappend coords [xc $row $j] $y
6105 } else {
6106 if {$i < $col - 1} {
6107 lappend coords [expr {$x2 + $linespc}] $y
6108 } elseif {$i > $col + 1} {
6109 lappend coords [expr {$x2 - $linespc}] $y
6111 lappend coords $x2 $y2
6113 } else {
6114 lappend coords $x2 $y2
6116 set t [$canv create line $coords -width [linewidth $p] \
6117 -fill $colormap($p) -tags lines.$p]
6118 $canv lower $t
6119 bindline $t $p
6121 if {$rmx > [lindex $idpos($id) 1]} {
6122 lset idpos($id) 1 $rmx
6123 redrawtags $id
6127 proc drawlines {id} {
6128 global canv
6130 $canv itemconf lines.$id -width [linewidth $id]
6133 proc drawcmittext {id row col} {
6134 global linespc canv canv2 canv3 fgcolor curview
6135 global cmitlisted commitinfo rowidlist parentlist
6136 global rowtextx idpos idtags idheads idotherrefs
6137 global linehtag linentag linedtag selectedline
6138 global canvxmax boldids boldnameids fgcolor markedid
6139 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6140 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6141 global circleoutlinecolor
6143 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6144 set listed $cmitlisted($curview,$id)
6145 if {$id eq $nullid} {
6146 set ofill $workingfilescirclecolor
6147 } elseif {$id eq $nullid2} {
6148 set ofill $indexcirclecolor
6149 } elseif {$id eq $mainheadid} {
6150 set ofill $mainheadcirclecolor
6151 } else {
6152 set ofill [lindex $circlecolors $listed]
6154 set x [xc $row $col]
6155 set y [yc $row]
6156 set orad [expr {$linespc / 3}]
6157 if {$listed <= 2} {
6158 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6159 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6160 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6161 } elseif {$listed == 3} {
6162 # triangle pointing left for left-side commits
6163 set t [$canv create polygon \
6164 [expr {$x - $orad}] $y \
6165 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6166 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6167 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6168 } else {
6169 # triangle pointing right for right-side commits
6170 set t [$canv create polygon \
6171 [expr {$x + $orad - 1}] $y \
6172 [expr {$x - $orad}] [expr {$y - $orad}] \
6173 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6174 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6176 set circleitem($row) $t
6177 $canv raise $t
6178 $canv bind $t <1> {selcanvline {} %x %y}
6179 set rmx [llength [lindex $rowidlist $row]]
6180 set olds [lindex $parentlist $row]
6181 if {$olds ne {}} {
6182 set nextids [lindex $rowidlist [expr {$row + 1}]]
6183 foreach p $olds {
6184 set i [lsearch -exact $nextids $p]
6185 if {$i > $rmx} {
6186 set rmx $i
6190 set xt [xc $row $rmx]
6191 set rowtextx($row) $xt
6192 set idpos($id) [list $x $xt $y]
6193 if {[info exists idtags($id)] || [info exists idheads($id)]
6194 || [info exists idotherrefs($id)]} {
6195 set xt [drawtags $id $x $xt $y]
6197 if {[lindex $commitinfo($id) 6] > 0} {
6198 set xt [drawnotesign $xt $y]
6200 set headline [lindex $commitinfo($id) 0]
6201 set name [lindex $commitinfo($id) 1]
6202 set date [lindex $commitinfo($id) 2]
6203 set date [formatdate $date]
6204 set font mainfont
6205 set nfont mainfont
6206 set isbold [ishighlighted $id]
6207 if {$isbold > 0} {
6208 lappend boldids $id
6209 set font mainfontbold
6210 if {$isbold > 1} {
6211 lappend boldnameids $id
6212 set nfont mainfontbold
6215 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6216 -text $headline -font $font -tags text]
6217 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6218 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6219 -text $name -font $nfont -tags text]
6220 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6221 -text $date -font mainfont -tags text]
6222 if {$selectedline == $row} {
6223 make_secsel $id
6225 if {[info exists markedid] && $markedid eq $id} {
6226 make_idmark $id
6228 set xr [expr {$xt + [font measure $font $headline]}]
6229 if {$xr > $canvxmax} {
6230 set canvxmax $xr
6231 setcanvscroll
6235 proc drawcmitrow {row} {
6236 global displayorder rowidlist nrows_drawn
6237 global iddrawn markingmatches
6238 global commitinfo numcommits
6239 global filehighlight fhighlights findpattern nhighlights
6240 global hlview vhighlights
6241 global highlight_related rhighlights
6243 if {$row >= $numcommits} return
6245 set id [lindex $displayorder $row]
6246 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6247 askvhighlight $row $id
6249 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6250 askfilehighlight $row $id
6252 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6253 askfindhighlight $row $id
6255 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6256 askrelhighlight $row $id
6258 if {![info exists iddrawn($id)]} {
6259 set col [lsearch -exact [lindex $rowidlist $row] $id]
6260 if {$col < 0} {
6261 puts "oops, row $row id $id not in list"
6262 return
6264 if {![info exists commitinfo($id)]} {
6265 getcommit $id
6267 assigncolor $id
6268 drawcmittext $id $row $col
6269 set iddrawn($id) 1
6270 incr nrows_drawn
6272 if {$markingmatches} {
6273 markrowmatches $row $id
6277 proc drawcommits {row {endrow {}}} {
6278 global numcommits iddrawn displayorder curview need_redisplay
6279 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6281 if {$row < 0} {
6282 set row 0
6284 if {$endrow eq {}} {
6285 set endrow $row
6287 if {$endrow >= $numcommits} {
6288 set endrow [expr {$numcommits - 1}]
6291 set rl1 [expr {$row - $downarrowlen - 3}]
6292 if {$rl1 < 0} {
6293 set rl1 0
6295 set ro1 [expr {$row - 3}]
6296 if {$ro1 < 0} {
6297 set ro1 0
6299 set r2 [expr {$endrow + $uparrowlen + 3}]
6300 if {$r2 > $numcommits} {
6301 set r2 $numcommits
6303 for {set r $rl1} {$r < $r2} {incr r} {
6304 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6305 if {$rl1 < $r} {
6306 layoutrows $rl1 $r
6308 set rl1 [expr {$r + 1}]
6311 if {$rl1 < $r} {
6312 layoutrows $rl1 $r
6314 optimize_rows $ro1 0 $r2
6315 if {$need_redisplay || $nrows_drawn > 2000} {
6316 clear_display
6319 # make the lines join to already-drawn rows either side
6320 set r [expr {$row - 1}]
6321 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6322 set r $row
6324 set er [expr {$endrow + 1}]
6325 if {$er >= $numcommits ||
6326 ![info exists iddrawn([lindex $displayorder $er])]} {
6327 set er $endrow
6329 for {} {$r <= $er} {incr r} {
6330 set id [lindex $displayorder $r]
6331 set wasdrawn [info exists iddrawn($id)]
6332 drawcmitrow $r
6333 if {$r == $er} break
6334 set nextid [lindex $displayorder [expr {$r + 1}]]
6335 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6336 drawparentlinks $id $r
6338 set rowids [lindex $rowidlist $r]
6339 foreach lid $rowids {
6340 if {$lid eq {}} continue
6341 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6342 if {$lid eq $id} {
6343 # see if this is the first child of any of its parents
6344 foreach p [lindex $parentlist $r] {
6345 if {[lsearch -exact $rowids $p] < 0} {
6346 # make this line extend up to the child
6347 set lineend($p) [drawlineseg $p $r $er 0]
6350 } else {
6351 set lineend($lid) [drawlineseg $lid $r $er 1]
6357 proc undolayout {row} {
6358 global uparrowlen mingaplen downarrowlen
6359 global rowidlist rowisopt rowfinal need_redisplay
6361 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6362 if {$r < 0} {
6363 set r 0
6365 if {[llength $rowidlist] > $r} {
6366 incr r -1
6367 set rowidlist [lrange $rowidlist 0 $r]
6368 set rowfinal [lrange $rowfinal 0 $r]
6369 set rowisopt [lrange $rowisopt 0 $r]
6370 set need_redisplay 1
6371 run drawvisible
6375 proc drawvisible {} {
6376 global canv linespc curview vrowmod selectedline targetrow targetid
6377 global need_redisplay cscroll numcommits
6379 set fs [$canv yview]
6380 set ymax [lindex [$canv cget -scrollregion] 3]
6381 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6382 set f0 [lindex $fs 0]
6383 set f1 [lindex $fs 1]
6384 set y0 [expr {int($f0 * $ymax)}]
6385 set y1 [expr {int($f1 * $ymax)}]
6387 if {[info exists targetid]} {
6388 if {[commitinview $targetid $curview]} {
6389 set r [rowofcommit $targetid]
6390 if {$r != $targetrow} {
6391 # Fix up the scrollregion and change the scrolling position
6392 # now that our target row has moved.
6393 set diff [expr {($r - $targetrow) * $linespc}]
6394 set targetrow $r
6395 setcanvscroll
6396 set ymax [lindex [$canv cget -scrollregion] 3]
6397 incr y0 $diff
6398 incr y1 $diff
6399 set f0 [expr {$y0 / $ymax}]
6400 set f1 [expr {$y1 / $ymax}]
6401 allcanvs yview moveto $f0
6402 $cscroll set $f0 $f1
6403 set need_redisplay 1
6405 } else {
6406 unset targetid
6410 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6411 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6412 if {$endrow >= $vrowmod($curview)} {
6413 update_arcrows $curview
6415 if {$selectedline ne {} &&
6416 $row <= $selectedline && $selectedline <= $endrow} {
6417 set targetrow $selectedline
6418 } elseif {[info exists targetid]} {
6419 set targetrow [expr {int(($row + $endrow) / 2)}]
6421 if {[info exists targetrow]} {
6422 if {$targetrow >= $numcommits} {
6423 set targetrow [expr {$numcommits - 1}]
6425 set targetid [commitonrow $targetrow]
6427 drawcommits $row $endrow
6430 proc clear_display {} {
6431 global iddrawn linesegs need_redisplay nrows_drawn
6432 global vhighlights fhighlights nhighlights rhighlights
6433 global linehtag linentag linedtag boldids boldnameids
6435 allcanvs delete all
6436 unset -nocomplain iddrawn
6437 unset -nocomplain linesegs
6438 unset -nocomplain linehtag
6439 unset -nocomplain linentag
6440 unset -nocomplain linedtag
6441 set boldids {}
6442 set boldnameids {}
6443 unset -nocomplain vhighlights
6444 unset -nocomplain fhighlights
6445 unset -nocomplain nhighlights
6446 unset -nocomplain rhighlights
6447 set need_redisplay 0
6448 set nrows_drawn 0
6451 proc findcrossings {id} {
6452 global rowidlist parentlist numcommits displayorder
6454 set cross {}
6455 set ccross {}
6456 foreach {s e} [rowranges $id] {
6457 if {$e >= $numcommits} {
6458 set e [expr {$numcommits - 1}]
6460 if {$e <= $s} continue
6461 for {set row $e} {[incr row -1] >= $s} {} {
6462 set x [lsearch -exact [lindex $rowidlist $row] $id]
6463 if {$x < 0} break
6464 set olds [lindex $parentlist $row]
6465 set kid [lindex $displayorder $row]
6466 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6467 if {$kidx < 0} continue
6468 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6469 foreach p $olds {
6470 set px [lsearch -exact $nextrow $p]
6471 if {$px < 0} continue
6472 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6473 if {[lsearch -exact $ccross $p] >= 0} continue
6474 if {$x == $px + ($kidx < $px? -1: 1)} {
6475 lappend ccross $p
6476 } elseif {[lsearch -exact $cross $p] < 0} {
6477 lappend cross $p
6483 return [concat $ccross {{}} $cross]
6486 proc assigncolor {id} {
6487 global colormap colors nextcolor
6488 global parents children children curview
6490 if {[info exists colormap($id)]} return
6491 set ncolors [llength $colors]
6492 if {[info exists children($curview,$id)]} {
6493 set kids $children($curview,$id)
6494 } else {
6495 set kids {}
6497 if {[llength $kids] == 1} {
6498 set child [lindex $kids 0]
6499 if {[info exists colormap($child)]
6500 && [llength $parents($curview,$child)] == 1} {
6501 set colormap($id) $colormap($child)
6502 return
6505 set badcolors {}
6506 set origbad {}
6507 foreach x [findcrossings $id] {
6508 if {$x eq {}} {
6509 # delimiter between corner crossings and other crossings
6510 if {[llength $badcolors] >= $ncolors - 1} break
6511 set origbad $badcolors
6513 if {[info exists colormap($x)]
6514 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6515 lappend badcolors $colormap($x)
6518 if {[llength $badcolors] >= $ncolors} {
6519 set badcolors $origbad
6521 set origbad $badcolors
6522 if {[llength $badcolors] < $ncolors - 1} {
6523 foreach child $kids {
6524 if {[info exists colormap($child)]
6525 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6526 lappend badcolors $colormap($child)
6528 foreach p $parents($curview,$child) {
6529 if {[info exists colormap($p)]
6530 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6531 lappend badcolors $colormap($p)
6535 if {[llength $badcolors] >= $ncolors} {
6536 set badcolors $origbad
6539 for {set i 0} {$i <= $ncolors} {incr i} {
6540 set c [lindex $colors $nextcolor]
6541 if {[incr nextcolor] >= $ncolors} {
6542 set nextcolor 0
6544 if {[lsearch -exact $badcolors $c]} break
6546 set colormap($id) $c
6549 proc bindline {t id} {
6550 global canv
6552 $canv bind $t <Enter> "lineenter %x %y $id"
6553 $canv bind $t <Motion> "linemotion %x %y $id"
6554 $canv bind $t <Leave> "lineleave $id"
6555 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6558 proc graph_pane_width {} {
6559 global use_ttk
6561 if {$use_ttk} {
6562 set g [.tf.histframe.pwclist sashpos 0]
6563 } else {
6564 set g [.tf.histframe.pwclist sash coord 0]
6566 return [lindex $g 0]
6569 proc totalwidth {l font extra} {
6570 set tot 0
6571 foreach str $l {
6572 set tot [expr {$tot + [font measure $font $str] + $extra}]
6574 return $tot
6577 proc drawtags {id x xt y1} {
6578 global idtags idheads idotherrefs mainhead
6579 global linespc lthickness
6580 global canv rowtextx curview fgcolor bgcolor ctxbut
6581 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6582 global tagbgcolor tagfgcolor tagoutlinecolor
6583 global reflinecolor
6585 set marks {}
6586 set ntags 0
6587 set nheads 0
6588 set singletag 0
6589 set maxtags 3
6590 set maxtagpct 25
6591 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6592 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6593 set extra [expr {$delta + $lthickness + $linespc}]
6595 if {[info exists idtags($id)]} {
6596 set marks $idtags($id)
6597 set ntags [llength $marks]
6598 if {$ntags > $maxtags ||
6599 [totalwidth $marks mainfont $extra] > $maxwidth} {
6600 # show just a single "n tags..." tag
6601 set singletag 1
6602 if {$ntags == 1} {
6603 set marks [list "tag..."]
6604 } else {
6605 set marks [list [format "%d tags..." $ntags]]
6607 set ntags 1
6610 if {[info exists idheads($id)]} {
6611 set marks [concat $marks $idheads($id)]
6612 set nheads [llength $idheads($id)]
6614 if {[info exists idotherrefs($id)]} {
6615 set marks [concat $marks $idotherrefs($id)]
6617 if {$marks eq {}} {
6618 return $xt
6621 set yt [expr {$y1 - 0.5 * $linespc}]
6622 set yb [expr {$yt + $linespc - 1}]
6623 set xvals {}
6624 set wvals {}
6625 set i -1
6626 foreach tag $marks {
6627 incr i
6628 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6629 set wid [font measure mainfontbold $tag]
6630 } else {
6631 set wid [font measure mainfont $tag]
6633 lappend xvals $xt
6634 lappend wvals $wid
6635 set xt [expr {$xt + $wid + $extra}]
6637 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6638 -width $lthickness -fill $reflinecolor -tags tag.$id]
6639 $canv lower $t
6640 foreach tag $marks x $xvals wid $wvals {
6641 set tag_quoted [string map {% %%} $tag]
6642 set xl [expr {$x + $delta}]
6643 set xr [expr {$x + $delta + $wid + $lthickness}]
6644 set font mainfont
6645 if {[incr ntags -1] >= 0} {
6646 # draw a tag
6647 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6648 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6649 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6650 -tags tag.$id]
6651 if {$singletag} {
6652 set tagclick [list showtags $id 1]
6653 } else {
6654 set tagclick [list showtag $tag_quoted 1]
6656 $canv bind $t <1> $tagclick
6657 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6658 } else {
6659 # draw a head or other ref
6660 if {[incr nheads -1] >= 0} {
6661 set col $headbgcolor
6662 if {$tag eq $mainhead} {
6663 set font mainfontbold
6665 } else {
6666 set col "#ddddff"
6668 set xl [expr {$xl - $delta/2}]
6669 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6670 -width 1 -outline black -fill $col -tags tag.$id
6671 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6672 set rwid [font measure mainfont $remoteprefix]
6673 set xi [expr {$x + 1}]
6674 set yti [expr {$yt + 1}]
6675 set xri [expr {$x + $rwid}]
6676 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6677 -width 0 -fill $remotebgcolor -tags tag.$id
6680 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6681 -font $font -tags [list tag.$id text]]
6682 if {$ntags >= 0} {
6683 $canv bind $t <1> $tagclick
6684 } elseif {$nheads >= 0} {
6685 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6688 return $xt
6691 proc drawnotesign {xt y} {
6692 global linespc canv fgcolor
6694 set orad [expr {$linespc / 3}]
6695 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6696 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6697 -fill yellow -outline $fgcolor -width 1 -tags circle]
6698 set xt [expr {$xt + $orad * 3}]
6699 return $xt
6702 proc xcoord {i level ln} {
6703 global canvx0 xspc1 xspc2
6705 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6706 if {$i > 0 && $i == $level} {
6707 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6708 } elseif {$i > $level} {
6709 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6711 return $x
6714 proc show_status {msg} {
6715 global canv fgcolor
6717 clear_display
6718 set_window_title
6719 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6720 -tags text -fill $fgcolor
6723 # Don't change the text pane cursor if it is currently the hand cursor,
6724 # showing that we are over a sha1 ID link.
6725 proc settextcursor {c} {
6726 global ctext curtextcursor
6728 if {[$ctext cget -cursor] == $curtextcursor} {
6729 $ctext config -cursor $c
6731 set curtextcursor $c
6734 proc nowbusy {what {name {}}} {
6735 global isbusy busyname statusw
6737 if {[array names isbusy] eq {}} {
6738 . config -cursor watch
6739 settextcursor watch
6741 set isbusy($what) 1
6742 set busyname($what) $name
6743 if {$name ne {}} {
6744 $statusw conf -text $name
6748 proc notbusy {what} {
6749 global isbusy maincursor textcursor busyname statusw
6751 catch {
6752 unset isbusy($what)
6753 if {$busyname($what) ne {} &&
6754 [$statusw cget -text] eq $busyname($what)} {
6755 $statusw conf -text {}
6758 if {[array names isbusy] eq {}} {
6759 . config -cursor $maincursor
6760 settextcursor $textcursor
6764 proc findmatches {f} {
6765 global findtype findstring
6766 if {$findtype == [mc "Regexp"]} {
6767 set matches [regexp -indices -all -inline $findstring $f]
6768 } else {
6769 set fs $findstring
6770 if {$findtype == [mc "IgnCase"]} {
6771 set f [string tolower $f]
6772 set fs [string tolower $fs]
6774 set matches {}
6775 set i 0
6776 set l [string length $fs]
6777 while {[set j [string first $fs $f $i]] >= 0} {
6778 lappend matches [list $j [expr {$j+$l-1}]]
6779 set i [expr {$j + $l}]
6782 return $matches
6785 proc dofind {{dirn 1} {wrap 1}} {
6786 global findstring findstartline findcurline selectedline numcommits
6787 global gdttype filehighlight fh_serial find_dirn findallowwrap
6789 if {[info exists find_dirn]} {
6790 if {$find_dirn == $dirn} return
6791 stopfinding
6793 focus .
6794 if {$findstring eq {} || $numcommits == 0} return
6795 if {$selectedline eq {}} {
6796 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6797 } else {
6798 set findstartline $selectedline
6800 set findcurline $findstartline
6801 nowbusy finding [mc "Searching"]
6802 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6803 after cancel do_file_hl $fh_serial
6804 do_file_hl $fh_serial
6806 set find_dirn $dirn
6807 set findallowwrap $wrap
6808 run findmore
6811 proc stopfinding {} {
6812 global find_dirn findcurline fprogcoord
6814 if {[info exists find_dirn]} {
6815 unset find_dirn
6816 unset findcurline
6817 notbusy finding
6818 set fprogcoord 0
6819 adjustprogress
6821 stopblaming
6824 proc findmore {} {
6825 global commitdata commitinfo numcommits findpattern findloc
6826 global findstartline findcurline findallowwrap
6827 global find_dirn gdttype fhighlights fprogcoord
6828 global curview varcorder vrownum varccommits vrowmod
6830 if {![info exists find_dirn]} {
6831 return 0
6833 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6834 set l $findcurline
6835 set moretodo 0
6836 if {$find_dirn > 0} {
6837 incr l
6838 if {$l >= $numcommits} {
6839 set l 0
6841 if {$l <= $findstartline} {
6842 set lim [expr {$findstartline + 1}]
6843 } else {
6844 set lim $numcommits
6845 set moretodo $findallowwrap
6847 } else {
6848 if {$l == 0} {
6849 set l $numcommits
6851 incr l -1
6852 if {$l >= $findstartline} {
6853 set lim [expr {$findstartline - 1}]
6854 } else {
6855 set lim -1
6856 set moretodo $findallowwrap
6859 set n [expr {($lim - $l) * $find_dirn}]
6860 if {$n > 500} {
6861 set n 500
6862 set moretodo 1
6864 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6865 update_arcrows $curview
6867 set found 0
6868 set domore 1
6869 set ai [bsearch $vrownum($curview) $l]
6870 set a [lindex $varcorder($curview) $ai]
6871 set arow [lindex $vrownum($curview) $ai]
6872 set ids [lindex $varccommits($curview,$a)]
6873 set arowend [expr {$arow + [llength $ids]}]
6874 if {$gdttype eq [mc "containing:"]} {
6875 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6876 if {$l < $arow || $l >= $arowend} {
6877 incr ai $find_dirn
6878 set a [lindex $varcorder($curview) $ai]
6879 set arow [lindex $vrownum($curview) $ai]
6880 set ids [lindex $varccommits($curview,$a)]
6881 set arowend [expr {$arow + [llength $ids]}]
6883 set id [lindex $ids [expr {$l - $arow}]]
6884 # shouldn't happen unless git log doesn't give all the commits...
6885 if {![info exists commitdata($id)] ||
6886 ![doesmatch $commitdata($id)]} {
6887 continue
6889 if {![info exists commitinfo($id)]} {
6890 getcommit $id
6892 set info $commitinfo($id)
6893 foreach f $info ty $fldtypes {
6894 if {$ty eq ""} continue
6895 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6896 [doesmatch $f]} {
6897 set found 1
6898 break
6901 if {$found} break
6903 } else {
6904 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6905 if {$l < $arow || $l >= $arowend} {
6906 incr ai $find_dirn
6907 set a [lindex $varcorder($curview) $ai]
6908 set arow [lindex $vrownum($curview) $ai]
6909 set ids [lindex $varccommits($curview,$a)]
6910 set arowend [expr {$arow + [llength $ids]}]
6912 set id [lindex $ids [expr {$l - $arow}]]
6913 if {![info exists fhighlights($id)]} {
6914 # this sets fhighlights($id) to -1
6915 askfilehighlight $l $id
6917 if {$fhighlights($id) > 0} {
6918 set found $domore
6919 break
6921 if {$fhighlights($id) < 0} {
6922 if {$domore} {
6923 set domore 0
6924 set findcurline [expr {$l - $find_dirn}]
6929 if {$found || ($domore && !$moretodo)} {
6930 unset findcurline
6931 unset find_dirn
6932 notbusy finding
6933 set fprogcoord 0
6934 adjustprogress
6935 if {$found} {
6936 findselectline $l
6937 } else {
6938 bell
6940 return 0
6942 if {!$domore} {
6943 flushhighlights
6944 } else {
6945 set findcurline [expr {$l - $find_dirn}]
6947 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6948 if {$n < 0} {
6949 incr n $numcommits
6951 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6952 adjustprogress
6953 return $domore
6956 proc findselectline {l} {
6957 global findloc commentend ctext findcurline markingmatches gdttype
6959 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6960 set findcurline $l
6961 selectline $l 1
6962 if {$markingmatches &&
6963 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6964 # highlight the matches in the comments
6965 set f [$ctext get 1.0 $commentend]
6966 set matches [findmatches $f]
6967 foreach match $matches {
6968 set start [lindex $match 0]
6969 set end [expr {[lindex $match 1] + 1}]
6970 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6973 drawvisible
6976 # mark the bits of a headline or author that match a find string
6977 proc markmatches {canv l str tag matches font row} {
6978 global selectedline
6980 set bbox [$canv bbox $tag]
6981 set x0 [lindex $bbox 0]
6982 set y0 [lindex $bbox 1]
6983 set y1 [lindex $bbox 3]
6984 foreach match $matches {
6985 set start [lindex $match 0]
6986 set end [lindex $match 1]
6987 if {$start > $end} continue
6988 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6989 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6990 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6991 [expr {$x0+$xlen+2}] $y1 \
6992 -outline {} -tags [list match$l matches] -fill yellow]
6993 $canv lower $t
6994 if {$row == $selectedline} {
6995 $canv raise $t secsel
7000 proc unmarkmatches {} {
7001 global markingmatches
7003 allcanvs delete matches
7004 set markingmatches 0
7005 stopfinding
7008 proc selcanvline {w x y} {
7009 global canv canvy0 ctext linespc
7010 global rowtextx
7011 set ymax [lindex [$canv cget -scrollregion] 3]
7012 if {$ymax == {}} return
7013 set yfrac [lindex [$canv yview] 0]
7014 set y [expr {$y + $yfrac * $ymax}]
7015 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
7016 if {$l < 0} {
7017 set l 0
7019 if {$w eq $canv} {
7020 set xmax [lindex [$canv cget -scrollregion] 2]
7021 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
7022 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
7024 unmarkmatches
7025 selectline $l 1
7028 proc commit_descriptor {p} {
7029 global commitinfo
7030 if {![info exists commitinfo($p)]} {
7031 getcommit $p
7033 set l "..."
7034 if {[llength $commitinfo($p)] > 1} {
7035 set l [lindex $commitinfo($p) 0]
7037 return "$p ($l)\n"
7040 # append some text to the ctext widget, and make any SHA1 ID
7041 # that we know about be a clickable link.
7042 # Also look for URLs of the form "http[s]://..." and make them web links.
7043 proc appendwithlinks {text tags} {
7044 global ctext linknum curview
7046 set start [$ctext index "end - 1c"]
7047 $ctext insert end $text $tags
7048 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
7049 foreach l $links {
7050 set s [lindex $l 0]
7051 set e [lindex $l 1]
7052 set linkid [string range $text $s $e]
7053 incr e
7054 $ctext tag delete link$linknum
7055 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7056 setlink $linkid link$linknum
7057 incr linknum
7059 set wlinks [regexp -indices -all -inline -line \
7060 {https?://[^[:space:]]+} $text]
7061 foreach l $wlinks {
7062 set s2 [lindex $l 0]
7063 set e2 [lindex $l 1]
7064 set url [string range $text $s2 $e2]
7065 incr e2
7066 $ctext tag delete link$linknum
7067 $ctext tag add link$linknum "$start + $s2 c" "$start + $e2 c"
7068 setwlink $url link$linknum
7069 incr linknum
7073 proc setlink {id lk} {
7074 global curview ctext pendinglinks
7075 global linkfgcolor
7077 if {[string range $id 0 1] eq "-g"} {
7078 set id [string range $id 2 end]
7081 set known 0
7082 if {[string length $id] < 40} {
7083 set matches [longid $id]
7084 if {[llength $matches] > 0} {
7085 if {[llength $matches] > 1} return
7086 set known 1
7087 set id [lindex $matches 0]
7089 } else {
7090 set known [commitinview $id $curview]
7092 if {$known} {
7093 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7094 $ctext tag bind $lk <1> [list selbyid $id]
7095 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7096 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7097 } else {
7098 lappend pendinglinks($id) $lk
7099 interestedin $id {makelink %P}
7103 proc setwlink {url lk} {
7104 global ctext
7105 global linkfgcolor
7106 global web_browser
7108 if {$web_browser eq {}} return
7109 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7110 $ctext tag bind $lk <1> [list browseweb $url]
7111 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7112 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7115 proc appendshortlink {id {pre {}} {post {}}} {
7116 global ctext linknum
7118 $ctext insert end $pre
7119 $ctext tag delete link$linknum
7120 $ctext insert end [string range $id 0 7] link$linknum
7121 $ctext insert end $post
7122 setlink $id link$linknum
7123 incr linknum
7126 proc makelink {id} {
7127 global pendinglinks
7129 if {![info exists pendinglinks($id)]} return
7130 foreach lk $pendinglinks($id) {
7131 setlink $id $lk
7133 unset pendinglinks($id)
7136 proc linkcursor {w inc} {
7137 global linkentercount curtextcursor
7139 if {[incr linkentercount $inc] > 0} {
7140 $w configure -cursor hand2
7141 } else {
7142 $w configure -cursor $curtextcursor
7143 if {$linkentercount < 0} {
7144 set linkentercount 0
7149 proc browseweb {url} {
7150 global web_browser
7152 if {$web_browser eq {}} return
7153 # Use eval here in case $web_browser is a command plus some arguments
7154 if {[catch {eval exec $web_browser [list $url] &} err]} {
7155 error_popup "[mc "Error starting web browser:"] $err"
7159 proc viewnextline {dir} {
7160 global canv linespc
7162 $canv delete hover
7163 set ymax [lindex [$canv cget -scrollregion] 3]
7164 set wnow [$canv yview]
7165 set wtop [expr {[lindex $wnow 0] * $ymax}]
7166 set newtop [expr {$wtop + $dir * $linespc}]
7167 if {$newtop < 0} {
7168 set newtop 0
7169 } elseif {$newtop > $ymax} {
7170 set newtop $ymax
7172 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7175 # add a list of tag or branch names at position pos
7176 # returns the number of names inserted
7177 proc appendrefs {pos ids var} {
7178 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7180 if {[catch {$ctext index $pos}]} {
7181 return 0
7183 $ctext conf -state normal
7184 $ctext delete $pos "$pos lineend"
7185 set tags {}
7186 foreach id $ids {
7187 foreach tag [set $var\($id\)] {
7188 lappend tags [list $tag $id]
7192 set sep {}
7193 set tags [lsort -index 0 -decreasing $tags]
7194 set nutags 0
7196 if {[llength $tags] > $maxrefs} {
7197 # If we are displaying heads, and there are too many,
7198 # see if there are some important heads to display.
7199 # Currently that are the current head and heads listed in $visiblerefs option
7200 set itags {}
7201 if {$var eq "idheads"} {
7202 set utags {}
7203 foreach ti $tags {
7204 set hname [lindex $ti 0]
7205 set id [lindex $ti 1]
7206 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7207 [llength $itags] < $maxrefs} {
7208 lappend itags $ti
7209 } else {
7210 lappend utags $ti
7213 set tags $utags
7215 if {$itags ne {}} {
7216 set str [mc "and many more"]
7217 set sep " "
7218 } else {
7219 set str [mc "many"]
7221 $ctext insert $pos "$str ([llength $tags])"
7222 set nutags [llength $tags]
7223 set tags $itags
7226 foreach ti $tags {
7227 set id [lindex $ti 1]
7228 set lk link$linknum
7229 incr linknum
7230 $ctext tag delete $lk
7231 $ctext insert $pos $sep
7232 $ctext insert $pos [lindex $ti 0] $lk
7233 setlink $id $lk
7234 set sep ", "
7236 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7237 $ctext conf -state disabled
7238 return [expr {[llength $tags] + $nutags}]
7241 # called when we have finished computing the nearby tags
7242 proc dispneartags {delay} {
7243 global selectedline currentid showneartags tagphase
7245 if {$selectedline eq {} || !$showneartags} return
7246 after cancel dispnexttag
7247 if {$delay} {
7248 after 200 dispnexttag
7249 set tagphase -1
7250 } else {
7251 after idle dispnexttag
7252 set tagphase 0
7256 proc dispnexttag {} {
7257 global selectedline currentid showneartags tagphase ctext
7259 if {$selectedline eq {} || !$showneartags} return
7260 switch -- $tagphase {
7262 set dtags [desctags $currentid]
7263 if {$dtags ne {}} {
7264 appendrefs precedes $dtags idtags
7268 set atags [anctags $currentid]
7269 if {$atags ne {}} {
7270 appendrefs follows $atags idtags
7274 set dheads [descheads $currentid]
7275 if {$dheads ne {}} {
7276 if {[appendrefs branch $dheads idheads] > 1
7277 && [$ctext get "branch -3c"] eq "h"} {
7278 # turn "Branch" into "Branches"
7279 $ctext conf -state normal
7280 $ctext insert "branch -2c" "es"
7281 $ctext conf -state disabled
7286 if {[incr tagphase] <= 2} {
7287 after idle dispnexttag
7291 proc make_secsel {id} {
7292 global linehtag linentag linedtag canv canv2 canv3
7294 if {![info exists linehtag($id)]} return
7295 $canv delete secsel
7296 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7297 -tags secsel -fill [$canv cget -selectbackground]]
7298 $canv lower $t
7299 $canv2 delete secsel
7300 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7301 -tags secsel -fill [$canv2 cget -selectbackground]]
7302 $canv2 lower $t
7303 $canv3 delete secsel
7304 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7305 -tags secsel -fill [$canv3 cget -selectbackground]]
7306 $canv3 lower $t
7309 proc make_idmark {id} {
7310 global linehtag canv fgcolor
7312 if {![info exists linehtag($id)]} return
7313 $canv delete markid
7314 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7315 -tags markid -outline $fgcolor]
7316 $canv raise $t
7319 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7320 global canv ctext commitinfo selectedline
7321 global canvy0 linespc parents children curview
7322 global currentid sha1entry
7323 global commentend idtags linknum
7324 global mergemax numcommits pending_select
7325 global cmitmode showneartags allcommits
7326 global targetrow targetid lastscrollrows
7327 global autoselect autosellen jump_to_here
7328 global vinlinediff
7330 unset -nocomplain pending_select
7331 $canv delete hover
7332 normalline
7333 unsel_reflist
7334 stopfinding
7335 if {$l < 0 || $l >= $numcommits} return
7336 set id [commitonrow $l]
7337 set targetid $id
7338 set targetrow $l
7339 set selectedline $l
7340 set currentid $id
7341 if {$lastscrollrows < $numcommits} {
7342 setcanvscroll
7345 if {$cmitmode ne "patch" && $switch_to_patch} {
7346 set cmitmode "patch"
7349 set y [expr {$canvy0 + $l * $linespc}]
7350 set ymax [lindex [$canv cget -scrollregion] 3]
7351 set ytop [expr {$y - $linespc - 1}]
7352 set ybot [expr {$y + $linespc + 1}]
7353 set wnow [$canv yview]
7354 set wtop [expr {[lindex $wnow 0] * $ymax}]
7355 set wbot [expr {[lindex $wnow 1] * $ymax}]
7356 set wh [expr {$wbot - $wtop}]
7357 set newtop $wtop
7358 if {$ytop < $wtop} {
7359 if {$ybot < $wtop} {
7360 set newtop [expr {$y - $wh / 2.0}]
7361 } else {
7362 set newtop $ytop
7363 if {$newtop > $wtop - $linespc} {
7364 set newtop [expr {$wtop - $linespc}]
7367 } elseif {$ybot > $wbot} {
7368 if {$ytop > $wbot} {
7369 set newtop [expr {$y - $wh / 2.0}]
7370 } else {
7371 set newtop [expr {$ybot - $wh}]
7372 if {$newtop < $wtop + $linespc} {
7373 set newtop [expr {$wtop + $linespc}]
7377 if {$newtop != $wtop} {
7378 if {$newtop < 0} {
7379 set newtop 0
7381 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7382 drawvisible
7385 make_secsel $id
7387 if {$isnew} {
7388 addtohistory [list selbyid $id 0] savecmitpos
7391 $sha1entry delete 0 end
7392 $sha1entry insert 0 $id
7393 if {$autoselect} {
7394 $sha1entry selection range 0 $autosellen
7396 rhighlight_sel $id
7398 $ctext conf -state normal
7399 clear_ctext
7400 set linknum 0
7401 if {![info exists commitinfo($id)]} {
7402 getcommit $id
7404 set info $commitinfo($id)
7405 set date [formatdate [lindex $info 2]]
7406 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7407 set date [formatdate [lindex $info 4]]
7408 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7409 if {[info exists idtags($id)]} {
7410 $ctext insert end [mc "Tags:"]
7411 foreach tag $idtags($id) {
7412 $ctext insert end " $tag"
7414 $ctext insert end "\n"
7417 set headers {}
7418 set olds $parents($curview,$id)
7419 if {[llength $olds] > 1} {
7420 set np 0
7421 foreach p $olds {
7422 if {$np >= $mergemax} {
7423 set tag mmax
7424 } else {
7425 set tag m$np
7427 $ctext insert end "[mc "Parent"]: " $tag
7428 appendwithlinks [commit_descriptor $p] {}
7429 incr np
7431 } else {
7432 foreach p $olds {
7433 append headers "[mc "Parent"]: [commit_descriptor $p]"
7437 foreach c $children($curview,$id) {
7438 append headers "[mc "Child"]: [commit_descriptor $c]"
7441 # make anything that looks like a SHA1 ID be a clickable link
7442 appendwithlinks $headers {}
7443 if {$showneartags} {
7444 if {![info exists allcommits]} {
7445 getallcommits
7447 $ctext insert end "[mc "Branch"]: "
7448 $ctext mark set branch "end -1c"
7449 $ctext mark gravity branch left
7450 $ctext insert end "\n[mc "Follows"]: "
7451 $ctext mark set follows "end -1c"
7452 $ctext mark gravity follows left
7453 $ctext insert end "\n[mc "Precedes"]: "
7454 $ctext mark set precedes "end -1c"
7455 $ctext mark gravity precedes left
7456 $ctext insert end "\n"
7457 dispneartags 1
7459 $ctext insert end "\n"
7460 set comment [lindex $info 5]
7461 if {[string first "\r" $comment] >= 0} {
7462 set comment [string map {"\r" "\n "} $comment]
7464 appendwithlinks $comment {comment}
7466 $ctext tag remove found 1.0 end
7467 $ctext conf -state disabled
7468 set commentend [$ctext index "end - 1c"]
7470 set jump_to_here $desired_loc
7471 init_flist [mc "Comments"]
7472 if {$cmitmode eq "tree"} {
7473 gettree $id
7474 } elseif {$vinlinediff($curview) == 1} {
7475 showinlinediff $id
7476 } elseif {[llength $olds] <= 1} {
7477 startdiff $id
7478 } else {
7479 mergediff $id
7483 proc selfirstline {} {
7484 unmarkmatches
7485 selectline 0 1
7488 proc sellastline {} {
7489 global numcommits
7490 unmarkmatches
7491 set l [expr {$numcommits - 1}]
7492 selectline $l 1
7495 proc selnextline {dir} {
7496 global selectedline
7497 focus .
7498 if {$selectedline eq {}} return
7499 set l [expr {$selectedline + $dir}]
7500 unmarkmatches
7501 selectline $l 1
7504 proc selnextpage {dir} {
7505 global canv linespc selectedline numcommits
7507 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7508 if {$lpp < 1} {
7509 set lpp 1
7511 allcanvs yview scroll [expr {$dir * $lpp}] units
7512 drawvisible
7513 if {$selectedline eq {}} return
7514 set l [expr {$selectedline + $dir * $lpp}]
7515 if {$l < 0} {
7516 set l 0
7517 } elseif {$l >= $numcommits} {
7518 set l [expr $numcommits - 1]
7520 unmarkmatches
7521 selectline $l 1
7524 proc unselectline {} {
7525 global selectedline currentid
7527 set selectedline {}
7528 unset -nocomplain currentid
7529 allcanvs delete secsel
7530 rhighlight_none
7533 proc reselectline {} {
7534 global selectedline
7536 if {$selectedline ne {}} {
7537 selectline $selectedline 0
7541 proc addtohistory {cmd {saveproc {}}} {
7542 global history historyindex curview
7544 unset_posvars
7545 save_position
7546 set elt [list $curview $cmd $saveproc {}]
7547 if {$historyindex > 0
7548 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7549 return
7552 if {$historyindex < [llength $history]} {
7553 set history [lreplace $history $historyindex end $elt]
7554 } else {
7555 lappend history $elt
7557 incr historyindex
7558 if {$historyindex > 1} {
7559 .tf.bar.leftbut conf -state normal
7560 } else {
7561 .tf.bar.leftbut conf -state disabled
7563 .tf.bar.rightbut conf -state disabled
7566 # save the scrolling position of the diff display pane
7567 proc save_position {} {
7568 global historyindex history
7570 if {$historyindex < 1} return
7571 set hi [expr {$historyindex - 1}]
7572 set fn [lindex $history $hi 2]
7573 if {$fn ne {}} {
7574 lset history $hi 3 [eval $fn]
7578 proc unset_posvars {} {
7579 global last_posvars
7581 if {[info exists last_posvars]} {
7582 foreach {var val} $last_posvars {
7583 global $var
7584 unset -nocomplain $var
7586 unset last_posvars
7590 proc godo {elt} {
7591 global curview last_posvars
7593 set view [lindex $elt 0]
7594 set cmd [lindex $elt 1]
7595 set pv [lindex $elt 3]
7596 if {$curview != $view} {
7597 showview $view
7599 unset_posvars
7600 foreach {var val} $pv {
7601 global $var
7602 set $var $val
7604 set last_posvars $pv
7605 eval $cmd
7608 proc goback {} {
7609 global history historyindex
7610 focus .
7612 if {$historyindex > 1} {
7613 save_position
7614 incr historyindex -1
7615 godo [lindex $history [expr {$historyindex - 1}]]
7616 .tf.bar.rightbut conf -state normal
7618 if {$historyindex <= 1} {
7619 .tf.bar.leftbut conf -state disabled
7623 proc goforw {} {
7624 global history historyindex
7625 focus .
7627 if {$historyindex < [llength $history]} {
7628 save_position
7629 set cmd [lindex $history $historyindex]
7630 incr historyindex
7631 godo $cmd
7632 .tf.bar.leftbut conf -state normal
7634 if {$historyindex >= [llength $history]} {
7635 .tf.bar.rightbut conf -state disabled
7639 proc go_to_parent {i} {
7640 global parents curview targetid
7641 set ps $parents($curview,$targetid)
7642 if {[llength $ps] >= $i} {
7643 selbyid [lindex $ps [expr $i - 1]]
7647 proc gettree {id} {
7648 global treefilelist treeidlist diffids diffmergeid treepending
7649 global nullid nullid2
7651 set diffids $id
7652 unset -nocomplain diffmergeid
7653 if {![info exists treefilelist($id)]} {
7654 if {![info exists treepending]} {
7655 if {$id eq $nullid} {
7656 set cmd [list | git ls-files]
7657 } elseif {$id eq $nullid2} {
7658 set cmd [list | git ls-files --stage -t]
7659 } else {
7660 set cmd [list | git ls-tree -r $id]
7662 if {[catch {set gtf [open $cmd r]}]} {
7663 return
7665 set treepending $id
7666 set treefilelist($id) {}
7667 set treeidlist($id) {}
7668 fconfigure $gtf -blocking 0 -encoding binary
7669 filerun $gtf [list gettreeline $gtf $id]
7671 } else {
7672 setfilelist $id
7676 proc gettreeline {gtf id} {
7677 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7679 set nl 0
7680 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7681 if {$diffids eq $nullid} {
7682 set fname $line
7683 } else {
7684 set i [string first "\t" $line]
7685 if {$i < 0} continue
7686 set fname [string range $line [expr {$i+1}] end]
7687 set line [string range $line 0 [expr {$i-1}]]
7688 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7689 set sha1 [lindex $line 2]
7690 lappend treeidlist($id) $sha1
7692 if {[string index $fname 0] eq "\""} {
7693 set fname [lindex $fname 0]
7695 set fname [encoding convertfrom $fname]
7696 lappend treefilelist($id) $fname
7698 if {![eof $gtf]} {
7699 return [expr {$nl >= 1000? 2: 1}]
7701 close $gtf
7702 unset treepending
7703 if {$cmitmode ne "tree"} {
7704 if {![info exists diffmergeid]} {
7705 gettreediffs $diffids
7707 } elseif {$id ne $diffids} {
7708 gettree $diffids
7709 } else {
7710 setfilelist $id
7712 return 0
7715 proc showfile {f} {
7716 global treefilelist treeidlist diffids nullid nullid2
7717 global ctext_file_names ctext_file_lines
7718 global ctext commentend
7720 set i [lsearch -exact $treefilelist($diffids) $f]
7721 if {$i < 0} {
7722 puts "oops, $f not in list for id $diffids"
7723 return
7725 if {$diffids eq $nullid} {
7726 if {[catch {set bf [open $f r]} err]} {
7727 puts "oops, can't read $f: $err"
7728 return
7730 } else {
7731 set blob [lindex $treeidlist($diffids) $i]
7732 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7733 puts "oops, error reading blob $blob: $err"
7734 return
7737 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7738 filerun $bf [list getblobline $bf $diffids]
7739 $ctext config -state normal
7740 clear_ctext $commentend
7741 lappend ctext_file_names $f
7742 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7743 $ctext insert end "\n"
7744 $ctext insert end "$f\n" filesep
7745 $ctext config -state disabled
7746 $ctext yview $commentend
7747 settabs 0
7750 proc getblobline {bf id} {
7751 global diffids cmitmode ctext
7753 if {$id ne $diffids || $cmitmode ne "tree"} {
7754 catch {close $bf}
7755 return 0
7757 $ctext config -state normal
7758 set nl 0
7759 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7760 $ctext insert end "$line\n"
7762 if {[eof $bf]} {
7763 global jump_to_here ctext_file_names commentend
7765 # delete last newline
7766 $ctext delete "end - 2c" "end - 1c"
7767 close $bf
7768 if {$jump_to_here ne {} &&
7769 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7770 set lnum [expr {[lindex $jump_to_here 1] +
7771 [lindex [split $commentend .] 0]}]
7772 mark_ctext_line $lnum
7774 $ctext config -state disabled
7775 return 0
7777 $ctext config -state disabled
7778 return [expr {$nl >= 1000? 2: 1}]
7781 proc mark_ctext_line {lnum} {
7782 global ctext markbgcolor
7784 $ctext tag delete omark
7785 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7786 $ctext tag conf omark -background $markbgcolor
7787 $ctext see $lnum.0
7790 proc mergediff {id} {
7791 global diffmergeid
7792 global diffids treediffs
7793 global parents curview
7795 set diffmergeid $id
7796 set diffids $id
7797 set treediffs($id) {}
7798 set np [llength $parents($curview,$id)]
7799 settabs $np
7800 getblobdiffs $id
7803 proc startdiff {ids} {
7804 global treediffs diffids treepending diffmergeid nullid nullid2
7806 settabs 1
7807 set diffids $ids
7808 unset -nocomplain diffmergeid
7809 if {![info exists treediffs($ids)] ||
7810 [lsearch -exact $ids $nullid] >= 0 ||
7811 [lsearch -exact $ids $nullid2] >= 0} {
7812 if {![info exists treepending]} {
7813 gettreediffs $ids
7815 } else {
7816 addtocflist $ids
7820 proc showinlinediff {ids} {
7821 global commitinfo commitdata ctext
7822 global treediffs
7824 set info $commitinfo($ids)
7825 set diff [lindex $info 7]
7826 set difflines [split $diff "\n"]
7828 initblobdiffvars
7829 set treediff {}
7831 set inhdr 0
7832 foreach line $difflines {
7833 if {![string compare -length 5 "diff " $line]} {
7834 set inhdr 1
7835 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7836 # offset also accounts for the b/ prefix
7837 lappend treediff [string range $line 6 end]
7838 set inhdr 0
7842 set treediffs($ids) $treediff
7843 add_flist $treediff
7845 $ctext conf -state normal
7846 foreach line $difflines {
7847 parseblobdiffline $ids $line
7849 maybe_scroll_ctext 1
7850 $ctext conf -state disabled
7853 # If the filename (name) is under any of the passed filter paths
7854 # then return true to include the file in the listing.
7855 proc path_filter {filter name} {
7856 set worktree [gitworktree]
7857 foreach p $filter {
7858 set fq_p [file normalize $p]
7859 set fq_n [file normalize [file join $worktree $name]]
7860 if {[string match [file normalize $fq_p]* $fq_n]} {
7861 return 1
7864 return 0
7867 proc addtocflist {ids} {
7868 global treediffs
7870 add_flist $treediffs($ids)
7871 getblobdiffs $ids
7874 proc diffcmd {ids flags} {
7875 global log_showroot nullid nullid2 git_version
7877 set i [lsearch -exact $ids $nullid]
7878 set j [lsearch -exact $ids $nullid2]
7879 if {$i >= 0} {
7880 if {[llength $ids] > 1 && $j < 0} {
7881 # comparing working directory with some specific revision
7882 set cmd [concat | git diff-index $flags]
7883 if {$i == 0} {
7884 lappend cmd -R [lindex $ids 1]
7885 } else {
7886 lappend cmd [lindex $ids 0]
7888 } else {
7889 # comparing working directory with index
7890 set cmd [concat | git diff-files $flags]
7891 if {$j == 1} {
7892 lappend cmd -R
7895 } elseif {$j >= 0} {
7896 if {[package vcompare $git_version "1.7.2"] >= 0} {
7897 set flags "$flags --ignore-submodules=dirty"
7899 set cmd [concat | git diff-index --cached $flags]
7900 if {[llength $ids] > 1} {
7901 # comparing index with specific revision
7902 if {$j == 0} {
7903 lappend cmd -R [lindex $ids 1]
7904 } else {
7905 lappend cmd [lindex $ids 0]
7907 } else {
7908 # comparing index with HEAD
7909 lappend cmd HEAD
7911 } else {
7912 if {$log_showroot} {
7913 lappend flags --root
7915 set cmd [concat | git diff-tree -r $flags $ids]
7917 return $cmd
7920 proc gettreediffs {ids} {
7921 global treediff treepending limitdiffs vfilelimit curview
7923 set cmd [diffcmd $ids {--no-commit-id}]
7924 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7925 set cmd [concat $cmd -- $vfilelimit($curview)]
7927 if {[catch {set gdtf [open $cmd r]}]} return
7929 set treepending $ids
7930 set treediff {}
7931 fconfigure $gdtf -blocking 0 -encoding binary
7932 filerun $gdtf [list gettreediffline $gdtf $ids]
7935 proc gettreediffline {gdtf ids} {
7936 global treediff treediffs treepending diffids diffmergeid
7937 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7939 set nr 0
7940 set sublist {}
7941 set max 1000
7942 if {$perfile_attrs} {
7943 # cache_gitattr is slow, and even slower on win32 where we
7944 # have to invoke it for only about 30 paths at a time
7945 set max 500
7946 if {[tk windowingsystem] == "win32"} {
7947 set max 120
7950 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7951 set i [string first "\t" $line]
7952 if {$i >= 0} {
7953 set file [string range $line [expr {$i+1}] end]
7954 if {[string index $file 0] eq "\""} {
7955 set file [lindex $file 0]
7957 set file [encoding convertfrom $file]
7958 if {$file ne [lindex $treediff end]} {
7959 lappend treediff $file
7960 lappend sublist $file
7964 if {$perfile_attrs} {
7965 cache_gitattr encoding $sublist
7967 if {![eof $gdtf]} {
7968 return [expr {$nr >= $max? 2: 1}]
7970 close $gdtf
7971 set treediffs($ids) $treediff
7972 unset treepending
7973 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7974 gettree $diffids
7975 } elseif {$ids != $diffids} {
7976 if {![info exists diffmergeid]} {
7977 gettreediffs $diffids
7979 } else {
7980 addtocflist $ids
7982 return 0
7985 # empty string or positive integer
7986 proc diffcontextvalidate {v} {
7987 return [regexp {^(|[1-9][0-9]*)$} $v]
7990 proc diffcontextchange {n1 n2 op} {
7991 global diffcontextstring diffcontext
7993 if {[string is integer -strict $diffcontextstring]} {
7994 if {$diffcontextstring >= 0} {
7995 set diffcontext $diffcontextstring
7996 reselectline
8001 proc changeignorespace {} {
8002 reselectline
8005 proc changeworddiff {name ix op} {
8006 reselectline
8009 proc initblobdiffvars {} {
8010 global diffencoding targetline diffnparents
8011 global diffinhdr currdiffsubmod diffseehere
8012 set targetline {}
8013 set diffnparents 0
8014 set diffinhdr 0
8015 set diffencoding [get_path_encoding {}]
8016 set currdiffsubmod ""
8017 set diffseehere -1
8020 proc getblobdiffs {ids} {
8021 global blobdifffd diffids env
8022 global treediffs
8023 global diffcontext
8024 global ignorespace
8025 global worddiff
8026 global limitdiffs vfilelimit curview
8027 global git_version
8029 set textconv {}
8030 if {[package vcompare $git_version "1.6.1"] >= 0} {
8031 set textconv "--textconv"
8033 set submodule {}
8034 if {[package vcompare $git_version "1.6.6"] >= 0} {
8035 set submodule "--submodule"
8037 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
8038 if {$ignorespace} {
8039 append cmd " -w"
8041 if {$worddiff ne [mc "Line diff"]} {
8042 append cmd " --word-diff=porcelain"
8044 if {$limitdiffs && $vfilelimit($curview) ne {}} {
8045 set cmd [concat $cmd -- $vfilelimit($curview)]
8047 if {[catch {set bdf [open $cmd r]} err]} {
8048 error_popup [mc "Error getting diffs: %s" $err]
8049 return
8051 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
8052 set blobdifffd($ids) $bdf
8053 initblobdiffvars
8054 filerun $bdf [list getblobdiffline $bdf $diffids]
8057 proc savecmitpos {} {
8058 global ctext cmitmode
8060 if {$cmitmode eq "tree"} {
8061 return {}
8063 return [list target_scrollpos [$ctext index @0,0]]
8066 proc savectextpos {} {
8067 global ctext
8069 return [list target_scrollpos [$ctext index @0,0]]
8072 proc maybe_scroll_ctext {ateof} {
8073 global ctext target_scrollpos
8075 if {![info exists target_scrollpos]} return
8076 if {!$ateof} {
8077 set nlines [expr {[winfo height $ctext]
8078 / [font metrics textfont -linespace]}]
8079 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
8081 $ctext yview $target_scrollpos
8082 unset target_scrollpos
8085 proc setinlist {var i val} {
8086 global $var
8088 while {[llength [set $var]] < $i} {
8089 lappend $var {}
8091 if {[llength [set $var]] == $i} {
8092 lappend $var $val
8093 } else {
8094 lset $var $i $val
8098 proc makediffhdr {fname ids} {
8099 global ctext curdiffstart treediffs diffencoding
8100 global ctext_file_names jump_to_here targetline diffline
8102 set fname [encoding convertfrom $fname]
8103 set diffencoding [get_path_encoding $fname]
8104 set i [lsearch -exact $treediffs($ids) $fname]
8105 if {$i >= 0} {
8106 setinlist difffilestart $i $curdiffstart
8108 lset ctext_file_names end $fname
8109 set l [expr {(78 - [string length $fname]) / 2}]
8110 set pad [string range "----------------------------------------" 1 $l]
8111 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8112 set targetline {}
8113 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8114 set targetline [lindex $jump_to_here 1]
8116 set diffline 0
8119 proc blobdiffmaybeseehere {ateof} {
8120 global diffseehere
8121 if {$diffseehere >= 0} {
8122 mark_ctext_line [lindex [split $diffseehere .] 0]
8124 maybe_scroll_ctext $ateof
8127 proc getblobdiffline {bdf ids} {
8128 global diffids blobdifffd
8129 global ctext
8131 set nr 0
8132 $ctext conf -state normal
8133 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8134 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8135 # Older diff read. Abort it.
8136 catch {close $bdf}
8137 if {$ids != $diffids} {
8138 array unset blobdifffd $ids
8140 return 0
8142 parseblobdiffline $ids $line
8144 $ctext conf -state disabled
8145 blobdiffmaybeseehere [eof $bdf]
8146 if {[eof $bdf]} {
8147 catch {close $bdf}
8148 array unset blobdifffd $ids
8149 return 0
8151 return [expr {$nr >= 1000? 2: 1}]
8154 proc parseblobdiffline {ids line} {
8155 global ctext curdiffstart
8156 global diffnexthead diffnextnote difffilestart
8157 global ctext_file_names ctext_file_lines
8158 global diffinhdr treediffs mergemax diffnparents
8159 global diffencoding jump_to_here targetline diffline currdiffsubmod
8160 global worddiff diffseehere
8162 if {![string compare -length 5 "diff " $line]} {
8163 if {![regexp {^diff (--cc|--git) } $line m type]} {
8164 set line [encoding convertfrom $line]
8165 $ctext insert end "$line\n" hunksep
8166 continue
8168 # start of a new file
8169 set diffinhdr 1
8170 set currdiffsubmod ""
8172 $ctext insert end "\n"
8173 set curdiffstart [$ctext index "end - 1c"]
8174 lappend ctext_file_names ""
8175 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8176 $ctext insert end "\n" filesep
8178 if {$type eq "--cc"} {
8179 # start of a new file in a merge diff
8180 set fname [string range $line 10 end]
8181 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8182 lappend treediffs($ids) $fname
8183 add_flist [list $fname]
8186 } else {
8187 set line [string range $line 11 end]
8188 # If the name hasn't changed the length will be odd,
8189 # the middle char will be a space, and the two bits either
8190 # side will be a/name and b/name, or "a/name" and "b/name".
8191 # If the name has changed we'll get "rename from" and
8192 # "rename to" or "copy from" and "copy to" lines following
8193 # this, and we'll use them to get the filenames.
8194 # This complexity is necessary because spaces in the
8195 # filename(s) don't get escaped.
8196 set l [string length $line]
8197 set i [expr {$l / 2}]
8198 if {!(($l & 1) && [string index $line $i] eq " " &&
8199 [string range $line 2 [expr {$i - 1}]] eq \
8200 [string range $line [expr {$i + 3}] end])} {
8201 return
8203 # unescape if quoted and chop off the a/ from the front
8204 if {[string index $line 0] eq "\""} {
8205 set fname [string range [lindex $line 0] 2 end]
8206 } else {
8207 set fname [string range $line 2 [expr {$i - 1}]]
8210 makediffhdr $fname $ids
8212 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8213 set fname [encoding convertfrom [string range $line 16 end]]
8214 $ctext insert end "\n"
8215 set curdiffstart [$ctext index "end - 1c"]
8216 lappend ctext_file_names $fname
8217 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8218 $ctext insert end "$line\n" filesep
8219 set i [lsearch -exact $treediffs($ids) $fname]
8220 if {$i >= 0} {
8221 setinlist difffilestart $i $curdiffstart
8224 } elseif {![string compare -length 2 "@@" $line]} {
8225 regexp {^@@+} $line ats
8226 set line [encoding convertfrom $diffencoding $line]
8227 $ctext insert end "$line\n" hunksep
8228 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8229 set diffline $nl
8231 set diffnparents [expr {[string length $ats] - 1}]
8232 set diffinhdr 0
8234 } elseif {![string compare -length 10 "Submodule " $line]} {
8235 # start of a new submodule
8236 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8237 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8238 } else {
8239 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8241 if {$currdiffsubmod != $fname} {
8242 $ctext insert end "\n"; # Add newline after commit message
8244 if {$currdiffsubmod != $fname} {
8245 set curdiffstart [$ctext index "end - 1c"]
8246 lappend ctext_file_names ""
8247 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8248 makediffhdr $fname $ids
8249 set currdiffsubmod $fname
8250 $ctext insert end "\n$line\n" filesep
8251 } else {
8252 $ctext insert end "$line\n" filesep
8254 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " >" $line]} {
8255 set line [encoding convertfrom $diffencoding $line]
8256 $ctext insert end "$line\n" dresult
8257 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " <" $line]} {
8258 set line [encoding convertfrom $diffencoding $line]
8259 $ctext insert end "$line\n" d0
8260 } elseif {$diffinhdr} {
8261 if {![string compare -length 12 "rename from " $line]} {
8262 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8263 if {[string index $fname 0] eq "\""} {
8264 set fname [lindex $fname 0]
8266 set fname [encoding convertfrom $fname]
8267 set i [lsearch -exact $treediffs($ids) $fname]
8268 if {$i >= 0} {
8269 setinlist difffilestart $i $curdiffstart
8271 } elseif {![string compare -length 10 $line "rename to "] ||
8272 ![string compare -length 8 $line "copy to "]} {
8273 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8274 if {[string index $fname 0] eq "\""} {
8275 set fname [lindex $fname 0]
8277 makediffhdr $fname $ids
8278 } elseif {[string compare -length 3 $line "---"] == 0} {
8279 # do nothing
8280 return
8281 } elseif {[string compare -length 3 $line "+++"] == 0} {
8282 set diffinhdr 0
8283 return
8285 $ctext insert end "$line\n" filesep
8287 } else {
8288 set line [string map {\x1A ^Z} \
8289 [encoding convertfrom $diffencoding $line]]
8290 # parse the prefix - one ' ', '-' or '+' for each parent
8291 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8292 set tag [expr {$diffnparents > 1? "m": "d"}]
8293 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8294 set words_pre_markup ""
8295 set words_post_markup ""
8296 if {[string trim $prefix " -+"] eq {}} {
8297 # prefix only has " ", "-" and "+" in it: normal diff line
8298 set num [string first "-" $prefix]
8299 if {$dowords} {
8300 set line [string range $line 1 end]
8302 if {$num >= 0} {
8303 # removed line, first parent with line is $num
8304 if {$num >= $mergemax} {
8305 set num "max"
8307 if {$dowords && $worddiff eq [mc "Markup words"]} {
8308 $ctext insert end "\[-$line-\]" $tag$num
8309 } else {
8310 $ctext insert end "$line" $tag$num
8312 if {!$dowords} {
8313 $ctext insert end "\n" $tag$num
8315 } else {
8316 set tags {}
8317 if {[string first "+" $prefix] >= 0} {
8318 # added line
8319 lappend tags ${tag}result
8320 if {$diffnparents > 1} {
8321 set num [string first " " $prefix]
8322 if {$num >= 0} {
8323 if {$num >= $mergemax} {
8324 set num "max"
8326 lappend tags m$num
8329 set words_pre_markup "{+"
8330 set words_post_markup "+}"
8332 if {$targetline ne {}} {
8333 if {$diffline == $targetline} {
8334 set diffseehere [$ctext index "end - 1 chars"]
8335 set targetline {}
8336 } else {
8337 incr diffline
8340 if {$dowords && $worddiff eq [mc "Markup words"]} {
8341 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8342 } else {
8343 $ctext insert end "$line" $tags
8345 if {!$dowords} {
8346 $ctext insert end "\n" $tags
8349 } elseif {$dowords && $prefix eq "~"} {
8350 $ctext insert end "\n" {}
8351 } else {
8352 # "\ No newline at end of file",
8353 # or something else we don't recognize
8354 $ctext insert end "$line\n" hunksep
8359 proc changediffdisp {} {
8360 global ctext diffelide
8362 $ctext tag conf d0 -elide [lindex $diffelide 0]
8363 $ctext tag conf dresult -elide [lindex $diffelide 1]
8366 proc highlightfile {cline} {
8367 global cflist cflist_top
8369 if {![info exists cflist_top]} return
8371 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8372 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8373 $cflist see $cline.0
8374 set cflist_top $cline
8377 proc highlightfile_for_scrollpos {topidx} {
8378 global cmitmode difffilestart
8380 if {$cmitmode eq "tree"} return
8381 if {![info exists difffilestart]} return
8383 set top [lindex [split $topidx .] 0]
8384 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8385 highlightfile 0
8386 } else {
8387 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8391 proc prevfile {} {
8392 global difffilestart ctext cmitmode
8394 if {$cmitmode eq "tree"} return
8395 set prev 0.0
8396 set here [$ctext index @0,0]
8397 foreach loc $difffilestart {
8398 if {[$ctext compare $loc >= $here]} {
8399 $ctext yview $prev
8400 return
8402 set prev $loc
8404 $ctext yview $prev
8407 proc nextfile {} {
8408 global difffilestart ctext cmitmode
8410 if {$cmitmode eq "tree"} return
8411 set here [$ctext index @0,0]
8412 foreach loc $difffilestart {
8413 if {[$ctext compare $loc > $here]} {
8414 $ctext yview $loc
8415 return
8420 proc clear_ctext {{first 1.0}} {
8421 global ctext smarktop smarkbot
8422 global ctext_file_names ctext_file_lines
8423 global pendinglinks
8425 set l [lindex [split $first .] 0]
8426 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8427 set smarktop $l
8429 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8430 set smarkbot $l
8432 $ctext delete $first end
8433 if {$first eq "1.0"} {
8434 unset -nocomplain pendinglinks
8436 set ctext_file_names {}
8437 set ctext_file_lines {}
8440 proc settabs {{firstab {}}} {
8441 global firsttabstop tabstop ctext have_tk85
8443 if {$firstab ne {} && $have_tk85} {
8444 set firsttabstop $firstab
8446 set w [font measure textfont "0"]
8447 if {$firsttabstop != 0} {
8448 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8449 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8450 } elseif {$have_tk85 || $tabstop != 8} {
8451 $ctext conf -tabs [expr {$tabstop * $w}]
8452 } else {
8453 $ctext conf -tabs {}
8457 proc incrsearch {name ix op} {
8458 global ctext searchstring searchdirn
8460 if {[catch {$ctext index anchor}]} {
8461 # no anchor set, use start of selection, or of visible area
8462 set sel [$ctext tag ranges sel]
8463 if {$sel ne {}} {
8464 $ctext mark set anchor [lindex $sel 0]
8465 } elseif {$searchdirn eq "-forwards"} {
8466 $ctext mark set anchor @0,0
8467 } else {
8468 $ctext mark set anchor @0,[winfo height $ctext]
8471 if {$searchstring ne {}} {
8472 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8473 if {$here ne {}} {
8474 $ctext see $here
8475 set mend "$here + $mlen c"
8476 $ctext tag remove sel 1.0 end
8477 $ctext tag add sel $here $mend
8478 suppress_highlighting_file_for_current_scrollpos
8479 highlightfile_for_scrollpos $here
8482 rehighlight_search_results
8485 proc dosearch {} {
8486 global sstring ctext searchstring searchdirn
8488 focus $sstring
8489 $sstring icursor end
8490 set searchdirn -forwards
8491 if {$searchstring ne {}} {
8492 set sel [$ctext tag ranges sel]
8493 if {$sel ne {}} {
8494 set start "[lindex $sel 0] + 1c"
8495 } elseif {[catch {set start [$ctext index anchor]}]} {
8496 set start "@0,0"
8498 set match [$ctext search -count mlen -- $searchstring $start]
8499 $ctext tag remove sel 1.0 end
8500 if {$match eq {}} {
8501 bell
8502 return
8504 $ctext see $match
8505 suppress_highlighting_file_for_current_scrollpos
8506 highlightfile_for_scrollpos $match
8507 set mend "$match + $mlen c"
8508 $ctext tag add sel $match $mend
8509 $ctext mark unset anchor
8510 rehighlight_search_results
8514 proc dosearchback {} {
8515 global sstring ctext searchstring searchdirn
8517 focus $sstring
8518 $sstring icursor end
8519 set searchdirn -backwards
8520 if {$searchstring ne {}} {
8521 set sel [$ctext tag ranges sel]
8522 if {$sel ne {}} {
8523 set start [lindex $sel 0]
8524 } elseif {[catch {set start [$ctext index anchor]}]} {
8525 set start @0,[winfo height $ctext]
8527 set match [$ctext search -backwards -count ml -- $searchstring $start]
8528 $ctext tag remove sel 1.0 end
8529 if {$match eq {}} {
8530 bell
8531 return
8533 $ctext see $match
8534 suppress_highlighting_file_for_current_scrollpos
8535 highlightfile_for_scrollpos $match
8536 set mend "$match + $ml c"
8537 $ctext tag add sel $match $mend
8538 $ctext mark unset anchor
8539 rehighlight_search_results
8543 proc rehighlight_search_results {} {
8544 global ctext searchstring
8546 $ctext tag remove found 1.0 end
8547 $ctext tag remove currentsearchhit 1.0 end
8549 if {$searchstring ne {}} {
8550 searchmarkvisible 1
8554 proc searchmark {first last} {
8555 global ctext searchstring
8557 set sel [$ctext tag ranges sel]
8559 set mend $first.0
8560 while {1} {
8561 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8562 if {$match eq {}} break
8563 set mend "$match + $mlen c"
8564 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8565 $ctext tag add currentsearchhit $match $mend
8566 } else {
8567 $ctext tag add found $match $mend
8572 proc searchmarkvisible {doall} {
8573 global ctext smarktop smarkbot
8575 set topline [lindex [split [$ctext index @0,0] .] 0]
8576 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8577 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8578 # no overlap with previous
8579 searchmark $topline $botline
8580 set smarktop $topline
8581 set smarkbot $botline
8582 } else {
8583 if {$topline < $smarktop} {
8584 searchmark $topline [expr {$smarktop-1}]
8585 set smarktop $topline
8587 if {$botline > $smarkbot} {
8588 searchmark [expr {$smarkbot+1}] $botline
8589 set smarkbot $botline
8594 proc suppress_highlighting_file_for_current_scrollpos {} {
8595 global ctext suppress_highlighting_file_for_this_scrollpos
8597 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8600 proc scrolltext {f0 f1} {
8601 global searchstring cmitmode ctext
8602 global suppress_highlighting_file_for_this_scrollpos
8604 set topidx [$ctext index @0,0]
8605 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8606 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8607 highlightfile_for_scrollpos $topidx
8610 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8612 .bleft.bottom.sb set $f0 $f1
8613 if {$searchstring ne {}} {
8614 searchmarkvisible 0
8618 proc setcoords {} {
8619 global linespc charspc canvx0 canvy0
8620 global xspc1 xspc2 lthickness
8622 set linespc [font metrics mainfont -linespace]
8623 set charspc [font measure mainfont "m"]
8624 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8625 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8626 set lthickness [expr {int($linespc / 9) + 1}]
8627 set xspc1(0) $linespc
8628 set xspc2 $linespc
8631 proc redisplay {} {
8632 global canv
8633 global selectedline
8635 set ymax [lindex [$canv cget -scrollregion] 3]
8636 if {$ymax eq {} || $ymax == 0} return
8637 set span [$canv yview]
8638 clear_display
8639 setcanvscroll
8640 allcanvs yview moveto [lindex $span 0]
8641 drawvisible
8642 if {$selectedline ne {}} {
8643 selectline $selectedline 0
8644 allcanvs yview moveto [lindex $span 0]
8648 proc parsefont {f n} {
8649 global fontattr
8651 set fontattr($f,family) [lindex $n 0]
8652 set s [lindex $n 1]
8653 if {$s eq {} || $s == 0} {
8654 set s 10
8655 } elseif {$s < 0} {
8656 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8658 set fontattr($f,size) $s
8659 set fontattr($f,weight) normal
8660 set fontattr($f,slant) roman
8661 foreach style [lrange $n 2 end] {
8662 switch -- $style {
8663 "normal" -
8664 "bold" {set fontattr($f,weight) $style}
8665 "roman" -
8666 "italic" {set fontattr($f,slant) $style}
8671 proc fontflags {f {isbold 0}} {
8672 global fontattr
8674 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8675 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8676 -slant $fontattr($f,slant)]
8679 proc fontname {f} {
8680 global fontattr
8682 set n [list $fontattr($f,family) $fontattr($f,size)]
8683 if {$fontattr($f,weight) eq "bold"} {
8684 lappend n "bold"
8686 if {$fontattr($f,slant) eq "italic"} {
8687 lappend n "italic"
8689 return $n
8692 proc incrfont {inc} {
8693 global mainfont textfont ctext canv cflist showrefstop
8694 global stopped entries fontattr
8696 unmarkmatches
8697 set s $fontattr(mainfont,size)
8698 incr s $inc
8699 if {$s < 1} {
8700 set s 1
8702 set fontattr(mainfont,size) $s
8703 font config mainfont -size $s
8704 font config mainfontbold -size $s
8705 set mainfont [fontname mainfont]
8706 set s $fontattr(textfont,size)
8707 incr s $inc
8708 if {$s < 1} {
8709 set s 1
8711 set fontattr(textfont,size) $s
8712 font config textfont -size $s
8713 font config textfontbold -size $s
8714 set textfont [fontname textfont]
8715 setcoords
8716 settabs
8717 redisplay
8720 proc clearsha1 {} {
8721 global sha1entry sha1string
8722 if {[string length $sha1string] == 40} {
8723 $sha1entry delete 0 end
8727 proc sha1change {n1 n2 op} {
8728 global sha1string currentid sha1but
8729 if {$sha1string == {}
8730 || ([info exists currentid] && $sha1string == $currentid)} {
8731 set state disabled
8732 } else {
8733 set state normal
8735 if {[$sha1but cget -state] == $state} return
8736 if {$state == "normal"} {
8737 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8738 } else {
8739 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8743 proc gotocommit {} {
8744 global sha1string tagids headids curview varcid
8746 if {$sha1string == {}
8747 || ([info exists currentid] && $sha1string == $currentid)} return
8748 if {[info exists tagids($sha1string)]} {
8749 set id $tagids($sha1string)
8750 } elseif {[info exists headids($sha1string)]} {
8751 set id $headids($sha1string)
8752 } else {
8753 set id [string tolower $sha1string]
8754 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8755 set matches [longid $id]
8756 if {$matches ne {}} {
8757 if {[llength $matches] > 1} {
8758 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8759 return
8761 set id [lindex $matches 0]
8763 } else {
8764 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8765 error_popup [mc "Revision %s is not known" $sha1string]
8766 return
8770 if {[commitinview $id $curview]} {
8771 selectline [rowofcommit $id] 1
8772 return
8774 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8775 set msg [mc "SHA1 id %s is not known" $sha1string]
8776 } else {
8777 set msg [mc "Revision %s is not in the current view" $sha1string]
8779 error_popup $msg
8782 proc lineenter {x y id} {
8783 global hoverx hovery hoverid hovertimer
8784 global commitinfo canv
8786 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8787 set hoverx $x
8788 set hovery $y
8789 set hoverid $id
8790 if {[info exists hovertimer]} {
8791 after cancel $hovertimer
8793 set hovertimer [after 500 linehover]
8794 $canv delete hover
8797 proc linemotion {x y id} {
8798 global hoverx hovery hoverid hovertimer
8800 if {[info exists hoverid] && $id == $hoverid} {
8801 set hoverx $x
8802 set hovery $y
8803 if {[info exists hovertimer]} {
8804 after cancel $hovertimer
8806 set hovertimer [after 500 linehover]
8810 proc lineleave {id} {
8811 global hoverid hovertimer canv
8813 if {[info exists hoverid] && $id == $hoverid} {
8814 $canv delete hover
8815 if {[info exists hovertimer]} {
8816 after cancel $hovertimer
8817 unset hovertimer
8819 unset hoverid
8823 proc linehover {} {
8824 global hoverx hovery hoverid hovertimer
8825 global canv linespc lthickness
8826 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8828 global commitinfo
8830 set text [lindex $commitinfo($hoverid) 0]
8831 set ymax [lindex [$canv cget -scrollregion] 3]
8832 if {$ymax == {}} return
8833 set yfrac [lindex [$canv yview] 0]
8834 set x [expr {$hoverx + 2 * $linespc}]
8835 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8836 set x0 [expr {$x - 2 * $lthickness}]
8837 set y0 [expr {$y - 2 * $lthickness}]
8838 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8839 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8840 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8841 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8842 -width 1 -tags hover]
8843 $canv raise $t
8844 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8845 -font mainfont -fill $linehoverfgcolor]
8846 $canv raise $t
8849 proc clickisonarrow {id y} {
8850 global lthickness
8852 set ranges [rowranges $id]
8853 set thresh [expr {2 * $lthickness + 6}]
8854 set n [expr {[llength $ranges] - 1}]
8855 for {set i 1} {$i < $n} {incr i} {
8856 set row [lindex $ranges $i]
8857 if {abs([yc $row] - $y) < $thresh} {
8858 return $i
8861 return {}
8864 proc arrowjump {id n y} {
8865 global canv
8867 # 1 <-> 2, 3 <-> 4, etc...
8868 set n [expr {(($n - 1) ^ 1) + 1}]
8869 set row [lindex [rowranges $id] $n]
8870 set yt [yc $row]
8871 set ymax [lindex [$canv cget -scrollregion] 3]
8872 if {$ymax eq {} || $ymax <= 0} return
8873 set view [$canv yview]
8874 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8875 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8876 if {$yfrac < 0} {
8877 set yfrac 0
8879 allcanvs yview moveto $yfrac
8882 proc lineclick {x y id isnew} {
8883 global ctext commitinfo children canv thickerline curview
8885 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8886 unmarkmatches
8887 unselectline
8888 normalline
8889 $canv delete hover
8890 # draw this line thicker than normal
8891 set thickerline $id
8892 drawlines $id
8893 if {$isnew} {
8894 set ymax [lindex [$canv cget -scrollregion] 3]
8895 if {$ymax eq {}} return
8896 set yfrac [lindex [$canv yview] 0]
8897 set y [expr {$y + $yfrac * $ymax}]
8899 set dirn [clickisonarrow $id $y]
8900 if {$dirn ne {}} {
8901 arrowjump $id $dirn $y
8902 return
8905 if {$isnew} {
8906 addtohistory [list lineclick $x $y $id 0] savectextpos
8908 # fill the details pane with info about this line
8909 $ctext conf -state normal
8910 clear_ctext
8911 settabs 0
8912 $ctext insert end "[mc "Parent"]:\t"
8913 $ctext insert end $id link0
8914 setlink $id link0
8915 set info $commitinfo($id)
8916 $ctext insert end "\n\t[lindex $info 0]\n"
8917 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8918 set date [formatdate [lindex $info 2]]
8919 $ctext insert end "\t[mc "Date"]:\t$date\n"
8920 set kids $children($curview,$id)
8921 if {$kids ne {}} {
8922 $ctext insert end "\n[mc "Children"]:"
8923 set i 0
8924 foreach child $kids {
8925 incr i
8926 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8927 set info $commitinfo($child)
8928 $ctext insert end "\n\t"
8929 $ctext insert end $child link$i
8930 setlink $child link$i
8931 $ctext insert end "\n\t[lindex $info 0]"
8932 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8933 set date [formatdate [lindex $info 2]]
8934 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8937 maybe_scroll_ctext 1
8938 $ctext conf -state disabled
8939 init_flist {}
8942 proc normalline {} {
8943 global thickerline
8944 if {[info exists thickerline]} {
8945 set id $thickerline
8946 unset thickerline
8947 drawlines $id
8951 proc selbyid {id {isnew 1}} {
8952 global curview
8953 if {[commitinview $id $curview]} {
8954 selectline [rowofcommit $id] $isnew
8958 proc mstime {} {
8959 global startmstime
8960 if {![info exists startmstime]} {
8961 set startmstime [clock clicks -milliseconds]
8963 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8966 proc rowmenu {x y id} {
8967 global rowctxmenu selectedline rowmenuid curview
8968 global nullid nullid2 fakerowmenu mainhead markedid
8970 stopfinding
8971 set rowmenuid $id
8972 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8973 set state disabled
8974 } else {
8975 set state normal
8977 if {[info exists markedid] && $markedid ne $id} {
8978 set mstate normal
8979 } else {
8980 set mstate disabled
8982 if {$id ne $nullid && $id ne $nullid2} {
8983 set menu $rowctxmenu
8984 if {$mainhead ne {}} {
8985 $menu entryconfigure 8 -label [mc "Reset %s branch to here" $mainhead] -state normal
8986 } else {
8987 $menu entryconfigure 8 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8989 $menu entryconfigure 10 -state $mstate
8990 $menu entryconfigure 11 -state $mstate
8991 $menu entryconfigure 12 -state $mstate
8992 } else {
8993 set menu $fakerowmenu
8995 $menu entryconfigure [mca "Diff this -> selected"] -state $state
8996 $menu entryconfigure [mca "Diff selected -> this"] -state $state
8997 $menu entryconfigure [mca "Make patch"] -state $state
8998 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8999 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
9000 tk_popup $menu $x $y
9003 proc markhere {} {
9004 global rowmenuid markedid canv
9006 set markedid $rowmenuid
9007 make_idmark $markedid
9010 proc gotomark {} {
9011 global markedid
9013 if {[info exists markedid]} {
9014 selbyid $markedid
9018 proc replace_by_kids {l r} {
9019 global curview children
9021 set id [commitonrow $r]
9022 set l [lreplace $l 0 0]
9023 foreach kid $children($curview,$id) {
9024 lappend l [rowofcommit $kid]
9026 return [lsort -integer -decreasing -unique $l]
9029 proc find_common_desc {} {
9030 global markedid rowmenuid curview children
9032 if {![info exists markedid]} return
9033 if {![commitinview $markedid $curview] ||
9034 ![commitinview $rowmenuid $curview]} return
9035 #set t1 [clock clicks -milliseconds]
9036 set l1 [list [rowofcommit $markedid]]
9037 set l2 [list [rowofcommit $rowmenuid]]
9038 while 1 {
9039 set r1 [lindex $l1 0]
9040 set r2 [lindex $l2 0]
9041 if {$r1 eq {} || $r2 eq {}} break
9042 if {$r1 == $r2} {
9043 selectline $r1 1
9044 break
9046 if {$r1 > $r2} {
9047 set l1 [replace_by_kids $l1 $r1]
9048 } else {
9049 set l2 [replace_by_kids $l2 $r2]
9052 #set t2 [clock clicks -milliseconds]
9053 #puts "took [expr {$t2-$t1}]ms"
9056 proc compare_commits {} {
9057 global markedid rowmenuid curview children
9059 if {![info exists markedid]} return
9060 if {![commitinview $markedid $curview]} return
9061 addtohistory [list do_cmp_commits $markedid $rowmenuid]
9062 do_cmp_commits $markedid $rowmenuid
9065 proc getpatchid {id} {
9066 global patchids
9068 if {![info exists patchids($id)]} {
9069 set cmd [diffcmd [list $id] {-p --root}]
9070 # trim off the initial "|"
9071 set cmd [lrange $cmd 1 end]
9072 if {[catch {
9073 set x [eval exec $cmd | git patch-id]
9074 set patchids($id) [lindex $x 0]
9075 }]} {
9076 set patchids($id) "error"
9079 return $patchids($id)
9082 proc do_cmp_commits {a b} {
9083 global ctext curview parents children patchids commitinfo
9085 $ctext conf -state normal
9086 clear_ctext
9087 init_flist {}
9088 for {set i 0} {$i < 100} {incr i} {
9089 set skipa 0
9090 set skipb 0
9091 if {[llength $parents($curview,$a)] > 1} {
9092 appendshortlink $a [mc "Skipping merge commit "] "\n"
9093 set skipa 1
9094 } else {
9095 set patcha [getpatchid $a]
9097 if {[llength $parents($curview,$b)] > 1} {
9098 appendshortlink $b [mc "Skipping merge commit "] "\n"
9099 set skipb 1
9100 } else {
9101 set patchb [getpatchid $b]
9103 if {!$skipa && !$skipb} {
9104 set heada [lindex $commitinfo($a) 0]
9105 set headb [lindex $commitinfo($b) 0]
9106 if {$patcha eq "error"} {
9107 appendshortlink $a [mc "Error getting patch ID for "] \
9108 [mc " - stopping\n"]
9109 break
9111 if {$patchb eq "error"} {
9112 appendshortlink $b [mc "Error getting patch ID for "] \
9113 [mc " - stopping\n"]
9114 break
9116 if {$patcha eq $patchb} {
9117 if {$heada eq $headb} {
9118 appendshortlink $a [mc "Commit "]
9119 appendshortlink $b " == " " $heada\n"
9120 } else {
9121 appendshortlink $a [mc "Commit "] " $heada\n"
9122 appendshortlink $b [mc " is the same patch as\n "] \
9123 " $headb\n"
9125 set skipa 1
9126 set skipb 1
9127 } else {
9128 $ctext insert end "\n"
9129 appendshortlink $a [mc "Commit "] " $heada\n"
9130 appendshortlink $b [mc " differs from\n "] \
9131 " $headb\n"
9132 $ctext insert end [mc "Diff of commits:\n\n"]
9133 $ctext conf -state disabled
9134 update
9135 diffcommits $a $b
9136 return
9139 if {$skipa} {
9140 set kids [real_children $curview,$a]
9141 if {[llength $kids] != 1} {
9142 $ctext insert end "\n"
9143 appendshortlink $a [mc "Commit "] \
9144 [mc " has %s children - stopping\n" [llength $kids]]
9145 break
9147 set a [lindex $kids 0]
9149 if {$skipb} {
9150 set kids [real_children $curview,$b]
9151 if {[llength $kids] != 1} {
9152 appendshortlink $b [mc "Commit "] \
9153 [mc " has %s children - stopping\n" [llength $kids]]
9154 break
9156 set b [lindex $kids 0]
9159 $ctext conf -state disabled
9162 proc diffcommits {a b} {
9163 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9165 set tmpdir [gitknewtmpdir]
9166 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9167 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9168 if {[catch {
9169 exec git diff-tree -p --pretty $a >$fna
9170 exec git diff-tree -p --pretty $b >$fnb
9171 } err]} {
9172 error_popup [mc "Error writing commit to file: %s" $err]
9173 return
9175 if {[catch {
9176 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9177 } err]} {
9178 error_popup [mc "Error diffing commits: %s" $err]
9179 return
9181 set diffids [list commits $a $b]
9182 set blobdifffd($diffids) $fd
9183 set diffinhdr 0
9184 set currdiffsubmod ""
9185 filerun $fd [list getblobdiffline $fd $diffids]
9188 proc diffvssel {dirn} {
9189 global rowmenuid selectedline
9191 if {$selectedline eq {}} return
9192 if {$dirn} {
9193 set oldid [commitonrow $selectedline]
9194 set newid $rowmenuid
9195 } else {
9196 set oldid $rowmenuid
9197 set newid [commitonrow $selectedline]
9199 addtohistory [list doseldiff $oldid $newid] savectextpos
9200 doseldiff $oldid $newid
9203 proc diffvsmark {dirn} {
9204 global rowmenuid markedid
9206 if {![info exists markedid]} return
9207 if {$dirn} {
9208 set oldid $markedid
9209 set newid $rowmenuid
9210 } else {
9211 set oldid $rowmenuid
9212 set newid $markedid
9214 addtohistory [list doseldiff $oldid $newid] savectextpos
9215 doseldiff $oldid $newid
9218 proc doseldiff {oldid newid} {
9219 global ctext
9220 global commitinfo
9222 $ctext conf -state normal
9223 clear_ctext
9224 init_flist [mc "Top"]
9225 $ctext insert end "[mc "From"] "
9226 $ctext insert end $oldid link0
9227 setlink $oldid link0
9228 $ctext insert end "\n "
9229 $ctext insert end [lindex $commitinfo($oldid) 0]
9230 $ctext insert end "\n\n[mc "To"] "
9231 $ctext insert end $newid link1
9232 setlink $newid link1
9233 $ctext insert end "\n "
9234 $ctext insert end [lindex $commitinfo($newid) 0]
9235 $ctext insert end "\n"
9236 $ctext conf -state disabled
9237 $ctext tag remove found 1.0 end
9238 startdiff [list $oldid $newid]
9241 proc mkpatch {} {
9242 global rowmenuid currentid commitinfo patchtop patchnum NS
9244 if {![info exists currentid]} return
9245 set oldid $currentid
9246 set oldhead [lindex $commitinfo($oldid) 0]
9247 set newid $rowmenuid
9248 set newhead [lindex $commitinfo($newid) 0]
9249 set top .patch
9250 set patchtop $top
9251 catch {destroy $top}
9252 ttk_toplevel $top
9253 make_transient $top .
9254 ${NS}::label $top.title -text [mc "Generate patch"]
9255 grid $top.title - -pady 10
9256 ${NS}::label $top.from -text [mc "From:"]
9257 ${NS}::entry $top.fromsha1 -width 40
9258 $top.fromsha1 insert 0 $oldid
9259 $top.fromsha1 conf -state readonly
9260 grid $top.from $top.fromsha1 -sticky w
9261 ${NS}::entry $top.fromhead -width 60
9262 $top.fromhead insert 0 $oldhead
9263 $top.fromhead conf -state readonly
9264 grid x $top.fromhead -sticky w
9265 ${NS}::label $top.to -text [mc "To:"]
9266 ${NS}::entry $top.tosha1 -width 40
9267 $top.tosha1 insert 0 $newid
9268 $top.tosha1 conf -state readonly
9269 grid $top.to $top.tosha1 -sticky w
9270 ${NS}::entry $top.tohead -width 60
9271 $top.tohead insert 0 $newhead
9272 $top.tohead conf -state readonly
9273 grid x $top.tohead -sticky w
9274 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9275 grid $top.rev x -pady 10 -padx 5
9276 ${NS}::label $top.flab -text [mc "Output file:"]
9277 ${NS}::entry $top.fname -width 60
9278 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9279 incr patchnum
9280 grid $top.flab $top.fname -sticky w
9281 ${NS}::frame $top.buts
9282 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9283 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9284 bind $top <Key-Return> mkpatchgo
9285 bind $top <Key-Escape> mkpatchcan
9286 grid $top.buts.gen $top.buts.can
9287 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9288 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9289 grid $top.buts - -pady 10 -sticky ew
9290 focus $top.fname
9293 proc mkpatchrev {} {
9294 global patchtop
9296 set oldid [$patchtop.fromsha1 get]
9297 set oldhead [$patchtop.fromhead get]
9298 set newid [$patchtop.tosha1 get]
9299 set newhead [$patchtop.tohead get]
9300 foreach e [list fromsha1 fromhead tosha1 tohead] \
9301 v [list $newid $newhead $oldid $oldhead] {
9302 $patchtop.$e conf -state normal
9303 $patchtop.$e delete 0 end
9304 $patchtop.$e insert 0 $v
9305 $patchtop.$e conf -state readonly
9309 proc mkpatchgo {} {
9310 global patchtop nullid nullid2
9312 set oldid [$patchtop.fromsha1 get]
9313 set newid [$patchtop.tosha1 get]
9314 set fname [$patchtop.fname get]
9315 set cmd [diffcmd [list $oldid $newid] -p]
9316 # trim off the initial "|"
9317 set cmd [lrange $cmd 1 end]
9318 lappend cmd >$fname &
9319 if {[catch {eval exec $cmd} err]} {
9320 error_popup "[mc "Error creating patch:"] $err" $patchtop
9322 catch {destroy $patchtop}
9323 unset patchtop
9326 proc mkpatchcan {} {
9327 global patchtop
9329 catch {destroy $patchtop}
9330 unset patchtop
9333 proc mktag {} {
9334 global rowmenuid mktagtop commitinfo NS
9336 set top .maketag
9337 set mktagtop $top
9338 catch {destroy $top}
9339 ttk_toplevel $top
9340 make_transient $top .
9341 ${NS}::label $top.title -text [mc "Create tag"]
9342 grid $top.title - -pady 10
9343 ${NS}::label $top.id -text [mc "ID:"]
9344 ${NS}::entry $top.sha1 -width 40
9345 $top.sha1 insert 0 $rowmenuid
9346 $top.sha1 conf -state readonly
9347 grid $top.id $top.sha1 -sticky w
9348 ${NS}::entry $top.head -width 60
9349 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9350 $top.head conf -state readonly
9351 grid x $top.head -sticky w
9352 ${NS}::label $top.tlab -text [mc "Tag name:"]
9353 ${NS}::entry $top.tag -width 60
9354 grid $top.tlab $top.tag -sticky w
9355 ${NS}::label $top.op -text [mc "Tag message is optional"]
9356 grid $top.op -columnspan 2 -sticky we
9357 ${NS}::label $top.mlab -text [mc "Tag message:"]
9358 ${NS}::entry $top.msg -width 60
9359 grid $top.mlab $top.msg -sticky w
9360 ${NS}::frame $top.buts
9361 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9362 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9363 bind $top <Key-Return> mktaggo
9364 bind $top <Key-Escape> mktagcan
9365 grid $top.buts.gen $top.buts.can
9366 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9367 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9368 grid $top.buts - -pady 10 -sticky ew
9369 focus $top.tag
9372 proc domktag {} {
9373 global mktagtop env tagids idtags
9375 set id [$mktagtop.sha1 get]
9376 set tag [$mktagtop.tag get]
9377 set msg [$mktagtop.msg get]
9378 if {$tag == {}} {
9379 error_popup [mc "No tag name specified"] $mktagtop
9380 return 0
9382 if {[info exists tagids($tag)]} {
9383 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9384 return 0
9386 if {[catch {
9387 if {$msg != {}} {
9388 exec git tag -a -m $msg $tag $id
9389 } else {
9390 exec git tag $tag $id
9392 } err]} {
9393 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9394 return 0
9397 set tagids($tag) $id
9398 lappend idtags($id) $tag
9399 redrawtags $id
9400 addedtag $id
9401 dispneartags 0
9402 run refill_reflist
9403 return 1
9406 proc redrawtags {id} {
9407 global canv linehtag idpos currentid curview cmitlisted markedid
9408 global canvxmax iddrawn circleitem mainheadid circlecolors
9409 global mainheadcirclecolor
9411 if {![commitinview $id $curview]} return
9412 if {![info exists iddrawn($id)]} return
9413 set row [rowofcommit $id]
9414 if {$id eq $mainheadid} {
9415 set ofill $mainheadcirclecolor
9416 } else {
9417 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9419 $canv itemconf $circleitem($row) -fill $ofill
9420 $canv delete tag.$id
9421 set xt [eval drawtags $id $idpos($id)]
9422 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9423 set text [$canv itemcget $linehtag($id) -text]
9424 set font [$canv itemcget $linehtag($id) -font]
9425 set xr [expr {$xt + [font measure $font $text]}]
9426 if {$xr > $canvxmax} {
9427 set canvxmax $xr
9428 setcanvscroll
9430 if {[info exists currentid] && $currentid == $id} {
9431 make_secsel $id
9433 if {[info exists markedid] && $markedid eq $id} {
9434 make_idmark $id
9438 proc mktagcan {} {
9439 global mktagtop
9441 catch {destroy $mktagtop}
9442 unset mktagtop
9445 proc mktaggo {} {
9446 if {![domktag]} return
9447 mktagcan
9450 proc copyreference {} {
9451 global rowmenuid autosellen
9453 set format "%h (\"%s\", %ad)"
9454 set cmd [list git show -s --pretty=format:$format --date=short]
9455 if {$autosellen < 40} {
9456 lappend cmd --abbrev=$autosellen
9458 set reference [eval exec $cmd $rowmenuid]
9460 clipboard clear
9461 clipboard append $reference
9464 proc writecommit {} {
9465 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9467 set top .writecommit
9468 set wrcomtop $top
9469 catch {destroy $top}
9470 ttk_toplevel $top
9471 make_transient $top .
9472 ${NS}::label $top.title -text [mc "Write commit to file"]
9473 grid $top.title - -pady 10
9474 ${NS}::label $top.id -text [mc "ID:"]
9475 ${NS}::entry $top.sha1 -width 40
9476 $top.sha1 insert 0 $rowmenuid
9477 $top.sha1 conf -state readonly
9478 grid $top.id $top.sha1 -sticky w
9479 ${NS}::entry $top.head -width 60
9480 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9481 $top.head conf -state readonly
9482 grid x $top.head -sticky w
9483 ${NS}::label $top.clab -text [mc "Command:"]
9484 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9485 grid $top.clab $top.cmd -sticky w -pady 10
9486 ${NS}::label $top.flab -text [mc "Output file:"]
9487 ${NS}::entry $top.fname -width 60
9488 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9489 grid $top.flab $top.fname -sticky w
9490 ${NS}::frame $top.buts
9491 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9492 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9493 bind $top <Key-Return> wrcomgo
9494 bind $top <Key-Escape> wrcomcan
9495 grid $top.buts.gen $top.buts.can
9496 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9497 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9498 grid $top.buts - -pady 10 -sticky ew
9499 focus $top.fname
9502 proc wrcomgo {} {
9503 global wrcomtop
9505 set id [$wrcomtop.sha1 get]
9506 set cmd "echo $id | [$wrcomtop.cmd get]"
9507 set fname [$wrcomtop.fname get]
9508 if {[catch {exec sh -c $cmd >$fname &} err]} {
9509 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9511 catch {destroy $wrcomtop}
9512 unset wrcomtop
9515 proc wrcomcan {} {
9516 global wrcomtop
9518 catch {destroy $wrcomtop}
9519 unset wrcomtop
9522 proc mkbranch {} {
9523 global NS rowmenuid
9525 set top .branchdialog
9527 set val(name) ""
9528 set val(id) $rowmenuid
9529 set val(command) [list mkbrgo $top]
9531 set ui(title) [mc "Create branch"]
9532 set ui(accept) [mc "Create"]
9534 branchdia $top val ui
9537 proc mvbranch {} {
9538 global NS
9539 global headmenuid headmenuhead
9541 set top .branchdialog
9543 set val(name) $headmenuhead
9544 set val(id) $headmenuid
9545 set val(command) [list mvbrgo $top $headmenuhead]
9547 set ui(title) [mc "Rename branch %s" $headmenuhead]
9548 set ui(accept) [mc "Rename"]
9550 branchdia $top val ui
9553 proc branchdia {top valvar uivar} {
9554 global NS commitinfo
9555 upvar $valvar val $uivar ui
9557 catch {destroy $top}
9558 ttk_toplevel $top
9559 make_transient $top .
9560 ${NS}::label $top.title -text $ui(title)
9561 grid $top.title - -pady 10
9562 ${NS}::label $top.id -text [mc "ID:"]
9563 ${NS}::entry $top.sha1 -width 40
9564 $top.sha1 insert 0 $val(id)
9565 $top.sha1 conf -state readonly
9566 grid $top.id $top.sha1 -sticky w
9567 ${NS}::entry $top.head -width 60
9568 $top.head insert 0 [lindex $commitinfo($val(id)) 0]
9569 $top.head conf -state readonly
9570 grid x $top.head -sticky ew
9571 grid columnconfigure $top 1 -weight 1
9572 ${NS}::label $top.nlab -text [mc "Name:"]
9573 ${NS}::entry $top.name -width 40
9574 $top.name insert 0 $val(name)
9575 grid $top.nlab $top.name -sticky w
9576 ${NS}::frame $top.buts
9577 ${NS}::button $top.buts.go -text $ui(accept) -command $val(command)
9578 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9579 bind $top <Key-Return> $val(command)
9580 bind $top <Key-Escape> "catch {destroy $top}"
9581 grid $top.buts.go $top.buts.can
9582 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9583 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9584 grid $top.buts - -pady 10 -sticky ew
9585 focus $top.name
9588 proc mkbrgo {top} {
9589 global headids idheads
9591 set name [$top.name get]
9592 set id [$top.sha1 get]
9593 set cmdargs {}
9594 set old_id {}
9595 if {$name eq {}} {
9596 error_popup [mc "Please specify a name for the new branch"] $top
9597 return
9599 if {[info exists headids($name)]} {
9600 if {![confirm_popup [mc \
9601 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9602 return
9604 set old_id $headids($name)
9605 lappend cmdargs -f
9607 catch {destroy $top}
9608 lappend cmdargs $name $id
9609 nowbusy newbranch
9610 update
9611 if {[catch {
9612 eval exec git branch $cmdargs
9613 } err]} {
9614 notbusy newbranch
9615 error_popup $err
9616 } else {
9617 notbusy newbranch
9618 if {$old_id ne {}} {
9619 movehead $id $name
9620 movedhead $id $name
9621 redrawtags $old_id
9622 redrawtags $id
9623 } else {
9624 set headids($name) $id
9625 lappend idheads($id) $name
9626 addedhead $id $name
9627 redrawtags $id
9629 dispneartags 0
9630 run refill_reflist
9634 proc mvbrgo {top prevname} {
9635 global headids idheads mainhead mainheadid
9637 set name [$top.name get]
9638 set id [$top.sha1 get]
9639 set cmdargs {}
9640 if {$name eq $prevname} {
9641 catch {destroy $top}
9642 return
9644 if {$name eq {}} {
9645 error_popup [mc "Please specify a new name for the branch"] $top
9646 return
9648 catch {destroy $top}
9649 lappend cmdargs -m $prevname $name
9650 nowbusy renamebranch
9651 update
9652 if {[catch {
9653 eval exec git branch $cmdargs
9654 } err]} {
9655 notbusy renamebranch
9656 error_popup $err
9657 } else {
9658 notbusy renamebranch
9659 removehead $id $prevname
9660 removedhead $id $prevname
9661 set headids($name) $id
9662 lappend idheads($id) $name
9663 addedhead $id $name
9664 if {$prevname eq $mainhead} {
9665 set mainhead $name
9666 set mainheadid $id
9668 redrawtags $id
9669 dispneartags 0
9670 run refill_reflist
9674 proc exec_citool {tool_args {baseid {}}} {
9675 global commitinfo env
9677 set save_env [array get env GIT_AUTHOR_*]
9679 if {$baseid ne {}} {
9680 if {![info exists commitinfo($baseid)]} {
9681 getcommit $baseid
9683 set author [lindex $commitinfo($baseid) 1]
9684 set date [lindex $commitinfo($baseid) 2]
9685 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9686 $author author name email]
9687 && $date ne {}} {
9688 set env(GIT_AUTHOR_NAME) $name
9689 set env(GIT_AUTHOR_EMAIL) $email
9690 set env(GIT_AUTHOR_DATE) $date
9694 eval exec git citool $tool_args &
9696 array unset env GIT_AUTHOR_*
9697 array set env $save_env
9700 proc cherrypick {} {
9701 global rowmenuid curview
9702 global mainhead mainheadid
9703 global gitdir
9705 set oldhead [exec git rev-parse HEAD]
9706 set dheads [descheads $rowmenuid]
9707 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9708 set ok [confirm_popup [mc "Commit %s is already\
9709 included in branch %s -- really re-apply it?" \
9710 [string range $rowmenuid 0 7] $mainhead]]
9711 if {!$ok} return
9713 nowbusy cherrypick [mc "Cherry-picking"]
9714 update
9715 # Unfortunately git-cherry-pick writes stuff to stderr even when
9716 # no error occurs, and exec takes that as an indication of error...
9717 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9718 notbusy cherrypick
9719 if {[regexp -line \
9720 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9721 $err msg fname]} {
9722 error_popup [mc "Cherry-pick failed because of local changes\
9723 to file '%s'.\nPlease commit, reset or stash\
9724 your changes and try again." $fname]
9725 } elseif {[regexp -line \
9726 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9727 $err]} {
9728 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9729 conflict.\nDo you wish to run git citool to\
9730 resolve it?"]]} {
9731 # Force citool to read MERGE_MSG
9732 file delete [file join $gitdir "GITGUI_MSG"]
9733 exec_citool {} $rowmenuid
9735 } else {
9736 error_popup $err
9738 run updatecommits
9739 return
9741 set newhead [exec git rev-parse HEAD]
9742 if {$newhead eq $oldhead} {
9743 notbusy cherrypick
9744 error_popup [mc "No changes committed"]
9745 return
9747 addnewchild $newhead $oldhead
9748 if {[commitinview $oldhead $curview]} {
9749 # XXX this isn't right if we have a path limit...
9750 insertrow $newhead $oldhead $curview
9751 if {$mainhead ne {}} {
9752 movehead $newhead $mainhead
9753 movedhead $newhead $mainhead
9755 set mainheadid $newhead
9756 redrawtags $oldhead
9757 redrawtags $newhead
9758 selbyid $newhead
9760 notbusy cherrypick
9763 proc revert {} {
9764 global rowmenuid curview
9765 global mainhead mainheadid
9766 global gitdir
9768 set oldhead [exec git rev-parse HEAD]
9769 set dheads [descheads $rowmenuid]
9770 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9771 set ok [confirm_popup [mc "Commit %s is not\
9772 included in branch %s -- really revert it?" \
9773 [string range $rowmenuid 0 7] $mainhead]]
9774 if {!$ok} return
9776 nowbusy revert [mc "Reverting"]
9777 update
9779 if [catch {exec git revert --no-edit $rowmenuid} err] {
9780 notbusy revert
9781 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9782 $err match files] {
9783 regsub {\n( |\t)+} $files "\n" files
9784 error_popup [mc "Revert failed because of local changes to\
9785 the following files:%s Please commit, reset or stash \
9786 your changes and try again." $files]
9787 } elseif [regexp {error: could not revert} $err] {
9788 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9789 Do you wish to run git citool to resolve it?"]] {
9790 # Force citool to read MERGE_MSG
9791 file delete [file join $gitdir "GITGUI_MSG"]
9792 exec_citool {} $rowmenuid
9794 } else { error_popup $err }
9795 run updatecommits
9796 return
9799 set newhead [exec git rev-parse HEAD]
9800 if { $newhead eq $oldhead } {
9801 notbusy revert
9802 error_popup [mc "No changes committed"]
9803 return
9806 addnewchild $newhead $oldhead
9808 if [commitinview $oldhead $curview] {
9809 # XXX this isn't right if we have a path limit...
9810 insertrow $newhead $oldhead $curview
9811 if {$mainhead ne {}} {
9812 movehead $newhead $mainhead
9813 movedhead $newhead $mainhead
9815 set mainheadid $newhead
9816 redrawtags $oldhead
9817 redrawtags $newhead
9818 selbyid $newhead
9821 notbusy revert
9824 proc resethead {} {
9825 global mainhead rowmenuid confirm_ok resettype NS
9827 set confirm_ok 0
9828 set w ".confirmreset"
9829 ttk_toplevel $w
9830 make_transient $w .
9831 wm title $w [mc "Confirm reset"]
9832 ${NS}::label $w.m -text \
9833 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9834 pack $w.m -side top -fill x -padx 20 -pady 20
9835 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9836 set resettype mixed
9837 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9838 -text [mc "Soft: Leave working tree and index untouched"]
9839 grid $w.f.soft -sticky w
9840 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9841 -text [mc "Mixed: Leave working tree untouched, reset index"]
9842 grid $w.f.mixed -sticky w
9843 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9844 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9845 grid $w.f.hard -sticky w
9846 pack $w.f -side top -fill x -padx 4
9847 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9848 pack $w.ok -side left -fill x -padx 20 -pady 20
9849 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9850 bind $w <Key-Escape> [list destroy $w]
9851 pack $w.cancel -side right -fill x -padx 20 -pady 20
9852 bind $w <Visibility> "grab $w; focus $w"
9853 tkwait window $w
9854 if {!$confirm_ok} return
9855 if {[catch {set fd [open \
9856 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9857 error_popup $err
9858 } else {
9859 dohidelocalchanges
9860 filerun $fd [list readresetstat $fd]
9861 nowbusy reset [mc "Resetting"]
9862 selbyid $rowmenuid
9866 proc readresetstat {fd} {
9867 global mainhead mainheadid showlocalchanges rprogcoord
9869 if {[gets $fd line] >= 0} {
9870 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9871 set rprogcoord [expr {1.0 * $m / $n}]
9872 adjustprogress
9874 return 1
9876 set rprogcoord 0
9877 adjustprogress
9878 notbusy reset
9879 if {[catch {close $fd} err]} {
9880 error_popup $err
9882 set oldhead $mainheadid
9883 set newhead [exec git rev-parse HEAD]
9884 if {$newhead ne $oldhead} {
9885 movehead $newhead $mainhead
9886 movedhead $newhead $mainhead
9887 set mainheadid $newhead
9888 redrawtags $oldhead
9889 redrawtags $newhead
9891 if {$showlocalchanges} {
9892 doshowlocalchanges
9894 return 0
9897 # context menu for a head
9898 proc headmenu {x y id head} {
9899 global headmenuid headmenuhead headctxmenu mainhead headids
9901 stopfinding
9902 set headmenuid $id
9903 set headmenuhead $head
9904 array set state {0 normal 1 normal 2 normal}
9905 if {[string match "remotes/*" $head]} {
9906 set localhead [string range $head [expr [string last / $head] + 1] end]
9907 if {[info exists headids($localhead)]} {
9908 set state(0) disabled
9910 array set state {1 disabled 2 disabled}
9912 if {$head eq $mainhead} {
9913 array set state {0 disabled 2 disabled}
9915 foreach i {0 1 2} {
9916 $headctxmenu entryconfigure $i -state $state($i)
9918 tk_popup $headctxmenu $x $y
9921 proc cobranch {} {
9922 global headmenuid headmenuhead headids
9923 global showlocalchanges
9925 # check the tree is clean first??
9926 set newhead $headmenuhead
9927 set command [list | git checkout]
9928 if {[string match "remotes/*" $newhead]} {
9929 set remote $newhead
9930 set newhead [string range $newhead [expr [string last / $newhead] + 1] end]
9931 # The following check is redundant - the menu option should
9932 # be disabled to begin with...
9933 if {[info exists headids($newhead)]} {
9934 error_popup [mc "A local branch named %s exists already" $newhead]
9935 return
9937 lappend command -b $newhead --track $remote
9938 } else {
9939 lappend command $newhead
9941 lappend command 2>@1
9942 nowbusy checkout [mc "Checking out"]
9943 update
9944 dohidelocalchanges
9945 if {[catch {
9946 set fd [open $command r]
9947 } err]} {
9948 notbusy checkout
9949 error_popup $err
9950 if {$showlocalchanges} {
9951 dodiffindex
9953 } else {
9954 filerun $fd [list readcheckoutstat $fd $newhead $headmenuid]
9958 proc readcheckoutstat {fd newhead newheadid} {
9959 global mainhead mainheadid headids idheads showlocalchanges progresscoords
9960 global viewmainheadid curview
9962 if {[gets $fd line] >= 0} {
9963 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9964 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9965 adjustprogress
9967 return 1
9969 set progresscoords {0 0}
9970 adjustprogress
9971 notbusy checkout
9972 if {[catch {close $fd} err]} {
9973 error_popup $err
9974 return
9976 set oldmainid $mainheadid
9977 if {! [info exists headids($newhead)]} {
9978 set headids($newhead) $newheadid
9979 lappend idheads($newheadid) $newhead
9980 addedhead $newheadid $newhead
9982 set mainhead $newhead
9983 set mainheadid $newheadid
9984 set viewmainheadid($curview) $newheadid
9985 redrawtags $oldmainid
9986 redrawtags $newheadid
9987 selbyid $newheadid
9988 if {$showlocalchanges} {
9989 dodiffindex
9993 proc rmbranch {} {
9994 global headmenuid headmenuhead mainhead
9995 global idheads
9997 set head $headmenuhead
9998 set id $headmenuid
9999 # this check shouldn't be needed any more...
10000 if {$head eq $mainhead} {
10001 error_popup [mc "Cannot delete the currently checked-out branch"]
10002 return
10004 set dheads [descheads $id]
10005 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
10006 # the stuff on this branch isn't on any other branch
10007 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
10008 branch.\nReally delete branch %s?" $head $head]]} return
10010 nowbusy rmbranch
10011 update
10012 if {[catch {exec git branch -D $head} err]} {
10013 notbusy rmbranch
10014 error_popup $err
10015 return
10017 removehead $id $head
10018 removedhead $id $head
10019 redrawtags $id
10020 notbusy rmbranch
10021 dispneartags 0
10022 run refill_reflist
10025 # Display a list of tags and heads
10026 proc showrefs {} {
10027 global showrefstop bgcolor fgcolor selectbgcolor NS
10028 global bglist fglist reflistfilter reflist maincursor
10030 set top .showrefs
10031 set showrefstop $top
10032 if {[winfo exists $top]} {
10033 raise $top
10034 refill_reflist
10035 return
10037 ttk_toplevel $top
10038 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
10039 make_transient $top .
10040 text $top.list -background $bgcolor -foreground $fgcolor \
10041 -selectbackground $selectbgcolor -font mainfont \
10042 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
10043 -width 30 -height 20 -cursor $maincursor \
10044 -spacing1 1 -spacing3 1 -state disabled
10045 $top.list tag configure highlight -background $selectbgcolor
10046 if {![lsearch -exact $bglist $top.list]} {
10047 lappend bglist $top.list
10048 lappend fglist $top.list
10050 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
10051 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
10052 grid $top.list $top.ysb -sticky nsew
10053 grid $top.xsb x -sticky ew
10054 ${NS}::frame $top.f
10055 ${NS}::label $top.f.l -text "[mc "Filter"]: "
10056 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
10057 set reflistfilter "*"
10058 trace add variable reflistfilter write reflistfilter_change
10059 pack $top.f.e -side right -fill x -expand 1
10060 pack $top.f.l -side left
10061 grid $top.f - -sticky ew -pady 2
10062 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
10063 bind $top <Key-Escape> [list destroy $top]
10064 grid $top.close -
10065 grid columnconfigure $top 0 -weight 1
10066 grid rowconfigure $top 0 -weight 1
10067 bind $top.list <1> {break}
10068 bind $top.list <B1-Motion> {break}
10069 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
10070 set reflist {}
10071 refill_reflist
10074 proc sel_reflist {w x y} {
10075 global showrefstop reflist headids tagids otherrefids
10077 if {![winfo exists $showrefstop]} return
10078 set l [lindex [split [$w index "@$x,$y"] "."] 0]
10079 set ref [lindex $reflist [expr {$l-1}]]
10080 set n [lindex $ref 0]
10081 switch -- [lindex $ref 1] {
10082 "H" {selbyid $headids($n)}
10083 "R" {selbyid $headids($n)}
10084 "T" {selbyid $tagids($n)}
10085 "o" {selbyid $otherrefids($n)}
10087 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
10090 proc unsel_reflist {} {
10091 global showrefstop
10093 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10094 $showrefstop.list tag remove highlight 0.0 end
10097 proc reflistfilter_change {n1 n2 op} {
10098 global reflistfilter
10100 after cancel refill_reflist
10101 after 200 refill_reflist
10104 proc refill_reflist {} {
10105 global reflist reflistfilter showrefstop headids tagids otherrefids
10106 global curview
10108 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10109 set refs {}
10110 foreach n [array names headids] {
10111 if {[string match $reflistfilter $n]} {
10112 if {[commitinview $headids($n) $curview]} {
10113 if {[string match "remotes/*" $n]} {
10114 lappend refs [list $n R]
10115 } else {
10116 lappend refs [list $n H]
10118 } else {
10119 interestedin $headids($n) {run refill_reflist}
10123 foreach n [array names tagids] {
10124 if {[string match $reflistfilter $n]} {
10125 if {[commitinview $tagids($n) $curview]} {
10126 lappend refs [list $n T]
10127 } else {
10128 interestedin $tagids($n) {run refill_reflist}
10132 foreach n [array names otherrefids] {
10133 if {[string match $reflistfilter $n]} {
10134 if {[commitinview $otherrefids($n) $curview]} {
10135 lappend refs [list $n o]
10136 } else {
10137 interestedin $otherrefids($n) {run refill_reflist}
10141 set refs [lsort -index 0 $refs]
10142 if {$refs eq $reflist} return
10144 # Update the contents of $showrefstop.list according to the
10145 # differences between $reflist (old) and $refs (new)
10146 $showrefstop.list conf -state normal
10147 $showrefstop.list insert end "\n"
10148 set i 0
10149 set j 0
10150 while {$i < [llength $reflist] || $j < [llength $refs]} {
10151 if {$i < [llength $reflist]} {
10152 if {$j < [llength $refs]} {
10153 set cmp [string compare [lindex $reflist $i 0] \
10154 [lindex $refs $j 0]]
10155 if {$cmp == 0} {
10156 set cmp [string compare [lindex $reflist $i 1] \
10157 [lindex $refs $j 1]]
10159 } else {
10160 set cmp -1
10162 } else {
10163 set cmp 1
10165 switch -- $cmp {
10166 -1 {
10167 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
10168 incr i
10171 incr i
10172 incr j
10175 set l [expr {$j + 1}]
10176 $showrefstop.list image create $l.0 -align baseline \
10177 -image reficon-[lindex $refs $j 1] -padx 2
10178 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
10179 incr j
10183 set reflist $refs
10184 # delete last newline
10185 $showrefstop.list delete end-2c end-1c
10186 $showrefstop.list conf -state disabled
10189 # Stuff for finding nearby tags
10190 proc getallcommits {} {
10191 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
10192 global idheads idtags idotherrefs allparents tagobjid
10193 global gitdir
10195 if {![info exists allcommits]} {
10196 set nextarc 0
10197 set allcommits 0
10198 set seeds {}
10199 set allcwait 0
10200 set cachedarcs 0
10201 set allccache [file join $gitdir "gitk.cache"]
10202 if {![catch {
10203 set f [open $allccache r]
10204 set allcwait 1
10205 getcache $f
10206 }]} return
10209 if {$allcwait} {
10210 return
10212 set cmd [list | git rev-list --parents]
10213 set allcupdate [expr {$seeds ne {}}]
10214 if {!$allcupdate} {
10215 set ids "--all"
10216 } else {
10217 set refs [concat [array names idheads] [array names idtags] \
10218 [array names idotherrefs]]
10219 set ids {}
10220 set tagobjs {}
10221 foreach name [array names tagobjid] {
10222 lappend tagobjs $tagobjid($name)
10224 foreach id [lsort -unique $refs] {
10225 if {![info exists allparents($id)] &&
10226 [lsearch -exact $tagobjs $id] < 0} {
10227 lappend ids $id
10230 if {$ids ne {}} {
10231 foreach id $seeds {
10232 lappend ids "^$id"
10236 if {$ids ne {}} {
10237 set fd [open [concat $cmd $ids] r]
10238 fconfigure $fd -blocking 0
10239 incr allcommits
10240 nowbusy allcommits
10241 filerun $fd [list getallclines $fd]
10242 } else {
10243 dispneartags 0
10247 # Since most commits have 1 parent and 1 child, we group strings of
10248 # such commits into "arcs" joining branch/merge points (BMPs), which
10249 # are commits that either don't have 1 parent or don't have 1 child.
10251 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10252 # arcout(id) - outgoing arcs for BMP
10253 # arcids(a) - list of IDs on arc including end but not start
10254 # arcstart(a) - BMP ID at start of arc
10255 # arcend(a) - BMP ID at end of arc
10256 # growing(a) - arc a is still growing
10257 # arctags(a) - IDs out of arcids (excluding end) that have tags
10258 # archeads(a) - IDs out of arcids (excluding end) that have heads
10259 # The start of an arc is at the descendent end, so "incoming" means
10260 # coming from descendents, and "outgoing" means going towards ancestors.
10262 proc getallclines {fd} {
10263 global allparents allchildren idtags idheads nextarc
10264 global arcnos arcids arctags arcout arcend arcstart archeads growing
10265 global seeds allcommits cachedarcs allcupdate
10267 set nid 0
10268 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10269 set id [lindex $line 0]
10270 if {[info exists allparents($id)]} {
10271 # seen it already
10272 continue
10274 set cachedarcs 0
10275 set olds [lrange $line 1 end]
10276 set allparents($id) $olds
10277 if {![info exists allchildren($id)]} {
10278 set allchildren($id) {}
10279 set arcnos($id) {}
10280 lappend seeds $id
10281 } else {
10282 set a $arcnos($id)
10283 if {[llength $olds] == 1 && [llength $a] == 1} {
10284 lappend arcids($a) $id
10285 if {[info exists idtags($id)]} {
10286 lappend arctags($a) $id
10288 if {[info exists idheads($id)]} {
10289 lappend archeads($a) $id
10291 if {[info exists allparents($olds)]} {
10292 # seen parent already
10293 if {![info exists arcout($olds)]} {
10294 splitarc $olds
10296 lappend arcids($a) $olds
10297 set arcend($a) $olds
10298 unset growing($a)
10300 lappend allchildren($olds) $id
10301 lappend arcnos($olds) $a
10302 continue
10305 foreach a $arcnos($id) {
10306 lappend arcids($a) $id
10307 set arcend($a) $id
10308 unset growing($a)
10311 set ao {}
10312 foreach p $olds {
10313 lappend allchildren($p) $id
10314 set a [incr nextarc]
10315 set arcstart($a) $id
10316 set archeads($a) {}
10317 set arctags($a) {}
10318 set archeads($a) {}
10319 set arcids($a) {}
10320 lappend ao $a
10321 set growing($a) 1
10322 if {[info exists allparents($p)]} {
10323 # seen it already, may need to make a new branch
10324 if {![info exists arcout($p)]} {
10325 splitarc $p
10327 lappend arcids($a) $p
10328 set arcend($a) $p
10329 unset growing($a)
10331 lappend arcnos($p) $a
10333 set arcout($id) $ao
10335 if {$nid > 0} {
10336 global cached_dheads cached_dtags cached_atags
10337 unset -nocomplain cached_dheads
10338 unset -nocomplain cached_dtags
10339 unset -nocomplain cached_atags
10341 if {![eof $fd]} {
10342 return [expr {$nid >= 1000? 2: 1}]
10344 set cacheok 1
10345 if {[catch {
10346 fconfigure $fd -blocking 1
10347 close $fd
10348 } err]} {
10349 # got an error reading the list of commits
10350 # if we were updating, try rereading the whole thing again
10351 if {$allcupdate} {
10352 incr allcommits -1
10353 dropcache $err
10354 return
10356 error_popup "[mc "Error reading commit topology information;\
10357 branch and preceding/following tag information\
10358 will be incomplete."]\n($err)"
10359 set cacheok 0
10361 if {[incr allcommits -1] == 0} {
10362 notbusy allcommits
10363 if {$cacheok} {
10364 run savecache
10367 dispneartags 0
10368 return 0
10371 proc recalcarc {a} {
10372 global arctags archeads arcids idtags idheads
10374 set at {}
10375 set ah {}
10376 foreach id [lrange $arcids($a) 0 end-1] {
10377 if {[info exists idtags($id)]} {
10378 lappend at $id
10380 if {[info exists idheads($id)]} {
10381 lappend ah $id
10384 set arctags($a) $at
10385 set archeads($a) $ah
10388 proc splitarc {p} {
10389 global arcnos arcids nextarc arctags archeads idtags idheads
10390 global arcstart arcend arcout allparents growing
10392 set a $arcnos($p)
10393 if {[llength $a] != 1} {
10394 puts "oops splitarc called but [llength $a] arcs already"
10395 return
10397 set a [lindex $a 0]
10398 set i [lsearch -exact $arcids($a) $p]
10399 if {$i < 0} {
10400 puts "oops splitarc $p not in arc $a"
10401 return
10403 set na [incr nextarc]
10404 if {[info exists arcend($a)]} {
10405 set arcend($na) $arcend($a)
10406 } else {
10407 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10408 set j [lsearch -exact $arcnos($l) $a]
10409 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10411 set tail [lrange $arcids($a) [expr {$i+1}] end]
10412 set arcids($a) [lrange $arcids($a) 0 $i]
10413 set arcend($a) $p
10414 set arcstart($na) $p
10415 set arcout($p) $na
10416 set arcids($na) $tail
10417 if {[info exists growing($a)]} {
10418 set growing($na) 1
10419 unset growing($a)
10422 foreach id $tail {
10423 if {[llength $arcnos($id)] == 1} {
10424 set arcnos($id) $na
10425 } else {
10426 set j [lsearch -exact $arcnos($id) $a]
10427 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10431 # reconstruct tags and heads lists
10432 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10433 recalcarc $a
10434 recalcarc $na
10435 } else {
10436 set arctags($na) {}
10437 set archeads($na) {}
10441 # Update things for a new commit added that is a child of one
10442 # existing commit. Used when cherry-picking.
10443 proc addnewchild {id p} {
10444 global allparents allchildren idtags nextarc
10445 global arcnos arcids arctags arcout arcend arcstart archeads growing
10446 global seeds allcommits
10448 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10449 set allparents($id) [list $p]
10450 set allchildren($id) {}
10451 set arcnos($id) {}
10452 lappend seeds $id
10453 lappend allchildren($p) $id
10454 set a [incr nextarc]
10455 set arcstart($a) $id
10456 set archeads($a) {}
10457 set arctags($a) {}
10458 set arcids($a) [list $p]
10459 set arcend($a) $p
10460 if {![info exists arcout($p)]} {
10461 splitarc $p
10463 lappend arcnos($p) $a
10464 set arcout($id) [list $a]
10467 # This implements a cache for the topology information.
10468 # The cache saves, for each arc, the start and end of the arc,
10469 # the ids on the arc, and the outgoing arcs from the end.
10470 proc readcache {f} {
10471 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10472 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10473 global allcwait
10475 set a $nextarc
10476 set lim $cachedarcs
10477 if {$lim - $a > 500} {
10478 set lim [expr {$a + 500}]
10480 if {[catch {
10481 if {$a == $lim} {
10482 # finish reading the cache and setting up arctags, etc.
10483 set line [gets $f]
10484 if {$line ne "1"} {error "bad final version"}
10485 close $f
10486 foreach id [array names idtags] {
10487 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10488 [llength $allparents($id)] == 1} {
10489 set a [lindex $arcnos($id) 0]
10490 if {$arctags($a) eq {}} {
10491 recalcarc $a
10495 foreach id [array names idheads] {
10496 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10497 [llength $allparents($id)] == 1} {
10498 set a [lindex $arcnos($id) 0]
10499 if {$archeads($a) eq {}} {
10500 recalcarc $a
10504 foreach id [lsort -unique $possible_seeds] {
10505 if {$arcnos($id) eq {}} {
10506 lappend seeds $id
10509 set allcwait 0
10510 } else {
10511 while {[incr a] <= $lim} {
10512 set line [gets $f]
10513 if {[llength $line] != 3} {error "bad line"}
10514 set s [lindex $line 0]
10515 set arcstart($a) $s
10516 lappend arcout($s) $a
10517 if {![info exists arcnos($s)]} {
10518 lappend possible_seeds $s
10519 set arcnos($s) {}
10521 set e [lindex $line 1]
10522 if {$e eq {}} {
10523 set growing($a) 1
10524 } else {
10525 set arcend($a) $e
10526 if {![info exists arcout($e)]} {
10527 set arcout($e) {}
10530 set arcids($a) [lindex $line 2]
10531 foreach id $arcids($a) {
10532 lappend allparents($s) $id
10533 set s $id
10534 lappend arcnos($id) $a
10536 if {![info exists allparents($s)]} {
10537 set allparents($s) {}
10539 set arctags($a) {}
10540 set archeads($a) {}
10542 set nextarc [expr {$a - 1}]
10544 } err]} {
10545 dropcache $err
10546 return 0
10548 if {!$allcwait} {
10549 getallcommits
10551 return $allcwait
10554 proc getcache {f} {
10555 global nextarc cachedarcs possible_seeds
10557 if {[catch {
10558 set line [gets $f]
10559 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10560 # make sure it's an integer
10561 set cachedarcs [expr {int([lindex $line 1])}]
10562 if {$cachedarcs < 0} {error "bad number of arcs"}
10563 set nextarc 0
10564 set possible_seeds {}
10565 run readcache $f
10566 } err]} {
10567 dropcache $err
10569 return 0
10572 proc dropcache {err} {
10573 global allcwait nextarc cachedarcs seeds
10575 #puts "dropping cache ($err)"
10576 foreach v {arcnos arcout arcids arcstart arcend growing \
10577 arctags archeads allparents allchildren} {
10578 global $v
10579 unset -nocomplain $v
10581 set allcwait 0
10582 set nextarc 0
10583 set cachedarcs 0
10584 set seeds {}
10585 getallcommits
10588 proc writecache {f} {
10589 global cachearc cachedarcs allccache
10590 global arcstart arcend arcnos arcids arcout
10592 set a $cachearc
10593 set lim $cachedarcs
10594 if {$lim - $a > 1000} {
10595 set lim [expr {$a + 1000}]
10597 if {[catch {
10598 while {[incr a] <= $lim} {
10599 if {[info exists arcend($a)]} {
10600 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10601 } else {
10602 puts $f [list $arcstart($a) {} $arcids($a)]
10605 } err]} {
10606 catch {close $f}
10607 catch {file delete $allccache}
10608 #puts "writing cache failed ($err)"
10609 return 0
10611 set cachearc [expr {$a - 1}]
10612 if {$a > $cachedarcs} {
10613 puts $f "1"
10614 close $f
10615 return 0
10617 return 1
10620 proc savecache {} {
10621 global nextarc cachedarcs cachearc allccache
10623 if {$nextarc == $cachedarcs} return
10624 set cachearc 0
10625 set cachedarcs $nextarc
10626 catch {
10627 set f [open $allccache w]
10628 puts $f [list 1 $cachedarcs]
10629 run writecache $f
10633 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10634 # or 0 if neither is true.
10635 proc anc_or_desc {a b} {
10636 global arcout arcstart arcend arcnos cached_isanc
10638 if {$arcnos($a) eq $arcnos($b)} {
10639 # Both are on the same arc(s); either both are the same BMP,
10640 # or if one is not a BMP, the other is also not a BMP or is
10641 # the BMP at end of the arc (and it only has 1 incoming arc).
10642 # Or both can be BMPs with no incoming arcs.
10643 if {$a eq $b || $arcnos($a) eq {}} {
10644 return 0
10646 # assert {[llength $arcnos($a)] == 1}
10647 set arc [lindex $arcnos($a) 0]
10648 set i [lsearch -exact $arcids($arc) $a]
10649 set j [lsearch -exact $arcids($arc) $b]
10650 if {$i < 0 || $i > $j} {
10651 return 1
10652 } else {
10653 return -1
10657 if {![info exists arcout($a)]} {
10658 set arc [lindex $arcnos($a) 0]
10659 if {[info exists arcend($arc)]} {
10660 set aend $arcend($arc)
10661 } else {
10662 set aend {}
10664 set a $arcstart($arc)
10665 } else {
10666 set aend $a
10668 if {![info exists arcout($b)]} {
10669 set arc [lindex $arcnos($b) 0]
10670 if {[info exists arcend($arc)]} {
10671 set bend $arcend($arc)
10672 } else {
10673 set bend {}
10675 set b $arcstart($arc)
10676 } else {
10677 set bend $b
10679 if {$a eq $bend} {
10680 return 1
10682 if {$b eq $aend} {
10683 return -1
10685 if {[info exists cached_isanc($a,$bend)]} {
10686 if {$cached_isanc($a,$bend)} {
10687 return 1
10690 if {[info exists cached_isanc($b,$aend)]} {
10691 if {$cached_isanc($b,$aend)} {
10692 return -1
10694 if {[info exists cached_isanc($a,$bend)]} {
10695 return 0
10699 set todo [list $a $b]
10700 set anc($a) a
10701 set anc($b) b
10702 for {set i 0} {$i < [llength $todo]} {incr i} {
10703 set x [lindex $todo $i]
10704 if {$anc($x) eq {}} {
10705 continue
10707 foreach arc $arcnos($x) {
10708 set xd $arcstart($arc)
10709 if {$xd eq $bend} {
10710 set cached_isanc($a,$bend) 1
10711 set cached_isanc($b,$aend) 0
10712 return 1
10713 } elseif {$xd eq $aend} {
10714 set cached_isanc($b,$aend) 1
10715 set cached_isanc($a,$bend) 0
10716 return -1
10718 if {![info exists anc($xd)]} {
10719 set anc($xd) $anc($x)
10720 lappend todo $xd
10721 } elseif {$anc($xd) ne $anc($x)} {
10722 set anc($xd) {}
10726 set cached_isanc($a,$bend) 0
10727 set cached_isanc($b,$aend) 0
10728 return 0
10731 # This identifies whether $desc has an ancestor that is
10732 # a growing tip of the graph and which is not an ancestor of $anc
10733 # and returns 0 if so and 1 if not.
10734 # If we subsequently discover a tag on such a growing tip, and that
10735 # turns out to be a descendent of $anc (which it could, since we
10736 # don't necessarily see children before parents), then $desc
10737 # isn't a good choice to display as a descendent tag of
10738 # $anc (since it is the descendent of another tag which is
10739 # a descendent of $anc). Similarly, $anc isn't a good choice to
10740 # display as a ancestor tag of $desc.
10742 proc is_certain {desc anc} {
10743 global arcnos arcout arcstart arcend growing problems
10745 set certain {}
10746 if {[llength $arcnos($anc)] == 1} {
10747 # tags on the same arc are certain
10748 if {$arcnos($desc) eq $arcnos($anc)} {
10749 return 1
10751 if {![info exists arcout($anc)]} {
10752 # if $anc is partway along an arc, use the start of the arc instead
10753 set a [lindex $arcnos($anc) 0]
10754 set anc $arcstart($a)
10757 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10758 set x $desc
10759 } else {
10760 set a [lindex $arcnos($desc) 0]
10761 set x $arcend($a)
10763 if {$x == $anc} {
10764 return 1
10766 set anclist [list $x]
10767 set dl($x) 1
10768 set nnh 1
10769 set ngrowanc 0
10770 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10771 set x [lindex $anclist $i]
10772 if {$dl($x)} {
10773 incr nnh -1
10775 set done($x) 1
10776 foreach a $arcout($x) {
10777 if {[info exists growing($a)]} {
10778 if {![info exists growanc($x)] && $dl($x)} {
10779 set growanc($x) 1
10780 incr ngrowanc
10782 } else {
10783 set y $arcend($a)
10784 if {[info exists dl($y)]} {
10785 if {$dl($y)} {
10786 if {!$dl($x)} {
10787 set dl($y) 0
10788 if {![info exists done($y)]} {
10789 incr nnh -1
10791 if {[info exists growanc($x)]} {
10792 incr ngrowanc -1
10794 set xl [list $y]
10795 for {set k 0} {$k < [llength $xl]} {incr k} {
10796 set z [lindex $xl $k]
10797 foreach c $arcout($z) {
10798 if {[info exists arcend($c)]} {
10799 set v $arcend($c)
10800 if {[info exists dl($v)] && $dl($v)} {
10801 set dl($v) 0
10802 if {![info exists done($v)]} {
10803 incr nnh -1
10805 if {[info exists growanc($v)]} {
10806 incr ngrowanc -1
10808 lappend xl $v
10815 } elseif {$y eq $anc || !$dl($x)} {
10816 set dl($y) 0
10817 lappend anclist $y
10818 } else {
10819 set dl($y) 1
10820 lappend anclist $y
10821 incr nnh
10826 foreach x [array names growanc] {
10827 if {$dl($x)} {
10828 return 0
10830 return 0
10832 return 1
10835 proc validate_arctags {a} {
10836 global arctags idtags
10838 set i -1
10839 set na $arctags($a)
10840 foreach id $arctags($a) {
10841 incr i
10842 if {![info exists idtags($id)]} {
10843 set na [lreplace $na $i $i]
10844 incr i -1
10847 set arctags($a) $na
10850 proc validate_archeads {a} {
10851 global archeads idheads
10853 set i -1
10854 set na $archeads($a)
10855 foreach id $archeads($a) {
10856 incr i
10857 if {![info exists idheads($id)]} {
10858 set na [lreplace $na $i $i]
10859 incr i -1
10862 set archeads($a) $na
10865 # Return the list of IDs that have tags that are descendents of id,
10866 # ignoring IDs that are descendents of IDs already reported.
10867 proc desctags {id} {
10868 global arcnos arcstart arcids arctags idtags allparents
10869 global growing cached_dtags
10871 if {![info exists allparents($id)]} {
10872 return {}
10874 set t1 [clock clicks -milliseconds]
10875 set argid $id
10876 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10877 # part-way along an arc; check that arc first
10878 set a [lindex $arcnos($id) 0]
10879 if {$arctags($a) ne {}} {
10880 validate_arctags $a
10881 set i [lsearch -exact $arcids($a) $id]
10882 set tid {}
10883 foreach t $arctags($a) {
10884 set j [lsearch -exact $arcids($a) $t]
10885 if {$j >= $i} break
10886 set tid $t
10888 if {$tid ne {}} {
10889 return $tid
10892 set id $arcstart($a)
10893 if {[info exists idtags($id)]} {
10894 return $id
10897 if {[info exists cached_dtags($id)]} {
10898 return $cached_dtags($id)
10901 set origid $id
10902 set todo [list $id]
10903 set queued($id) 1
10904 set nc 1
10905 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10906 set id [lindex $todo $i]
10907 set done($id) 1
10908 set ta [info exists hastaggedancestor($id)]
10909 if {!$ta} {
10910 incr nc -1
10912 # ignore tags on starting node
10913 if {!$ta && $i > 0} {
10914 if {[info exists idtags($id)]} {
10915 set tagloc($id) $id
10916 set ta 1
10917 } elseif {[info exists cached_dtags($id)]} {
10918 set tagloc($id) $cached_dtags($id)
10919 set ta 1
10922 foreach a $arcnos($id) {
10923 set d $arcstart($a)
10924 if {!$ta && $arctags($a) ne {}} {
10925 validate_arctags $a
10926 if {$arctags($a) ne {}} {
10927 lappend tagloc($id) [lindex $arctags($a) end]
10930 if {$ta || $arctags($a) ne {}} {
10931 set tomark [list $d]
10932 for {set j 0} {$j < [llength $tomark]} {incr j} {
10933 set dd [lindex $tomark $j]
10934 if {![info exists hastaggedancestor($dd)]} {
10935 if {[info exists done($dd)]} {
10936 foreach b $arcnos($dd) {
10937 lappend tomark $arcstart($b)
10939 if {[info exists tagloc($dd)]} {
10940 unset tagloc($dd)
10942 } elseif {[info exists queued($dd)]} {
10943 incr nc -1
10945 set hastaggedancestor($dd) 1
10949 if {![info exists queued($d)]} {
10950 lappend todo $d
10951 set queued($d) 1
10952 if {![info exists hastaggedancestor($d)]} {
10953 incr nc
10958 set tags {}
10959 foreach id [array names tagloc] {
10960 if {![info exists hastaggedancestor($id)]} {
10961 foreach t $tagloc($id) {
10962 if {[lsearch -exact $tags $t] < 0} {
10963 lappend tags $t
10968 set t2 [clock clicks -milliseconds]
10969 set loopix $i
10971 # remove tags that are descendents of other tags
10972 for {set i 0} {$i < [llength $tags]} {incr i} {
10973 set a [lindex $tags $i]
10974 for {set j 0} {$j < $i} {incr j} {
10975 set b [lindex $tags $j]
10976 set r [anc_or_desc $a $b]
10977 if {$r == 1} {
10978 set tags [lreplace $tags $j $j]
10979 incr j -1
10980 incr i -1
10981 } elseif {$r == -1} {
10982 set tags [lreplace $tags $i $i]
10983 incr i -1
10984 break
10989 if {[array names growing] ne {}} {
10990 # graph isn't finished, need to check if any tag could get
10991 # eclipsed by another tag coming later. Simply ignore any
10992 # tags that could later get eclipsed.
10993 set ctags {}
10994 foreach t $tags {
10995 if {[is_certain $t $origid]} {
10996 lappend ctags $t
10999 if {$tags eq $ctags} {
11000 set cached_dtags($origid) $tags
11001 } else {
11002 set tags $ctags
11004 } else {
11005 set cached_dtags($origid) $tags
11007 set t3 [clock clicks -milliseconds]
11008 if {0 && $t3 - $t1 >= 100} {
11009 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
11010 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
11012 return $tags
11015 proc anctags {id} {
11016 global arcnos arcids arcout arcend arctags idtags allparents
11017 global growing cached_atags
11019 if {![info exists allparents($id)]} {
11020 return {}
11022 set t1 [clock clicks -milliseconds]
11023 set argid $id
11024 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
11025 # part-way along an arc; check that arc first
11026 set a [lindex $arcnos($id) 0]
11027 if {$arctags($a) ne {}} {
11028 validate_arctags $a
11029 set i [lsearch -exact $arcids($a) $id]
11030 foreach t $arctags($a) {
11031 set j [lsearch -exact $arcids($a) $t]
11032 if {$j > $i} {
11033 return $t
11037 if {![info exists arcend($a)]} {
11038 return {}
11040 set id $arcend($a)
11041 if {[info exists idtags($id)]} {
11042 return $id
11045 if {[info exists cached_atags($id)]} {
11046 return $cached_atags($id)
11049 set origid $id
11050 set todo [list $id]
11051 set queued($id) 1
11052 set taglist {}
11053 set nc 1
11054 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
11055 set id [lindex $todo $i]
11056 set done($id) 1
11057 set td [info exists hastaggeddescendent($id)]
11058 if {!$td} {
11059 incr nc -1
11061 # ignore tags on starting node
11062 if {!$td && $i > 0} {
11063 if {[info exists idtags($id)]} {
11064 set tagloc($id) $id
11065 set td 1
11066 } elseif {[info exists cached_atags($id)]} {
11067 set tagloc($id) $cached_atags($id)
11068 set td 1
11071 foreach a $arcout($id) {
11072 if {!$td && $arctags($a) ne {}} {
11073 validate_arctags $a
11074 if {$arctags($a) ne {}} {
11075 lappend tagloc($id) [lindex $arctags($a) 0]
11078 if {![info exists arcend($a)]} continue
11079 set d $arcend($a)
11080 if {$td || $arctags($a) ne {}} {
11081 set tomark [list $d]
11082 for {set j 0} {$j < [llength $tomark]} {incr j} {
11083 set dd [lindex $tomark $j]
11084 if {![info exists hastaggeddescendent($dd)]} {
11085 if {[info exists done($dd)]} {
11086 foreach b $arcout($dd) {
11087 if {[info exists arcend($b)]} {
11088 lappend tomark $arcend($b)
11091 if {[info exists tagloc($dd)]} {
11092 unset tagloc($dd)
11094 } elseif {[info exists queued($dd)]} {
11095 incr nc -1
11097 set hastaggeddescendent($dd) 1
11101 if {![info exists queued($d)]} {
11102 lappend todo $d
11103 set queued($d) 1
11104 if {![info exists hastaggeddescendent($d)]} {
11105 incr nc
11110 set t2 [clock clicks -milliseconds]
11111 set loopix $i
11112 set tags {}
11113 foreach id [array names tagloc] {
11114 if {![info exists hastaggeddescendent($id)]} {
11115 foreach t $tagloc($id) {
11116 if {[lsearch -exact $tags $t] < 0} {
11117 lappend tags $t
11123 # remove tags that are ancestors of other tags
11124 for {set i 0} {$i < [llength $tags]} {incr i} {
11125 set a [lindex $tags $i]
11126 for {set j 0} {$j < $i} {incr j} {
11127 set b [lindex $tags $j]
11128 set r [anc_or_desc $a $b]
11129 if {$r == -1} {
11130 set tags [lreplace $tags $j $j]
11131 incr j -1
11132 incr i -1
11133 } elseif {$r == 1} {
11134 set tags [lreplace $tags $i $i]
11135 incr i -1
11136 break
11141 if {[array names growing] ne {}} {
11142 # graph isn't finished, need to check if any tag could get
11143 # eclipsed by another tag coming later. Simply ignore any
11144 # tags that could later get eclipsed.
11145 set ctags {}
11146 foreach t $tags {
11147 if {[is_certain $origid $t]} {
11148 lappend ctags $t
11151 if {$tags eq $ctags} {
11152 set cached_atags($origid) $tags
11153 } else {
11154 set tags $ctags
11156 } else {
11157 set cached_atags($origid) $tags
11159 set t3 [clock clicks -milliseconds]
11160 if {0 && $t3 - $t1 >= 100} {
11161 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
11162 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
11164 return $tags
11167 # Return the list of IDs that have heads that are descendents of id,
11168 # including id itself if it has a head.
11169 proc descheads {id} {
11170 global arcnos arcstart arcids archeads idheads cached_dheads
11171 global allparents arcout
11173 if {![info exists allparents($id)]} {
11174 return {}
11176 set aret {}
11177 if {![info exists arcout($id)]} {
11178 # part-way along an arc; check it first
11179 set a [lindex $arcnos($id) 0]
11180 if {$archeads($a) ne {}} {
11181 validate_archeads $a
11182 set i [lsearch -exact $arcids($a) $id]
11183 foreach t $archeads($a) {
11184 set j [lsearch -exact $arcids($a) $t]
11185 if {$j > $i} break
11186 lappend aret $t
11189 set id $arcstart($a)
11191 set origid $id
11192 set todo [list $id]
11193 set seen($id) 1
11194 set ret {}
11195 for {set i 0} {$i < [llength $todo]} {incr i} {
11196 set id [lindex $todo $i]
11197 if {[info exists cached_dheads($id)]} {
11198 set ret [concat $ret $cached_dheads($id)]
11199 } else {
11200 if {[info exists idheads($id)]} {
11201 lappend ret $id
11203 foreach a $arcnos($id) {
11204 if {$archeads($a) ne {}} {
11205 validate_archeads $a
11206 if {$archeads($a) ne {}} {
11207 set ret [concat $ret $archeads($a)]
11210 set d $arcstart($a)
11211 if {![info exists seen($d)]} {
11212 lappend todo $d
11213 set seen($d) 1
11218 set ret [lsort -unique $ret]
11219 set cached_dheads($origid) $ret
11220 return [concat $ret $aret]
11223 proc addedtag {id} {
11224 global arcnos arcout cached_dtags cached_atags
11226 if {![info exists arcnos($id)]} return
11227 if {![info exists arcout($id)]} {
11228 recalcarc [lindex $arcnos($id) 0]
11230 unset -nocomplain cached_dtags
11231 unset -nocomplain cached_atags
11234 proc addedhead {hid head} {
11235 global arcnos arcout cached_dheads
11237 if {![info exists arcnos($hid)]} return
11238 if {![info exists arcout($hid)]} {
11239 recalcarc [lindex $arcnos($hid) 0]
11241 unset -nocomplain cached_dheads
11244 proc removedhead {hid head} {
11245 global cached_dheads
11247 unset -nocomplain cached_dheads
11250 proc movedhead {hid head} {
11251 global arcnos arcout cached_dheads
11253 if {![info exists arcnos($hid)]} return
11254 if {![info exists arcout($hid)]} {
11255 recalcarc [lindex $arcnos($hid) 0]
11257 unset -nocomplain cached_dheads
11260 proc changedrefs {} {
11261 global cached_dheads cached_dtags cached_atags cached_tagcontent
11262 global arctags archeads arcnos arcout idheads idtags
11264 foreach id [concat [array names idheads] [array names idtags]] {
11265 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11266 set a [lindex $arcnos($id) 0]
11267 if {![info exists donearc($a)]} {
11268 recalcarc $a
11269 set donearc($a) 1
11273 unset -nocomplain cached_tagcontent
11274 unset -nocomplain cached_dtags
11275 unset -nocomplain cached_atags
11276 unset -nocomplain cached_dheads
11279 proc rereadrefs {} {
11280 global idtags idheads idotherrefs mainheadid
11282 set refids [concat [array names idtags] \
11283 [array names idheads] [array names idotherrefs]]
11284 foreach id $refids {
11285 if {![info exists ref($id)]} {
11286 set ref($id) [listrefs $id]
11289 set oldmainhead $mainheadid
11290 readrefs
11291 changedrefs
11292 set refids [lsort -unique [concat $refids [array names idtags] \
11293 [array names idheads] [array names idotherrefs]]]
11294 foreach id $refids {
11295 set v [listrefs $id]
11296 if {![info exists ref($id)] || $ref($id) != $v} {
11297 redrawtags $id
11300 if {$oldmainhead ne $mainheadid} {
11301 redrawtags $oldmainhead
11302 redrawtags $mainheadid
11304 run refill_reflist
11307 proc listrefs {id} {
11308 global idtags idheads idotherrefs
11310 set x {}
11311 if {[info exists idtags($id)]} {
11312 set x $idtags($id)
11314 set y {}
11315 if {[info exists idheads($id)]} {
11316 set y $idheads($id)
11318 set z {}
11319 if {[info exists idotherrefs($id)]} {
11320 set z $idotherrefs($id)
11322 return [list $x $y $z]
11325 proc add_tag_ctext {tag} {
11326 global ctext cached_tagcontent tagids
11328 if {![info exists cached_tagcontent($tag)]} {
11329 catch {
11330 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11333 $ctext insert end "[mc "Tag"]: $tag\n" bold
11334 if {[info exists cached_tagcontent($tag)]} {
11335 set text $cached_tagcontent($tag)
11336 } else {
11337 set text "[mc "Id"]: $tagids($tag)"
11339 appendwithlinks $text {}
11342 proc showtag {tag isnew} {
11343 global ctext cached_tagcontent tagids linknum tagobjid
11345 if {$isnew} {
11346 addtohistory [list showtag $tag 0] savectextpos
11348 $ctext conf -state normal
11349 clear_ctext
11350 settabs 0
11351 set linknum 0
11352 add_tag_ctext $tag
11353 maybe_scroll_ctext 1
11354 $ctext conf -state disabled
11355 init_flist {}
11358 proc showtags {id isnew} {
11359 global idtags ctext linknum
11361 if {$isnew} {
11362 addtohistory [list showtags $id 0] savectextpos
11364 $ctext conf -state normal
11365 clear_ctext
11366 settabs 0
11367 set linknum 0
11368 set sep {}
11369 foreach tag $idtags($id) {
11370 $ctext insert end $sep
11371 add_tag_ctext $tag
11372 set sep "\n\n"
11374 maybe_scroll_ctext 1
11375 $ctext conf -state disabled
11376 init_flist {}
11379 proc doquit {} {
11380 global stopped
11381 global gitktmpdir
11383 set stopped 100
11384 savestuff .
11385 destroy .
11387 if {[info exists gitktmpdir]} {
11388 catch {file delete -force $gitktmpdir}
11392 proc mkfontdisp {font top which} {
11393 global fontattr fontpref $font NS use_ttk
11395 set fontpref($font) [set $font]
11396 ${NS}::button $top.${font}but -text $which \
11397 -command [list choosefont $font $which]
11398 ${NS}::label $top.$font -relief flat -font $font \
11399 -text $fontattr($font,family) -justify left
11400 grid x $top.${font}but $top.$font -sticky w
11403 proc choosefont {font which} {
11404 global fontparam fontlist fonttop fontattr
11405 global prefstop NS
11407 set fontparam(which) $which
11408 set fontparam(font) $font
11409 set fontparam(family) [font actual $font -family]
11410 set fontparam(size) $fontattr($font,size)
11411 set fontparam(weight) $fontattr($font,weight)
11412 set fontparam(slant) $fontattr($font,slant)
11413 set top .gitkfont
11414 set fonttop $top
11415 if {![winfo exists $top]} {
11416 font create sample
11417 eval font config sample [font actual $font]
11418 ttk_toplevel $top
11419 make_transient $top $prefstop
11420 wm title $top [mc "Gitk font chooser"]
11421 ${NS}::label $top.l -textvariable fontparam(which)
11422 pack $top.l -side top
11423 set fontlist [lsort [font families]]
11424 ${NS}::frame $top.f
11425 listbox $top.f.fam -listvariable fontlist \
11426 -yscrollcommand [list $top.f.sb set]
11427 bind $top.f.fam <<ListboxSelect>> selfontfam
11428 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11429 pack $top.f.sb -side right -fill y
11430 pack $top.f.fam -side left -fill both -expand 1
11431 pack $top.f -side top -fill both -expand 1
11432 ${NS}::frame $top.g
11433 spinbox $top.g.size -from 4 -to 40 -width 4 \
11434 -textvariable fontparam(size) \
11435 -validatecommand {string is integer -strict %s}
11436 checkbutton $top.g.bold -padx 5 \
11437 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11438 -variable fontparam(weight) -onvalue bold -offvalue normal
11439 checkbutton $top.g.ital -padx 5 \
11440 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11441 -variable fontparam(slant) -onvalue italic -offvalue roman
11442 pack $top.g.size $top.g.bold $top.g.ital -side left
11443 pack $top.g -side top
11444 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11445 -background white
11446 $top.c create text 100 25 -anchor center -text $which -font sample \
11447 -fill black -tags text
11448 bind $top.c <Configure> [list centertext $top.c]
11449 pack $top.c -side top -fill x
11450 ${NS}::frame $top.buts
11451 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11452 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11453 bind $top <Key-Return> fontok
11454 bind $top <Key-Escape> fontcan
11455 grid $top.buts.ok $top.buts.can
11456 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11457 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11458 pack $top.buts -side bottom -fill x
11459 trace add variable fontparam write chg_fontparam
11460 } else {
11461 raise $top
11462 $top.c itemconf text -text $which
11464 set i [lsearch -exact $fontlist $fontparam(family)]
11465 if {$i >= 0} {
11466 $top.f.fam selection set $i
11467 $top.f.fam see $i
11471 proc centertext {w} {
11472 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11475 proc fontok {} {
11476 global fontparam fontpref prefstop
11478 set f $fontparam(font)
11479 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11480 if {$fontparam(weight) eq "bold"} {
11481 lappend fontpref($f) "bold"
11483 if {$fontparam(slant) eq "italic"} {
11484 lappend fontpref($f) "italic"
11486 set w $prefstop.notebook.fonts.$f
11487 $w conf -text $fontparam(family) -font $fontpref($f)
11489 fontcan
11492 proc fontcan {} {
11493 global fonttop fontparam
11495 if {[info exists fonttop]} {
11496 catch {destroy $fonttop}
11497 catch {font delete sample}
11498 unset fonttop
11499 unset fontparam
11503 if {[package vsatisfies [package provide Tk] 8.6]} {
11504 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11505 # function to make use of it.
11506 proc choosefont {font which} {
11507 tk fontchooser configure -title $which -font $font \
11508 -command [list on_choosefont $font $which]
11509 tk fontchooser show
11511 proc on_choosefont {font which newfont} {
11512 global fontparam
11513 puts stderr "$font $newfont"
11514 array set f [font actual $newfont]
11515 set fontparam(which) $which
11516 set fontparam(font) $font
11517 set fontparam(family) $f(-family)
11518 set fontparam(size) $f(-size)
11519 set fontparam(weight) $f(-weight)
11520 set fontparam(slant) $f(-slant)
11521 fontok
11525 proc selfontfam {} {
11526 global fonttop fontparam
11528 set i [$fonttop.f.fam curselection]
11529 if {$i ne {}} {
11530 set fontparam(family) [$fonttop.f.fam get $i]
11534 proc chg_fontparam {v sub op} {
11535 global fontparam
11537 font config sample -$sub $fontparam($sub)
11540 # Create a property sheet tab page
11541 proc create_prefs_page {w} {
11542 global NS
11543 set parent [join [lrange [split $w .] 0 end-1] .]
11544 if {[winfo class $parent] eq "TNotebook"} {
11545 ${NS}::frame $w
11546 } else {
11547 ${NS}::labelframe $w
11551 proc prefspage_general {notebook} {
11552 global NS maxwidth maxgraphpct showneartags showlocalchanges
11553 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11554 global hideremotes want_ttk have_ttk maxrefs web_browser
11556 set page [create_prefs_page $notebook.general]
11558 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11559 grid $page.ldisp - -sticky w -pady 10
11560 ${NS}::label $page.spacer -text " "
11561 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11562 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11563 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11564 #xgettext:no-tcl-format
11565 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11566 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11567 grid x $page.maxpctl $page.maxpct -sticky w
11568 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11569 -variable showlocalchanges
11570 grid x $page.showlocal -sticky w
11571 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11572 -variable autoselect
11573 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11574 grid x $page.autoselect $page.autosellen -sticky w
11575 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11576 -variable hideremotes
11577 grid x $page.hideremotes -sticky w
11579 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11580 grid $page.ddisp - -sticky w -pady 10
11581 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11582 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11583 grid x $page.tabstopl $page.tabstop -sticky w
11584 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11585 -variable showneartags
11586 grid x $page.ntag -sticky w
11587 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11588 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11589 grid x $page.maxrefsl $page.maxrefs -sticky w
11590 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11591 -variable limitdiffs
11592 grid x $page.ldiff -sticky w
11593 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11594 -variable perfile_attrs
11595 grid x $page.lattr -sticky w
11597 ${NS}::entry $page.extdifft -textvariable extdifftool
11598 ${NS}::frame $page.extdifff
11599 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11600 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11601 pack $page.extdifff.l $page.extdifff.b -side left
11602 pack configure $page.extdifff.l -padx 10
11603 grid x $page.extdifff $page.extdifft -sticky ew
11605 ${NS}::entry $page.webbrowser -textvariable web_browser
11606 ${NS}::frame $page.webbrowserf
11607 ${NS}::label $page.webbrowserf.l -text [mc "Web browser" ]
11608 pack $page.webbrowserf.l -side left
11609 pack configure $page.webbrowserf.l -padx 10
11610 grid x $page.webbrowserf $page.webbrowser -sticky ew
11612 ${NS}::label $page.lgen -text [mc "General options"]
11613 grid $page.lgen - -sticky w -pady 10
11614 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11615 -text [mc "Use themed widgets"]
11616 if {$have_ttk} {
11617 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11618 } else {
11619 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11621 grid x $page.want_ttk $page.ttk_note -sticky w
11622 return $page
11625 proc prefspage_colors {notebook} {
11626 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11627 global diffbgcolors
11629 set page [create_prefs_page $notebook.colors]
11631 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11632 grid $page.cdisp - -sticky w -pady 10
11633 label $page.ui -padx 40 -relief sunk -background $uicolor
11634 ${NS}::button $page.uibut -text [mc "Interface"] \
11635 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11636 grid x $page.uibut $page.ui -sticky w
11637 label $page.bg -padx 40 -relief sunk -background $bgcolor
11638 ${NS}::button $page.bgbut -text [mc "Background"] \
11639 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11640 grid x $page.bgbut $page.bg -sticky w
11641 label $page.fg -padx 40 -relief sunk -background $fgcolor
11642 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11643 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11644 grid x $page.fgbut $page.fg -sticky w
11645 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11646 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11647 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11648 [list $ctext tag conf d0 -foreground]]
11649 grid x $page.diffoldbut $page.diffold -sticky w
11650 label $page.diffoldbg -padx 40 -relief sunk -background [lindex $diffbgcolors 0]
11651 ${NS}::button $page.diffoldbgbut -text [mc "Diff: old lines bg"] \
11652 -command [list choosecolor diffbgcolors 0 $page.diffoldbg \
11653 [mc "diff old lines bg"] \
11654 [list $ctext tag conf d0 -background]]
11655 grid x $page.diffoldbgbut $page.diffoldbg -sticky w
11656 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11657 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11658 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11659 [list $ctext tag conf dresult -foreground]]
11660 grid x $page.diffnewbut $page.diffnew -sticky w
11661 label $page.diffnewbg -padx 40 -relief sunk -background [lindex $diffbgcolors 1]
11662 ${NS}::button $page.diffnewbgbut -text [mc "Diff: new lines bg"] \
11663 -command [list choosecolor diffbgcolors 1 $page.diffnewbg \
11664 [mc "diff new lines bg"] \
11665 [list $ctext tag conf dresult -background]]
11666 grid x $page.diffnewbgbut $page.diffnewbg -sticky w
11667 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11668 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11669 -command [list choosecolor diffcolors 2 $page.hunksep \
11670 [mc "diff hunk header"] \
11671 [list $ctext tag conf hunksep -foreground]]
11672 grid x $page.hunksepbut $page.hunksep -sticky w
11673 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11674 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11675 -command [list choosecolor markbgcolor {} $page.markbgsep \
11676 [mc "marked line background"] \
11677 [list $ctext tag conf omark -background]]
11678 grid x $page.markbgbut $page.markbgsep -sticky w
11679 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11680 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11681 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11682 grid x $page.selbgbut $page.selbgsep -sticky w
11683 return $page
11686 proc prefspage_fonts {notebook} {
11687 global NS
11688 set page [create_prefs_page $notebook.fonts]
11689 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11690 grid $page.cfont - -sticky w -pady 10
11691 mkfontdisp mainfont $page [mc "Main font"]
11692 mkfontdisp textfont $page [mc "Diff display font"]
11693 mkfontdisp uifont $page [mc "User interface font"]
11694 return $page
11697 proc doprefs {} {
11698 global maxwidth maxgraphpct use_ttk NS
11699 global oldprefs prefstop showneartags showlocalchanges
11700 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11701 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11702 global hideremotes want_ttk have_ttk
11704 set top .gitkprefs
11705 set prefstop $top
11706 if {[winfo exists $top]} {
11707 raise $top
11708 return
11710 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11711 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11712 set oldprefs($v) [set $v]
11714 ttk_toplevel $top
11715 wm title $top [mc "Gitk preferences"]
11716 make_transient $top .
11718 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11719 set notebook [ttk::notebook $top.notebook]
11720 } else {
11721 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11724 lappend pages [prefspage_general $notebook] [mc "General"]
11725 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11726 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11727 set col 0
11728 foreach {page title} $pages {
11729 if {$use_notebook} {
11730 $notebook add $page -text $title
11731 } else {
11732 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11733 -text $title -command [list raise $page]]
11734 $page configure -text $title
11735 grid $btn -row 0 -column [incr col] -sticky w
11736 grid $page -row 1 -column 0 -sticky news -columnspan 100
11740 if {!$use_notebook} {
11741 grid columnconfigure $notebook 0 -weight 1
11742 grid rowconfigure $notebook 1 -weight 1
11743 raise [lindex $pages 0]
11746 grid $notebook -sticky news -padx 2 -pady 2
11747 grid rowconfigure $top 0 -weight 1
11748 grid columnconfigure $top 0 -weight 1
11750 ${NS}::frame $top.buts
11751 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11752 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11753 bind $top <Key-Return> prefsok
11754 bind $top <Key-Escape> prefscan
11755 grid $top.buts.ok $top.buts.can
11756 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11757 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11758 grid $top.buts - - -pady 10 -sticky ew
11759 grid columnconfigure $top 2 -weight 1
11760 bind $top <Visibility> [list focus $top.buts.ok]
11763 proc choose_extdiff {} {
11764 global extdifftool
11766 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11767 if {$prog ne {}} {
11768 set extdifftool $prog
11772 proc choosecolor {v vi w x cmd} {
11773 global $v
11775 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11776 -title [mc "Gitk: choose color for %s" $x]]
11777 if {$c eq {}} return
11778 $w conf -background $c
11779 lset $v $vi $c
11780 eval $cmd $c
11783 proc setselbg {c} {
11784 global bglist cflist
11785 foreach w $bglist {
11786 if {[winfo exists $w]} {
11787 $w configure -selectbackground $c
11790 $cflist tag configure highlight \
11791 -background [$cflist cget -selectbackground]
11792 allcanvs itemconf secsel -fill $c
11795 # This sets the background color and the color scheme for the whole UI.
11796 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11797 # if we don't specify one ourselves, which makes the checkbuttons and
11798 # radiobuttons look bad. This chooses white for selectColor if the
11799 # background color is light, or black if it is dark.
11800 proc setui {c} {
11801 if {[tk windowingsystem] eq "win32"} { return }
11802 set bg [winfo rgb . $c]
11803 set selc black
11804 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11805 set selc white
11807 tk_setPalette background $c selectColor $selc
11810 proc setbg {c} {
11811 global bglist
11813 foreach w $bglist {
11814 if {[winfo exists $w]} {
11815 $w conf -background $c
11820 proc setfg {c} {
11821 global fglist canv
11823 foreach w $fglist {
11824 if {[winfo exists $w]} {
11825 $w conf -foreground $c
11828 allcanvs itemconf text -fill $c
11829 $canv itemconf circle -outline $c
11830 $canv itemconf markid -outline $c
11833 proc prefscan {} {
11834 global oldprefs prefstop
11836 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11837 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11838 global $v
11839 set $v $oldprefs($v)
11841 catch {destroy $prefstop}
11842 unset prefstop
11843 fontcan
11846 proc prefsok {} {
11847 global maxwidth maxgraphpct
11848 global oldprefs prefstop showneartags showlocalchanges
11849 global fontpref mainfont textfont uifont
11850 global limitdiffs treediffs perfile_attrs
11851 global hideremotes
11853 catch {destroy $prefstop}
11854 unset prefstop
11855 fontcan
11856 set fontchanged 0
11857 if {$mainfont ne $fontpref(mainfont)} {
11858 set mainfont $fontpref(mainfont)
11859 parsefont mainfont $mainfont
11860 eval font configure mainfont [fontflags mainfont]
11861 eval font configure mainfontbold [fontflags mainfont 1]
11862 setcoords
11863 set fontchanged 1
11865 if {$textfont ne $fontpref(textfont)} {
11866 set textfont $fontpref(textfont)
11867 parsefont textfont $textfont
11868 eval font configure textfont [fontflags textfont]
11869 eval font configure textfontbold [fontflags textfont 1]
11871 if {$uifont ne $fontpref(uifont)} {
11872 set uifont $fontpref(uifont)
11873 parsefont uifont $uifont
11874 eval font configure uifont [fontflags uifont]
11876 settabs
11877 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11878 if {$showlocalchanges} {
11879 doshowlocalchanges
11880 } else {
11881 dohidelocalchanges
11884 if {$limitdiffs != $oldprefs(limitdiffs) ||
11885 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11886 # treediffs elements are limited by path;
11887 # won't have encodings cached if perfile_attrs was just turned on
11888 unset -nocomplain treediffs
11890 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11891 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11892 redisplay
11893 } elseif {$showneartags != $oldprefs(showneartags) ||
11894 $limitdiffs != $oldprefs(limitdiffs)} {
11895 reselectline
11897 if {$hideremotes != $oldprefs(hideremotes)} {
11898 rereadrefs
11902 proc formatdate {d} {
11903 global datetimeformat
11904 if {$d ne {}} {
11905 # If $datetimeformat includes a timezone, display in the
11906 # timezone of the argument. Otherwise, display in local time.
11907 if {[string match {*%[zZ]*} $datetimeformat]} {
11908 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11909 # Tcl < 8.5 does not support -timezone. Emulate it by
11910 # setting TZ (e.g. TZ=<-0430>+04:30).
11911 global env
11912 if {[info exists env(TZ)]} {
11913 set savedTZ $env(TZ)
11915 set zone [lindex $d 1]
11916 set sign [string map {+ - - +} [string index $zone 0]]
11917 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11918 set d [clock format [lindex $d 0] -format $datetimeformat]
11919 if {[info exists savedTZ]} {
11920 set env(TZ) $savedTZ
11921 } else {
11922 unset env(TZ)
11925 } else {
11926 set d [clock format [lindex $d 0] -format $datetimeformat]
11929 return $d
11932 # This list of encoding names and aliases is distilled from
11933 # http://www.iana.org/assignments/character-sets.
11934 # Not all of them are supported by Tcl.
11935 set encoding_aliases {
11936 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11937 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11938 { ISO-10646-UTF-1 csISO10646UTF1 }
11939 { ISO_646.basic:1983 ref csISO646basic1983 }
11940 { INVARIANT csINVARIANT }
11941 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11942 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11943 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11944 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11945 { NATS-DANO iso-ir-9-1 csNATSDANO }
11946 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11947 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11948 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11949 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11950 { ISO-2022-KR csISO2022KR }
11951 { EUC-KR csEUCKR }
11952 { ISO-2022-JP csISO2022JP }
11953 { ISO-2022-JP-2 csISO2022JP2 }
11954 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11955 csISO13JISC6220jp }
11956 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11957 { IT iso-ir-15 ISO646-IT csISO15Italian }
11958 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11959 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11960 { greek7-old iso-ir-18 csISO18Greek7Old }
11961 { latin-greek iso-ir-19 csISO19LatinGreek }
11962 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11963 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11964 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11965 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11966 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11967 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11968 { INIS iso-ir-49 csISO49INIS }
11969 { INIS-8 iso-ir-50 csISO50INIS8 }
11970 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11971 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11972 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11973 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11974 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11975 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11976 csISO60Norwegian1 }
11977 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11978 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11979 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11980 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11981 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11982 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11983 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11984 { greek7 iso-ir-88 csISO88Greek7 }
11985 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11986 { iso-ir-90 csISO90 }
11987 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11988 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11989 csISO92JISC62991984b }
11990 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11991 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11992 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11993 csISO95JIS62291984handadd }
11994 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11995 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11996 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11997 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11998 CP819 csISOLatin1 }
11999 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
12000 { T.61-7bit iso-ir-102 csISO102T617bit }
12001 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
12002 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
12003 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
12004 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
12005 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
12006 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
12007 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
12008 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
12009 arabic csISOLatinArabic }
12010 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
12011 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
12012 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
12013 greek greek8 csISOLatinGreek }
12014 { T.101-G2 iso-ir-128 csISO128T101G2 }
12015 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
12016 csISOLatinHebrew }
12017 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
12018 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
12019 { CSN_369103 iso-ir-139 csISO139CSN369103 }
12020 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
12021 { ISO_6937-2-add iso-ir-142 csISOTextComm }
12022 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
12023 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
12024 csISOLatinCyrillic }
12025 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
12026 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
12027 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
12028 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
12029 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
12030 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
12031 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
12032 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
12033 { ISO_10367-box iso-ir-155 csISO10367Box }
12034 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
12035 { latin-lap lap iso-ir-158 csISO158Lap }
12036 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
12037 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
12038 { us-dk csUSDK }
12039 { dk-us csDKUS }
12040 { JIS_X0201 X0201 csHalfWidthKatakana }
12041 { KSC5636 ISO646-KR csKSC5636 }
12042 { ISO-10646-UCS-2 csUnicode }
12043 { ISO-10646-UCS-4 csUCS4 }
12044 { DEC-MCS dec csDECMCS }
12045 { hp-roman8 roman8 r8 csHPRoman8 }
12046 { macintosh mac csMacintosh }
12047 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
12048 csIBM037 }
12049 { IBM038 EBCDIC-INT cp038 csIBM038 }
12050 { IBM273 CP273 csIBM273 }
12051 { IBM274 EBCDIC-BE CP274 csIBM274 }
12052 { IBM275 EBCDIC-BR cp275 csIBM275 }
12053 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
12054 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
12055 { IBM280 CP280 ebcdic-cp-it csIBM280 }
12056 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
12057 { IBM284 CP284 ebcdic-cp-es csIBM284 }
12058 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
12059 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
12060 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
12061 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
12062 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
12063 { IBM424 cp424 ebcdic-cp-he csIBM424 }
12064 { IBM437 cp437 437 csPC8CodePage437 }
12065 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
12066 { IBM775 cp775 csPC775Baltic }
12067 { IBM850 cp850 850 csPC850Multilingual }
12068 { IBM851 cp851 851 csIBM851 }
12069 { IBM852 cp852 852 csPCp852 }
12070 { IBM855 cp855 855 csIBM855 }
12071 { IBM857 cp857 857 csIBM857 }
12072 { IBM860 cp860 860 csIBM860 }
12073 { IBM861 cp861 861 cp-is csIBM861 }
12074 { IBM862 cp862 862 csPC862LatinHebrew }
12075 { IBM863 cp863 863 csIBM863 }
12076 { IBM864 cp864 csIBM864 }
12077 { IBM865 cp865 865 csIBM865 }
12078 { IBM866 cp866 866 csIBM866 }
12079 { IBM868 CP868 cp-ar csIBM868 }
12080 { IBM869 cp869 869 cp-gr csIBM869 }
12081 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
12082 { IBM871 CP871 ebcdic-cp-is csIBM871 }
12083 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
12084 { IBM891 cp891 csIBM891 }
12085 { IBM903 cp903 csIBM903 }
12086 { IBM904 cp904 904 csIBBM904 }
12087 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
12088 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
12089 { IBM1026 CP1026 csIBM1026 }
12090 { EBCDIC-AT-DE csIBMEBCDICATDE }
12091 { EBCDIC-AT-DE-A csEBCDICATDEA }
12092 { EBCDIC-CA-FR csEBCDICCAFR }
12093 { EBCDIC-DK-NO csEBCDICDKNO }
12094 { EBCDIC-DK-NO-A csEBCDICDKNOA }
12095 { EBCDIC-FI-SE csEBCDICFISE }
12096 { EBCDIC-FI-SE-A csEBCDICFISEA }
12097 { EBCDIC-FR csEBCDICFR }
12098 { EBCDIC-IT csEBCDICIT }
12099 { EBCDIC-PT csEBCDICPT }
12100 { EBCDIC-ES csEBCDICES }
12101 { EBCDIC-ES-A csEBCDICESA }
12102 { EBCDIC-ES-S csEBCDICESS }
12103 { EBCDIC-UK csEBCDICUK }
12104 { EBCDIC-US csEBCDICUS }
12105 { UNKNOWN-8BIT csUnknown8BiT }
12106 { MNEMONIC csMnemonic }
12107 { MNEM csMnem }
12108 { VISCII csVISCII }
12109 { VIQR csVIQR }
12110 { KOI8-R csKOI8R }
12111 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
12112 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
12113 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
12114 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
12115 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
12116 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
12117 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
12118 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
12119 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
12120 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
12121 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
12122 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
12123 { IBM1047 IBM-1047 }
12124 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
12125 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
12126 { UNICODE-1-1 csUnicode11 }
12127 { CESU-8 csCESU-8 }
12128 { BOCU-1 csBOCU-1 }
12129 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
12130 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
12131 l8 }
12132 { ISO-8859-15 ISO_8859-15 Latin-9 }
12133 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
12134 { GBK CP936 MS936 windows-936 }
12135 { JIS_Encoding csJISEncoding }
12136 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
12137 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
12138 EUC-JP }
12139 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
12140 { ISO-10646-UCS-Basic csUnicodeASCII }
12141 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
12142 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
12143 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
12144 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
12145 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
12146 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
12147 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
12148 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
12149 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
12150 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
12151 { Adobe-Standard-Encoding csAdobeStandardEncoding }
12152 { Ventura-US csVenturaUS }
12153 { Ventura-International csVenturaInternational }
12154 { PC8-Danish-Norwegian csPC8DanishNorwegian }
12155 { PC8-Turkish csPC8Turkish }
12156 { IBM-Symbols csIBMSymbols }
12157 { IBM-Thai csIBMThai }
12158 { HP-Legal csHPLegal }
12159 { HP-Pi-font csHPPiFont }
12160 { HP-Math8 csHPMath8 }
12161 { Adobe-Symbol-Encoding csHPPSMath }
12162 { HP-DeskTop csHPDesktop }
12163 { Ventura-Math csVenturaMath }
12164 { Microsoft-Publishing csMicrosoftPublishing }
12165 { Windows-31J csWindows31J }
12166 { GB2312 csGB2312 }
12167 { Big5 csBig5 }
12170 proc tcl_encoding {enc} {
12171 global encoding_aliases tcl_encoding_cache
12172 if {[info exists tcl_encoding_cache($enc)]} {
12173 return $tcl_encoding_cache($enc)
12175 set names [encoding names]
12176 set lcnames [string tolower $names]
12177 set enc [string tolower $enc]
12178 set i [lsearch -exact $lcnames $enc]
12179 if {$i < 0} {
12180 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
12181 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
12182 set i [lsearch -exact $lcnames $encx]
12185 if {$i < 0} {
12186 foreach l $encoding_aliases {
12187 set ll [string tolower $l]
12188 if {[lsearch -exact $ll $enc] < 0} continue
12189 # look through the aliases for one that tcl knows about
12190 foreach e $ll {
12191 set i [lsearch -exact $lcnames $e]
12192 if {$i < 0} {
12193 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
12194 set i [lsearch -exact $lcnames $ex]
12197 if {$i >= 0} break
12199 break
12202 set tclenc {}
12203 if {$i >= 0} {
12204 set tclenc [lindex $names $i]
12206 set tcl_encoding_cache($enc) $tclenc
12207 return $tclenc
12210 proc gitattr {path attr default} {
12211 global path_attr_cache
12212 if {[info exists path_attr_cache($attr,$path)]} {
12213 set r $path_attr_cache($attr,$path)
12214 } else {
12215 set r "unspecified"
12216 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
12217 regexp "(.*): $attr: (.*)" $line m f r
12219 set path_attr_cache($attr,$path) $r
12221 if {$r eq "unspecified"} {
12222 return $default
12224 return $r
12227 proc cache_gitattr {attr pathlist} {
12228 global path_attr_cache
12229 set newlist {}
12230 foreach path $pathlist {
12231 if {![info exists path_attr_cache($attr,$path)]} {
12232 lappend newlist $path
12235 set lim 1000
12236 if {[tk windowingsystem] == "win32"} {
12237 # windows has a 32k limit on the arguments to a command...
12238 set lim 30
12240 while {$newlist ne {}} {
12241 set head [lrange $newlist 0 [expr {$lim - 1}]]
12242 set newlist [lrange $newlist $lim end]
12243 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
12244 foreach row [split $rlist "\n"] {
12245 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12246 if {[string index $path 0] eq "\""} {
12247 set path [encoding convertfrom [lindex $path 0]]
12249 set path_attr_cache($attr,$path) $value
12256 proc get_path_encoding {path} {
12257 global gui_encoding perfile_attrs
12258 set tcl_enc $gui_encoding
12259 if {$path ne {} && $perfile_attrs} {
12260 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12261 if {$enc2 ne {}} {
12262 set tcl_enc $enc2
12265 return $tcl_enc
12268 ## For msgcat loading, first locate the installation location.
12269 if { [info exists ::env(GITK_MSGSDIR)] } {
12270 ## Msgsdir was manually set in the environment.
12271 set gitk_msgsdir $::env(GITK_MSGSDIR)
12272 } else {
12273 ## Let's guess the prefix from argv0.
12274 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12275 set gitk_libdir [file join $gitk_prefix share gitk lib]
12276 set gitk_msgsdir [file join $gitk_libdir msgs]
12277 unset gitk_prefix
12280 ## Internationalization (i18n) through msgcat and gettext. See
12281 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12282 package require msgcat
12283 namespace import ::msgcat::mc
12284 ## And eventually load the actual message catalog
12285 ::msgcat::mcload $gitk_msgsdir
12287 # First check that Tcl/Tk is recent enough
12288 if {[catch {package require Tk 8.4} err]} {
12289 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12290 Gitk requires at least Tcl/Tk 8.4."]
12291 exit 1
12294 # on OSX bring the current Wish process window to front
12295 if {[tk windowingsystem] eq "aqua"} {
12296 exec osascript -e [format {
12297 tell application "System Events"
12298 set frontmost of processes whose unix id is %d to true
12299 end tell
12300 } [pid] ]
12303 # Unset GIT_TRACE var if set
12304 if { [info exists ::env(GIT_TRACE)] } {
12305 unset ::env(GIT_TRACE)
12308 # defaults...
12309 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12311 set gitencoding {}
12312 catch {
12313 set gitencoding [exec git config --get i18n.commitencoding]
12315 catch {
12316 set gitencoding [exec git config --get i18n.logoutputencoding]
12318 if {$gitencoding == ""} {
12319 set gitencoding "utf-8"
12321 set tclencoding [tcl_encoding $gitencoding]
12322 if {$tclencoding == {}} {
12323 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12326 set gui_encoding [encoding system]
12327 catch {
12328 set enc [exec git config --get gui.encoding]
12329 if {$enc ne {}} {
12330 set tclenc [tcl_encoding $enc]
12331 if {$tclenc ne {}} {
12332 set gui_encoding $tclenc
12333 } else {
12334 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12339 set log_showroot true
12340 catch {
12341 set log_showroot [exec git config --bool --get log.showroot]
12344 if {[tk windowingsystem] eq "aqua"} {
12345 set mainfont {{Lucida Grande} 9}
12346 set textfont {Monaco 9}
12347 set uifont {{Lucida Grande} 9 bold}
12348 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12349 # fontconfig!
12350 set mainfont {sans 9}
12351 set textfont {monospace 9}
12352 set uifont {sans 9 bold}
12353 } else {
12354 set mainfont {Helvetica 9}
12355 set textfont {Courier 9}
12356 set uifont {Helvetica 9 bold}
12358 set tabstop 8
12359 set findmergefiles 0
12360 set maxgraphpct 50
12361 set maxwidth 16
12362 set revlistorder 0
12363 set fastdate 0
12364 set uparrowlen 5
12365 set downarrowlen 5
12366 set mingaplen 100
12367 set cmitmode "patch"
12368 set wrapcomment "none"
12369 set showneartags 1
12370 set hideremotes 0
12371 set maxrefs 20
12372 set visiblerefs {"master"}
12373 set maxlinelen 200
12374 set showlocalchanges 1
12375 set limitdiffs 1
12376 set datetimeformat "%Y-%m-%d %H:%M:%S"
12377 set autoselect 1
12378 set autosellen 40
12379 set perfile_attrs 0
12380 set want_ttk 1
12382 if {[tk windowingsystem] eq "aqua"} {
12383 set extdifftool "opendiff"
12384 } else {
12385 set extdifftool "meld"
12388 set colors {"#00ff00" red blue magenta darkgrey brown orange}
12389 if {[tk windowingsystem] eq "win32"} {
12390 set uicolor SystemButtonFace
12391 set uifgcolor SystemButtonText
12392 set uifgdisabledcolor SystemDisabledText
12393 set bgcolor SystemWindow
12394 set fgcolor SystemWindowText
12395 set selectbgcolor SystemHighlight
12396 set web_browser "cmd /c start"
12397 } else {
12398 set uicolor grey85
12399 set uifgcolor black
12400 set uifgdisabledcolor "#999"
12401 set bgcolor white
12402 set fgcolor black
12403 set selectbgcolor gray85
12404 if {[tk windowingsystem] eq "aqua"} {
12405 set web_browser "open"
12406 } else {
12407 set web_browser "xdg-open"
12410 set diffcolors {"#c30000" "#009800" blue}
12411 set diffbgcolors {"#fff3f3" "#f0fff0"}
12412 set diffcontext 3
12413 set mergecolors {red blue "#00ff00" purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12414 set ignorespace 0
12415 set worddiff ""
12416 set markbgcolor "#e0e0ff"
12418 set headbgcolor "#00ff00"
12419 set headfgcolor black
12420 set headoutlinecolor black
12421 set remotebgcolor #ffddaa
12422 set tagbgcolor yellow
12423 set tagfgcolor black
12424 set tagoutlinecolor black
12425 set reflinecolor black
12426 set filesepbgcolor #aaaaaa
12427 set filesepfgcolor black
12428 set linehoverbgcolor #ffff80
12429 set linehoverfgcolor black
12430 set linehoveroutlinecolor black
12431 set mainheadcirclecolor yellow
12432 set workingfilescirclecolor red
12433 set indexcirclecolor "#00ff00"
12434 set circlecolors {white blue gray blue blue}
12435 set linkfgcolor blue
12436 set circleoutlinecolor $fgcolor
12437 set foundbgcolor yellow
12438 set currentsearchhitbgcolor orange
12440 # button for popping up context menus
12441 if {[tk windowingsystem] eq "aqua"} {
12442 set ctxbut <Button-2>
12443 } else {
12444 set ctxbut <Button-3>
12447 catch {
12448 # follow the XDG base directory specification by default. See
12449 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12450 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12451 # XDG_CONFIG_HOME environment variable is set
12452 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12453 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12454 } else {
12455 # default XDG_CONFIG_HOME
12456 set config_file "~/.config/git/gitk"
12457 set config_file_tmp "~/.config/git/gitk-tmp"
12459 if {![file exists $config_file]} {
12460 # for backward compatibility use the old config file if it exists
12461 if {[file exists "~/.gitk"]} {
12462 set config_file "~/.gitk"
12463 set config_file_tmp "~/.gitk-tmp"
12464 } elseif {![file exists [file dirname $config_file]]} {
12465 file mkdir [file dirname $config_file]
12468 source $config_file
12470 config_check_tmp_exists 50
12472 set config_variables {
12473 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12474 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12475 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12476 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12477 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12478 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12479 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12480 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12481 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12482 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor diffbgcolors
12483 web_browser
12485 foreach var $config_variables {
12486 config_init_trace $var
12487 trace add variable $var write config_variable_change_cb
12490 parsefont mainfont $mainfont
12491 eval font create mainfont [fontflags mainfont]
12492 eval font create mainfontbold [fontflags mainfont 1]
12494 parsefont textfont $textfont
12495 eval font create textfont [fontflags textfont]
12496 eval font create textfontbold [fontflags textfont 1]
12498 parsefont uifont $uifont
12499 eval font create uifont [fontflags uifont]
12501 setui $uicolor
12503 setoptions
12505 # check that we can find a .git directory somewhere...
12506 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12507 show_error {} . [mc "Cannot find a git repository here."]
12508 exit 1
12511 set selecthead {}
12512 set selectheadid {}
12514 set revtreeargs {}
12515 set cmdline_files {}
12516 set i 0
12517 set revtreeargscmd {}
12518 foreach arg $argv {
12519 switch -glob -- $arg {
12520 "" { }
12521 "--" {
12522 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12523 break
12525 "--select-commit=*" {
12526 set selecthead [string range $arg 16 end]
12528 "--argscmd=*" {
12529 set revtreeargscmd [string range $arg 10 end]
12531 default {
12532 lappend revtreeargs $arg
12535 incr i
12538 if {$selecthead eq "HEAD"} {
12539 set selecthead {}
12542 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12543 # no -- on command line, but some arguments (other than --argscmd)
12544 if {[catch {
12545 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12546 set cmdline_files [split $f "\n"]
12547 set n [llength $cmdline_files]
12548 set revtreeargs [lrange $revtreeargs 0 end-$n]
12549 # Unfortunately git rev-parse doesn't produce an error when
12550 # something is both a revision and a filename. To be consistent
12551 # with git log and git rev-list, check revtreeargs for filenames.
12552 foreach arg $revtreeargs {
12553 if {[file exists $arg]} {
12554 show_error {} . [mc "Ambiguous argument '%s': both revision\
12555 and filename" $arg]
12556 exit 1
12559 } err]} {
12560 # unfortunately we get both stdout and stderr in $err,
12561 # so look for "fatal:".
12562 set i [string first "fatal:" $err]
12563 if {$i > 0} {
12564 set err [string range $err [expr {$i + 6}] end]
12566 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12567 exit 1
12571 set nullid "0000000000000000000000000000000000000000"
12572 set nullid2 "0000000000000000000000000000000000000001"
12573 set nullfile "/dev/null"
12575 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12576 if {![info exists have_ttk]} {
12577 set have_ttk [llength [info commands ::ttk::style]]
12579 set use_ttk [expr {$have_ttk && $want_ttk}]
12580 set NS [expr {$use_ttk ? "ttk" : ""}]
12582 if {$use_ttk} {
12583 setttkstyle
12586 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12588 set show_notes {}
12589 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12590 set show_notes "--show-notes"
12593 set appname "gitk"
12595 set runq {}
12596 set history {}
12597 set historyindex 0
12598 set fh_serial 0
12599 set nhl_names {}
12600 set highlight_paths {}
12601 set findpattern {}
12602 set searchdirn -forwards
12603 set boldids {}
12604 set boldnameids {}
12605 set diffelide {0 0}
12606 set markingmatches 0
12607 set linkentercount 0
12608 set need_redisplay 0
12609 set nrows_drawn 0
12610 set firsttabstop 0
12612 set nextviewnum 1
12613 set curview 0
12614 set selectedview 0
12615 set selectedhlview [mc "None"]
12616 set highlight_related [mc "None"]
12617 set highlight_files {}
12618 set viewfiles(0) {}
12619 set viewperm(0) 0
12620 set viewchanged(0) 0
12621 set viewargs(0) {}
12622 set viewargscmd(0) {}
12624 set selectedline {}
12625 set numcommits 0
12626 set loginstance 0
12627 set cmdlineok 0
12628 set stopped 0
12629 set stuffsaved 0
12630 set patchnum 0
12631 set lserial 0
12632 set hasworktree [hasworktree]
12633 set cdup {}
12634 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12635 set cdup [exec git rev-parse --show-cdup]
12637 set worktree [gitworktree]
12638 setcoords
12639 makewindow
12640 catch {
12641 image create photo gitlogo -width 16 -height 16
12643 image create photo gitlogominus -width 4 -height 2
12644 gitlogominus put #C00000 -to 0 0 4 2
12645 gitlogo copy gitlogominus -to 1 5
12646 gitlogo copy gitlogominus -to 6 5
12647 gitlogo copy gitlogominus -to 11 5
12648 image delete gitlogominus
12650 image create photo gitlogoplus -width 4 -height 4
12651 gitlogoplus put #008000 -to 1 0 3 4
12652 gitlogoplus put #008000 -to 0 1 4 3
12653 gitlogo copy gitlogoplus -to 1 9
12654 gitlogo copy gitlogoplus -to 6 9
12655 gitlogo copy gitlogoplus -to 11 9
12656 image delete gitlogoplus
12658 image create photo gitlogo32 -width 32 -height 32
12659 gitlogo32 copy gitlogo -zoom 2 2
12661 wm iconphoto . -default gitlogo gitlogo32
12663 # wait for the window to become visible
12664 tkwait visibility .
12665 set_window_title
12666 update
12667 readrefs
12669 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12670 # create a view for the files/dirs specified on the command line
12671 set curview 1
12672 set selectedview 1
12673 set nextviewnum 2
12674 set viewname(1) [mc "Command line"]
12675 set viewfiles(1) $cmdline_files
12676 set viewargs(1) $revtreeargs
12677 set viewargscmd(1) $revtreeargscmd
12678 set viewperm(1) 0
12679 set viewchanged(1) 0
12680 set vdatemode(1) 0
12681 addviewmenu 1
12682 .bar.view entryconf [mca "&Edit view..."] -state normal
12683 .bar.view entryconf [mca "&Delete view"] -state normal
12686 if {[info exists permviews]} {
12687 foreach v $permviews {
12688 set n $nextviewnum
12689 incr nextviewnum
12690 set viewname($n) [lindex $v 0]
12691 set viewfiles($n) [lindex $v 1]
12692 set viewargs($n) [lindex $v 2]
12693 set viewargscmd($n) [lindex $v 3]
12694 set viewperm($n) 1
12695 set viewchanged($n) 0
12696 addviewmenu $n
12700 if {[tk windowingsystem] eq "win32"} {
12701 focus -force .
12704 getcommits {}
12706 # Local variables:
12707 # mode: tcl
12708 # indent-tabs-mode: t
12709 # tab-width: 8
12710 # End: