The thirteenth batch
[git/debian.git] / gitk-git / gitk
blobdf3ba2ea99b310c3cdcd5c7a8938eef498b3e92e
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 # Escapes a list of filter paths to be passed to git log via stdin. Note that
357 # paths must not be quoted.
358 proc escape_filter_paths {paths} {
359 set escaped [list]
360 foreach path $paths {
361 lappend escaped [string map {\\ \\\\ "\ " "\\\ "} $path]
363 return $escaped
366 # Start off a git log process and arrange to read its output
367 proc start_rev_list {view} {
368 global startmsecs commitidx viewcomplete curview
369 global tclencoding
370 global viewargs viewargscmd viewfiles vfilelimit
371 global showlocalchanges
372 global viewactive viewinstances vmergeonly
373 global mainheadid viewmainheadid viewmainheadid_orig
374 global vcanopt vflags vrevs vorigargs
375 global show_notes
377 set startmsecs [clock clicks -milliseconds]
378 set commitidx($view) 0
379 # these are set this way for the error exits
380 set viewcomplete($view) 1
381 set viewactive($view) 0
382 varcinit $view
384 set args $viewargs($view)
385 if {$viewargscmd($view) ne {}} {
386 if {[catch {
387 set str [exec sh -c $viewargscmd($view)]
388 } err]} {
389 error_popup "[mc "Error executing --argscmd command:"] $err"
390 return 0
392 set args [concat $args [split $str "\n"]]
394 set vcanopt($view) [parseviewargs $view $args]
396 set files $viewfiles($view)
397 if {$vmergeonly($view)} {
398 set files [unmerged_files $files]
399 if {$files eq {}} {
400 global nr_unmerged
401 if {$nr_unmerged == 0} {
402 error_popup [mc "No files selected: --merge specified but\
403 no files are unmerged."]
404 } else {
405 error_popup [mc "No files selected: --merge specified but\
406 no unmerged files are within file limit."]
408 return 0
411 set vfilelimit($view) $files
413 if {$vcanopt($view)} {
414 set revs [parseviewrevs $view $vrevs($view)]
415 if {$revs eq {}} {
416 return 0
418 set args $vflags($view)
419 } else {
420 set revs {}
421 set args $vorigargs($view)
424 if {[catch {
425 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
426 --parents --boundary $args --stdin \
427 "<<[join [concat $revs "--" \
428 [escape_filter_paths $files]] "\\n"]"] r]
429 } err]} {
430 error_popup "[mc "Error executing git log:"] $err"
431 return 0
433 set i [reg_instance $fd]
434 set viewinstances($view) [list $i]
435 set viewmainheadid($view) $mainheadid
436 set viewmainheadid_orig($view) $mainheadid
437 if {$files ne {} && $mainheadid ne {}} {
438 get_viewmainhead $view
440 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
441 interestedin $viewmainheadid($view) dodiffindex
443 fconfigure $fd -blocking 0 -translation lf -eofchar {}
444 if {$tclencoding != {}} {
445 fconfigure $fd -encoding $tclencoding
447 filerun $fd [list getcommitlines $fd $i $view 0]
448 nowbusy $view [mc "Reading"]
449 set viewcomplete($view) 0
450 set viewactive($view) 1
451 return 1
454 proc stop_instance {inst} {
455 global commfd leftover
457 set fd $commfd($inst)
458 catch {
459 set pid [pid $fd]
461 if {$::tcl_platform(platform) eq {windows}} {
462 exec taskkill /pid $pid
463 } else {
464 exec kill $pid
467 catch {close $fd}
468 nukefile $fd
469 unset commfd($inst)
470 unset leftover($inst)
473 proc stop_backends {} {
474 global commfd
476 foreach inst [array names commfd] {
477 stop_instance $inst
481 proc stop_rev_list {view} {
482 global viewinstances
484 foreach inst $viewinstances($view) {
485 stop_instance $inst
487 set viewinstances($view) {}
490 proc reset_pending_select {selid} {
491 global pending_select mainheadid selectheadid
493 if {$selid ne {}} {
494 set pending_select $selid
495 } elseif {$selectheadid ne {}} {
496 set pending_select $selectheadid
497 } else {
498 set pending_select $mainheadid
502 proc getcommits {selid} {
503 global canv curview need_redisplay viewactive
505 initlayout
506 if {[start_rev_list $curview]} {
507 reset_pending_select $selid
508 show_status [mc "Reading commits..."]
509 set need_redisplay 1
510 } else {
511 show_status [mc "No commits selected"]
515 proc updatecommits {} {
516 global curview vcanopt vorigargs vfilelimit viewinstances
517 global viewactive viewcomplete tclencoding
518 global startmsecs showneartags showlocalchanges
519 global mainheadid viewmainheadid viewmainheadid_orig pending_select
520 global hasworktree
521 global varcid vposids vnegids vflags vrevs
522 global show_notes
524 set hasworktree [hasworktree]
525 rereadrefs
526 set view $curview
527 if {$mainheadid ne $viewmainheadid_orig($view)} {
528 if {$showlocalchanges} {
529 dohidelocalchanges
531 set viewmainheadid($view) $mainheadid
532 set viewmainheadid_orig($view) $mainheadid
533 if {$vfilelimit($view) ne {}} {
534 get_viewmainhead $view
537 if {$showlocalchanges} {
538 doshowlocalchanges
540 if {$vcanopt($view)} {
541 set oldpos $vposids($view)
542 set oldneg $vnegids($view)
543 set revs [parseviewrevs $view $vrevs($view)]
544 if {$revs eq {}} {
545 return
547 # note: getting the delta when negative refs change is hard,
548 # and could require multiple git log invocations, so in that
549 # case we ask git log for all the commits (not just the delta)
550 if {$oldneg eq $vnegids($view)} {
551 set newrevs {}
552 set npos 0
553 # take out positive refs that we asked for before or
554 # that we have already seen
555 foreach rev $revs {
556 if {[string length $rev] == 40} {
557 if {[lsearch -exact $oldpos $rev] < 0
558 && ![info exists varcid($view,$rev)]} {
559 lappend newrevs $rev
560 incr npos
562 } else {
563 lappend $newrevs $rev
566 if {$npos == 0} return
567 set revs $newrevs
568 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
570 set args $vflags($view)
571 foreach r $oldpos {
572 lappend revs "^$r"
574 } else {
575 set revs {}
576 set args $vorigargs($view)
578 if {[catch {
579 set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
580 --parents --boundary $args --stdin \
581 "<<[join [concat $revs "--" \
582 [escape_filter_paths \
583 $vfilelimit($view)]] "\\n"]"] r]
584 } err]} {
585 error_popup "[mc "Error executing git log:"] $err"
586 return
588 if {$viewactive($view) == 0} {
589 set startmsecs [clock clicks -milliseconds]
591 set i [reg_instance $fd]
592 lappend viewinstances($view) $i
593 fconfigure $fd -blocking 0 -translation lf -eofchar {}
594 if {$tclencoding != {}} {
595 fconfigure $fd -encoding $tclencoding
597 filerun $fd [list getcommitlines $fd $i $view 1]
598 incr viewactive($view)
599 set viewcomplete($view) 0
600 reset_pending_select {}
601 nowbusy $view [mc "Reading"]
602 if {$showneartags} {
603 getallcommits
607 proc reloadcommits {} {
608 global curview viewcomplete selectedline currentid thickerline
609 global showneartags treediffs commitinterest cached_commitrow
610 global targetid commitinfo
612 set selid {}
613 if {$selectedline ne {}} {
614 set selid $currentid
617 if {!$viewcomplete($curview)} {
618 stop_rev_list $curview
620 resetvarcs $curview
621 set selectedline {}
622 unset -nocomplain currentid
623 unset -nocomplain thickerline
624 unset -nocomplain treediffs
625 readrefs
626 changedrefs
627 if {$showneartags} {
628 getallcommits
630 clear_display
631 unset -nocomplain commitinfo
632 unset -nocomplain commitinterest
633 unset -nocomplain cached_commitrow
634 unset -nocomplain targetid
635 setcanvscroll
636 getcommits $selid
637 return 0
640 # This makes a string representation of a positive integer which
641 # sorts as a string in numerical order
642 proc strrep {n} {
643 if {$n < 16} {
644 return [format "%x" $n]
645 } elseif {$n < 256} {
646 return [format "x%.2x" $n]
647 } elseif {$n < 65536} {
648 return [format "y%.4x" $n]
650 return [format "z%.8x" $n]
653 # Procedures used in reordering commits from git log (without
654 # --topo-order) into the order for display.
656 proc varcinit {view} {
657 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
658 global vtokmod varcmod vrowmod varcix vlastins
660 set varcstart($view) {{}}
661 set vupptr($view) {0}
662 set vdownptr($view) {0}
663 set vleftptr($view) {0}
664 set vbackptr($view) {0}
665 set varctok($view) {{}}
666 set varcrow($view) {{}}
667 set vtokmod($view) {}
668 set varcmod($view) 0
669 set vrowmod($view) 0
670 set varcix($view) {{}}
671 set vlastins($view) {0}
674 proc resetvarcs {view} {
675 global varcid varccommits parents children vseedcount ordertok
676 global vshortids
678 foreach vid [array names varcid $view,*] {
679 unset varcid($vid)
680 unset children($vid)
681 unset parents($vid)
683 foreach vid [array names vshortids $view,*] {
684 unset vshortids($vid)
686 # some commits might have children but haven't been seen yet
687 foreach vid [array names children $view,*] {
688 unset children($vid)
690 foreach va [array names varccommits $view,*] {
691 unset varccommits($va)
693 foreach vd [array names vseedcount $view,*] {
694 unset vseedcount($vd)
696 unset -nocomplain ordertok
699 # returns a list of the commits with no children
700 proc seeds {v} {
701 global vdownptr vleftptr varcstart
703 set ret {}
704 set a [lindex $vdownptr($v) 0]
705 while {$a != 0} {
706 lappend ret [lindex $varcstart($v) $a]
707 set a [lindex $vleftptr($v) $a]
709 return $ret
712 proc newvarc {view id} {
713 global varcid varctok parents children vdatemode
714 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
715 global commitdata commitinfo vseedcount varccommits vlastins
717 set a [llength $varctok($view)]
718 set vid $view,$id
719 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
720 if {![info exists commitinfo($id)]} {
721 parsecommit $id $commitdata($id) 1
723 set cdate [lindex [lindex $commitinfo($id) 4] 0]
724 if {![string is integer -strict $cdate]} {
725 set cdate 0
727 if {![info exists vseedcount($view,$cdate)]} {
728 set vseedcount($view,$cdate) -1
730 set c [incr vseedcount($view,$cdate)]
731 set cdate [expr {$cdate ^ 0xffffffff}]
732 set tok "s[strrep $cdate][strrep $c]"
733 } else {
734 set tok {}
736 set ka 0
737 if {[llength $children($vid)] > 0} {
738 set kid [lindex $children($vid) end]
739 set k $varcid($view,$kid)
740 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
741 set ki $kid
742 set ka $k
743 set tok [lindex $varctok($view) $k]
746 if {$ka != 0} {
747 set i [lsearch -exact $parents($view,$ki) $id]
748 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
749 append tok [strrep $j]
751 set c [lindex $vlastins($view) $ka]
752 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
753 set c $ka
754 set b [lindex $vdownptr($view) $ka]
755 } else {
756 set b [lindex $vleftptr($view) $c]
758 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
759 set c $b
760 set b [lindex $vleftptr($view) $c]
762 if {$c == $ka} {
763 lset vdownptr($view) $ka $a
764 lappend vbackptr($view) 0
765 } else {
766 lset vleftptr($view) $c $a
767 lappend vbackptr($view) $c
769 lset vlastins($view) $ka $a
770 lappend vupptr($view) $ka
771 lappend vleftptr($view) $b
772 if {$b != 0} {
773 lset vbackptr($view) $b $a
775 lappend varctok($view) $tok
776 lappend varcstart($view) $id
777 lappend vdownptr($view) 0
778 lappend varcrow($view) {}
779 lappend varcix($view) {}
780 set varccommits($view,$a) {}
781 lappend vlastins($view) 0
782 return $a
785 proc splitvarc {p v} {
786 global varcid varcstart varccommits varctok vtokmod
787 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
789 set oa $varcid($v,$p)
790 set otok [lindex $varctok($v) $oa]
791 set ac $varccommits($v,$oa)
792 set i [lsearch -exact $varccommits($v,$oa) $p]
793 if {$i <= 0} return
794 set na [llength $varctok($v)]
795 # "%" sorts before "0"...
796 set tok "$otok%[strrep $i]"
797 lappend varctok($v) $tok
798 lappend varcrow($v) {}
799 lappend varcix($v) {}
800 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
801 set varccommits($v,$na) [lrange $ac $i end]
802 lappend varcstart($v) $p
803 foreach id $varccommits($v,$na) {
804 set varcid($v,$id) $na
806 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
807 lappend vlastins($v) [lindex $vlastins($v) $oa]
808 lset vdownptr($v) $oa $na
809 lset vlastins($v) $oa 0
810 lappend vupptr($v) $oa
811 lappend vleftptr($v) 0
812 lappend vbackptr($v) 0
813 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
814 lset vupptr($v) $b $na
816 if {[string compare $otok $vtokmod($v)] <= 0} {
817 modify_arc $v $oa
821 proc renumbervarc {a v} {
822 global parents children varctok varcstart varccommits
823 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
825 set t1 [clock clicks -milliseconds]
826 set todo {}
827 set isrelated($a) 1
828 set kidchanged($a) 1
829 set ntot 0
830 while {$a != 0} {
831 if {[info exists isrelated($a)]} {
832 lappend todo $a
833 set id [lindex $varccommits($v,$a) end]
834 foreach p $parents($v,$id) {
835 if {[info exists varcid($v,$p)]} {
836 set isrelated($varcid($v,$p)) 1
840 incr ntot
841 set b [lindex $vdownptr($v) $a]
842 if {$b == 0} {
843 while {$a != 0} {
844 set b [lindex $vleftptr($v) $a]
845 if {$b != 0} break
846 set a [lindex $vupptr($v) $a]
849 set a $b
851 foreach a $todo {
852 if {![info exists kidchanged($a)]} continue
853 set id [lindex $varcstart($v) $a]
854 if {[llength $children($v,$id)] > 1} {
855 set children($v,$id) [lsort -command [list vtokcmp $v] \
856 $children($v,$id)]
858 set oldtok [lindex $varctok($v) $a]
859 if {!$vdatemode($v)} {
860 set tok {}
861 } else {
862 set tok $oldtok
864 set ka 0
865 set kid [last_real_child $v,$id]
866 if {$kid ne {}} {
867 set k $varcid($v,$kid)
868 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
869 set ki $kid
870 set ka $k
871 set tok [lindex $varctok($v) $k]
874 if {$ka != 0} {
875 set i [lsearch -exact $parents($v,$ki) $id]
876 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
877 append tok [strrep $j]
879 if {$tok eq $oldtok} {
880 continue
882 set id [lindex $varccommits($v,$a) end]
883 foreach p $parents($v,$id) {
884 if {[info exists varcid($v,$p)]} {
885 set kidchanged($varcid($v,$p)) 1
886 } else {
887 set sortkids($p) 1
890 lset varctok($v) $a $tok
891 set b [lindex $vupptr($v) $a]
892 if {$b != $ka} {
893 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
894 modify_arc $v $ka
896 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
897 modify_arc $v $b
899 set c [lindex $vbackptr($v) $a]
900 set d [lindex $vleftptr($v) $a]
901 if {$c == 0} {
902 lset vdownptr($v) $b $d
903 } else {
904 lset vleftptr($v) $c $d
906 if {$d != 0} {
907 lset vbackptr($v) $d $c
909 if {[lindex $vlastins($v) $b] == $a} {
910 lset vlastins($v) $b $c
912 lset vupptr($v) $a $ka
913 set c [lindex $vlastins($v) $ka]
914 if {$c == 0 || \
915 [string compare $tok [lindex $varctok($v) $c]] < 0} {
916 set c $ka
917 set b [lindex $vdownptr($v) $ka]
918 } else {
919 set b [lindex $vleftptr($v) $c]
921 while {$b != 0 && \
922 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
923 set c $b
924 set b [lindex $vleftptr($v) $c]
926 if {$c == $ka} {
927 lset vdownptr($v) $ka $a
928 lset vbackptr($v) $a 0
929 } else {
930 lset vleftptr($v) $c $a
931 lset vbackptr($v) $a $c
933 lset vleftptr($v) $a $b
934 if {$b != 0} {
935 lset vbackptr($v) $b $a
937 lset vlastins($v) $ka $a
940 foreach id [array names sortkids] {
941 if {[llength $children($v,$id)] > 1} {
942 set children($v,$id) [lsort -command [list vtokcmp $v] \
943 $children($v,$id)]
946 set t2 [clock clicks -milliseconds]
947 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
950 # Fix up the graph after we have found out that in view $v,
951 # $p (a commit that we have already seen) is actually the parent
952 # of the last commit in arc $a.
953 proc fix_reversal {p a v} {
954 global varcid varcstart varctok vupptr
956 set pa $varcid($v,$p)
957 if {$p ne [lindex $varcstart($v) $pa]} {
958 splitvarc $p $v
959 set pa $varcid($v,$p)
961 # seeds always need to be renumbered
962 if {[lindex $vupptr($v) $pa] == 0 ||
963 [string compare [lindex $varctok($v) $a] \
964 [lindex $varctok($v) $pa]] > 0} {
965 renumbervarc $pa $v
969 proc insertrow {id p v} {
970 global cmitlisted children parents varcid varctok vtokmod
971 global varccommits ordertok commitidx numcommits curview
972 global targetid targetrow vshortids
974 readcommit $id
975 set vid $v,$id
976 set cmitlisted($vid) 1
977 set children($vid) {}
978 set parents($vid) [list $p]
979 set a [newvarc $v $id]
980 set varcid($vid) $a
981 lappend vshortids($v,[string range $id 0 3]) $id
982 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
983 modify_arc $v $a
985 lappend varccommits($v,$a) $id
986 set vp $v,$p
987 if {[llength [lappend children($vp) $id]] > 1} {
988 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
989 unset -nocomplain ordertok
991 fix_reversal $p $a $v
992 incr commitidx($v)
993 if {$v == $curview} {
994 set numcommits $commitidx($v)
995 setcanvscroll
996 if {[info exists targetid]} {
997 if {![comes_before $targetid $p]} {
998 incr targetrow
1004 proc insertfakerow {id p} {
1005 global varcid varccommits parents children cmitlisted
1006 global commitidx varctok vtokmod targetid targetrow curview numcommits
1008 set v $curview
1009 set a $varcid($v,$p)
1010 set i [lsearch -exact $varccommits($v,$a) $p]
1011 if {$i < 0} {
1012 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
1013 return
1015 set children($v,$id) {}
1016 set parents($v,$id) [list $p]
1017 set varcid($v,$id) $a
1018 lappend children($v,$p) $id
1019 set cmitlisted($v,$id) 1
1020 set numcommits [incr commitidx($v)]
1021 # note we deliberately don't update varcstart($v) even if $i == 0
1022 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1023 modify_arc $v $a $i
1024 if {[info exists targetid]} {
1025 if {![comes_before $targetid $p]} {
1026 incr targetrow
1029 setcanvscroll
1030 drawvisible
1033 proc removefakerow {id} {
1034 global varcid varccommits parents children commitidx
1035 global varctok vtokmod cmitlisted currentid selectedline
1036 global targetid curview numcommits
1038 set v $curview
1039 if {[llength $parents($v,$id)] != 1} {
1040 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1041 return
1043 set p [lindex $parents($v,$id) 0]
1044 set a $varcid($v,$id)
1045 set i [lsearch -exact $varccommits($v,$a) $id]
1046 if {$i < 0} {
1047 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1048 return
1050 unset varcid($v,$id)
1051 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1052 unset parents($v,$id)
1053 unset children($v,$id)
1054 unset cmitlisted($v,$id)
1055 set numcommits [incr commitidx($v) -1]
1056 set j [lsearch -exact $children($v,$p) $id]
1057 if {$j >= 0} {
1058 set children($v,$p) [lreplace $children($v,$p) $j $j]
1060 modify_arc $v $a $i
1061 if {[info exist currentid] && $id eq $currentid} {
1062 unset currentid
1063 set selectedline {}
1065 if {[info exists targetid] && $targetid eq $id} {
1066 set targetid $p
1068 setcanvscroll
1069 drawvisible
1072 proc real_children {vp} {
1073 global children nullid nullid2
1075 set kids {}
1076 foreach id $children($vp) {
1077 if {$id ne $nullid && $id ne $nullid2} {
1078 lappend kids $id
1081 return $kids
1084 proc first_real_child {vp} {
1085 global children nullid nullid2
1087 foreach id $children($vp) {
1088 if {$id ne $nullid && $id ne $nullid2} {
1089 return $id
1092 return {}
1095 proc last_real_child {vp} {
1096 global children nullid nullid2
1098 set kids $children($vp)
1099 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1100 set id [lindex $kids $i]
1101 if {$id ne $nullid && $id ne $nullid2} {
1102 return $id
1105 return {}
1108 proc vtokcmp {v a b} {
1109 global varctok varcid
1111 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1112 [lindex $varctok($v) $varcid($v,$b)]]
1115 # This assumes that if lim is not given, the caller has checked that
1116 # arc a's token is less than $vtokmod($v)
1117 proc modify_arc {v a {lim {}}} {
1118 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1120 if {$lim ne {}} {
1121 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1122 if {$c > 0} return
1123 if {$c == 0} {
1124 set r [lindex $varcrow($v) $a]
1125 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1128 set vtokmod($v) [lindex $varctok($v) $a]
1129 set varcmod($v) $a
1130 if {$v == $curview} {
1131 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1132 set a [lindex $vupptr($v) $a]
1133 set lim {}
1135 set r 0
1136 if {$a != 0} {
1137 if {$lim eq {}} {
1138 set lim [llength $varccommits($v,$a)]
1140 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1142 set vrowmod($v) $r
1143 undolayout $r
1147 proc update_arcrows {v} {
1148 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1149 global varcid vrownum varcorder varcix varccommits
1150 global vupptr vdownptr vleftptr varctok
1151 global displayorder parentlist curview cached_commitrow
1153 if {$vrowmod($v) == $commitidx($v)} return
1154 if {$v == $curview} {
1155 if {[llength $displayorder] > $vrowmod($v)} {
1156 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1157 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1159 unset -nocomplain cached_commitrow
1161 set narctot [expr {[llength $varctok($v)] - 1}]
1162 set a $varcmod($v)
1163 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1164 # go up the tree until we find something that has a row number,
1165 # or we get to a seed
1166 set a [lindex $vupptr($v) $a]
1168 if {$a == 0} {
1169 set a [lindex $vdownptr($v) 0]
1170 if {$a == 0} return
1171 set vrownum($v) {0}
1172 set varcorder($v) [list $a]
1173 lset varcix($v) $a 0
1174 lset varcrow($v) $a 0
1175 set arcn 0
1176 set row 0
1177 } else {
1178 set arcn [lindex $varcix($v) $a]
1179 if {[llength $vrownum($v)] > $arcn + 1} {
1180 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1181 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1183 set row [lindex $varcrow($v) $a]
1185 while {1} {
1186 set p $a
1187 incr row [llength $varccommits($v,$a)]
1188 # go down if possible
1189 set b [lindex $vdownptr($v) $a]
1190 if {$b == 0} {
1191 # if not, go left, or go up until we can go left
1192 while {$a != 0} {
1193 set b [lindex $vleftptr($v) $a]
1194 if {$b != 0} break
1195 set a [lindex $vupptr($v) $a]
1197 if {$a == 0} break
1199 set a $b
1200 incr arcn
1201 lappend vrownum($v) $row
1202 lappend varcorder($v) $a
1203 lset varcix($v) $a $arcn
1204 lset varcrow($v) $a $row
1206 set vtokmod($v) [lindex $varctok($v) $p]
1207 set varcmod($v) $p
1208 set vrowmod($v) $row
1209 if {[info exists currentid]} {
1210 set selectedline [rowofcommit $currentid]
1214 # Test whether view $v contains commit $id
1215 proc commitinview {id v} {
1216 global varcid
1218 return [info exists varcid($v,$id)]
1221 # Return the row number for commit $id in the current view
1222 proc rowofcommit {id} {
1223 global varcid varccommits varcrow curview cached_commitrow
1224 global varctok vtokmod
1226 set v $curview
1227 if {![info exists varcid($v,$id)]} {
1228 puts "oops rowofcommit no arc for [shortids $id]"
1229 return {}
1231 set a $varcid($v,$id)
1232 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1233 update_arcrows $v
1235 if {[info exists cached_commitrow($id)]} {
1236 return $cached_commitrow($id)
1238 set i [lsearch -exact $varccommits($v,$a) $id]
1239 if {$i < 0} {
1240 puts "oops didn't find commit [shortids $id] in arc $a"
1241 return {}
1243 incr i [lindex $varcrow($v) $a]
1244 set cached_commitrow($id) $i
1245 return $i
1248 # Returns 1 if a is on an earlier row than b, otherwise 0
1249 proc comes_before {a b} {
1250 global varcid varctok curview
1252 set v $curview
1253 if {$a eq $b || ![info exists varcid($v,$a)] || \
1254 ![info exists varcid($v,$b)]} {
1255 return 0
1257 if {$varcid($v,$a) != $varcid($v,$b)} {
1258 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1259 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1261 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1264 proc bsearch {l elt} {
1265 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1266 return 0
1268 set lo 0
1269 set hi [llength $l]
1270 while {$hi - $lo > 1} {
1271 set mid [expr {int(($lo + $hi) / 2)}]
1272 set t [lindex $l $mid]
1273 if {$elt < $t} {
1274 set hi $mid
1275 } elseif {$elt > $t} {
1276 set lo $mid
1277 } else {
1278 return $mid
1281 return $lo
1284 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1285 proc make_disporder {start end} {
1286 global vrownum curview commitidx displayorder parentlist
1287 global varccommits varcorder parents vrowmod varcrow
1288 global d_valid_start d_valid_end
1290 if {$end > $vrowmod($curview)} {
1291 update_arcrows $curview
1293 set ai [bsearch $vrownum($curview) $start]
1294 set start [lindex $vrownum($curview) $ai]
1295 set narc [llength $vrownum($curview)]
1296 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1297 set a [lindex $varcorder($curview) $ai]
1298 set l [llength $displayorder]
1299 set al [llength $varccommits($curview,$a)]
1300 if {$l < $r + $al} {
1301 if {$l < $r} {
1302 set pad [ntimes [expr {$r - $l}] {}]
1303 set displayorder [concat $displayorder $pad]
1304 set parentlist [concat $parentlist $pad]
1305 } elseif {$l > $r} {
1306 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1307 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1309 foreach id $varccommits($curview,$a) {
1310 lappend displayorder $id
1311 lappend parentlist $parents($curview,$id)
1313 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1314 set i $r
1315 foreach id $varccommits($curview,$a) {
1316 lset displayorder $i $id
1317 lset parentlist $i $parents($curview,$id)
1318 incr i
1321 incr r $al
1325 proc commitonrow {row} {
1326 global displayorder
1328 set id [lindex $displayorder $row]
1329 if {$id eq {}} {
1330 make_disporder $row [expr {$row + 1}]
1331 set id [lindex $displayorder $row]
1333 return $id
1336 proc closevarcs {v} {
1337 global varctok varccommits varcid parents children
1338 global cmitlisted commitidx vtokmod curview numcommits
1340 set missing_parents 0
1341 set scripts {}
1342 set narcs [llength $varctok($v)]
1343 for {set a 1} {$a < $narcs} {incr a} {
1344 set id [lindex $varccommits($v,$a) end]
1345 foreach p $parents($v,$id) {
1346 if {[info exists varcid($v,$p)]} continue
1347 # add p as a new commit
1348 incr missing_parents
1349 set cmitlisted($v,$p) 0
1350 set parents($v,$p) {}
1351 if {[llength $children($v,$p)] == 1 &&
1352 [llength $parents($v,$id)] == 1} {
1353 set b $a
1354 } else {
1355 set b [newvarc $v $p]
1357 set varcid($v,$p) $b
1358 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1359 modify_arc $v $b
1361 lappend varccommits($v,$b) $p
1362 incr commitidx($v)
1363 if {$v == $curview} {
1364 set numcommits $commitidx($v)
1366 set scripts [check_interest $p $scripts]
1369 if {$missing_parents > 0} {
1370 foreach s $scripts {
1371 eval $s
1376 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1377 # Assumes we already have an arc for $rwid.
1378 proc rewrite_commit {v id rwid} {
1379 global children parents varcid varctok vtokmod varccommits
1381 foreach ch $children($v,$id) {
1382 # make $rwid be $ch's parent in place of $id
1383 set i [lsearch -exact $parents($v,$ch) $id]
1384 if {$i < 0} {
1385 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1387 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1388 # add $ch to $rwid's children and sort the list if necessary
1389 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1390 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1391 $children($v,$rwid)]
1393 # fix the graph after joining $id to $rwid
1394 set a $varcid($v,$ch)
1395 fix_reversal $rwid $a $v
1396 # parentlist is wrong for the last element of arc $a
1397 # even if displayorder is right, hence the 3rd arg here
1398 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1402 # Mechanism for registering a command to be executed when we come
1403 # across a particular commit. To handle the case when only the
1404 # prefix of the commit is known, the commitinterest array is now
1405 # indexed by the first 4 characters of the ID. Each element is a
1406 # list of id, cmd pairs.
1407 proc interestedin {id cmd} {
1408 global commitinterest
1410 lappend commitinterest([string range $id 0 3]) $id $cmd
1413 proc check_interest {id scripts} {
1414 global commitinterest
1416 set prefix [string range $id 0 3]
1417 if {[info exists commitinterest($prefix)]} {
1418 set newlist {}
1419 foreach {i script} $commitinterest($prefix) {
1420 if {[string match "$i*" $id]} {
1421 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1422 } else {
1423 lappend newlist $i $script
1426 if {$newlist ne {}} {
1427 set commitinterest($prefix) $newlist
1428 } else {
1429 unset commitinterest($prefix)
1432 return $scripts
1435 proc getcommitlines {fd inst view updating} {
1436 global cmitlisted leftover
1437 global commitidx commitdata vdatemode
1438 global parents children curview hlview
1439 global idpending ordertok
1440 global varccommits varcid varctok vtokmod vfilelimit vshortids
1442 set stuff [read $fd 500000]
1443 # git log doesn't terminate the last commit with a null...
1444 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1445 set stuff "\0"
1447 if {$stuff == {}} {
1448 if {![eof $fd]} {
1449 return 1
1451 global commfd viewcomplete viewactive viewname
1452 global viewinstances
1453 unset commfd($inst)
1454 set i [lsearch -exact $viewinstances($view) $inst]
1455 if {$i >= 0} {
1456 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1458 # set it blocking so we wait for the process to terminate
1459 fconfigure $fd -blocking 1
1460 if {[catch {close $fd} err]} {
1461 set fv {}
1462 if {$view != $curview} {
1463 set fv " for the \"$viewname($view)\" view"
1465 if {[string range $err 0 4] == "usage"} {
1466 set err "Gitk: error reading commits$fv:\
1467 bad arguments to git log."
1468 if {$viewname($view) eq [mc "Command line"]} {
1469 append err \
1470 " (Note: arguments to gitk are passed to git log\
1471 to allow selection of commits to be displayed.)"
1473 } else {
1474 set err "Error reading commits$fv: $err"
1476 error_popup $err
1478 if {[incr viewactive($view) -1] <= 0} {
1479 set viewcomplete($view) 1
1480 # Check if we have seen any ids listed as parents that haven't
1481 # appeared in the list
1482 closevarcs $view
1483 notbusy $view
1485 if {$view == $curview} {
1486 run chewcommits
1488 return 0
1490 set start 0
1491 set gotsome 0
1492 set scripts {}
1493 while 1 {
1494 set i [string first "\0" $stuff $start]
1495 if {$i < 0} {
1496 append leftover($inst) [string range $stuff $start end]
1497 break
1499 if {$start == 0} {
1500 set cmit $leftover($inst)
1501 append cmit [string range $stuff 0 [expr {$i - 1}]]
1502 set leftover($inst) {}
1503 } else {
1504 set cmit [string range $stuff $start [expr {$i - 1}]]
1506 set start [expr {$i + 1}]
1507 set j [string first "\n" $cmit]
1508 set ok 0
1509 set listed 1
1510 if {$j >= 0 && [string match "commit *" $cmit]} {
1511 set ids [string range $cmit 7 [expr {$j - 1}]]
1512 if {[string match {[-^<>]*} $ids]} {
1513 switch -- [string index $ids 0] {
1514 "-" {set listed 0}
1515 "^" {set listed 2}
1516 "<" {set listed 3}
1517 ">" {set listed 4}
1519 set ids [string range $ids 1 end]
1521 set ok 1
1522 foreach id $ids {
1523 if {[string length $id] != 40} {
1524 set ok 0
1525 break
1529 if {!$ok} {
1530 set shortcmit $cmit
1531 if {[string length $shortcmit] > 80} {
1532 set shortcmit "[string range $shortcmit 0 80]..."
1534 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1535 exit 1
1537 set id [lindex $ids 0]
1538 set vid $view,$id
1540 lappend vshortids($view,[string range $id 0 3]) $id
1542 if {!$listed && $updating && ![info exists varcid($vid)] &&
1543 $vfilelimit($view) ne {}} {
1544 # git log doesn't rewrite parents for unlisted commits
1545 # when doing path limiting, so work around that here
1546 # by working out the rewritten parent with git rev-list
1547 # and if we already know about it, using the rewritten
1548 # parent as a substitute parent for $id's children.
1549 if {![catch {
1550 set rwid [exec git rev-list --first-parent --max-count=1 \
1551 $id -- $vfilelimit($view)]
1552 }]} {
1553 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1554 # use $rwid in place of $id
1555 rewrite_commit $view $id $rwid
1556 continue
1561 set a 0
1562 if {[info exists varcid($vid)]} {
1563 if {$cmitlisted($vid) || !$listed} continue
1564 set a $varcid($vid)
1566 if {$listed} {
1567 set olds [lrange $ids 1 end]
1568 } else {
1569 set olds {}
1571 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1572 set cmitlisted($vid) $listed
1573 set parents($vid) $olds
1574 if {![info exists children($vid)]} {
1575 set children($vid) {}
1576 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1577 set k [lindex $children($vid) 0]
1578 if {[llength $parents($view,$k)] == 1 &&
1579 (!$vdatemode($view) ||
1580 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1581 set a $varcid($view,$k)
1584 if {$a == 0} {
1585 # new arc
1586 set a [newvarc $view $id]
1588 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1589 modify_arc $view $a
1591 if {![info exists varcid($vid)]} {
1592 set varcid($vid) $a
1593 lappend varccommits($view,$a) $id
1594 incr commitidx($view)
1597 set i 0
1598 foreach p $olds {
1599 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1600 set vp $view,$p
1601 if {[llength [lappend children($vp) $id]] > 1 &&
1602 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1603 set children($vp) [lsort -command [list vtokcmp $view] \
1604 $children($vp)]
1605 unset -nocomplain ordertok
1607 if {[info exists varcid($view,$p)]} {
1608 fix_reversal $p $a $view
1611 incr i
1614 set scripts [check_interest $id $scripts]
1615 set gotsome 1
1617 if {$gotsome} {
1618 global numcommits hlview
1620 if {$view == $curview} {
1621 set numcommits $commitidx($view)
1622 run chewcommits
1624 if {[info exists hlview] && $view == $hlview} {
1625 # we never actually get here...
1626 run vhighlightmore
1628 foreach s $scripts {
1629 eval $s
1632 return 2
1635 proc chewcommits {} {
1636 global curview hlview viewcomplete
1637 global pending_select
1639 layoutmore
1640 if {$viewcomplete($curview)} {
1641 global commitidx varctok
1642 global numcommits startmsecs
1644 if {[info exists pending_select]} {
1645 update
1646 reset_pending_select {}
1648 if {[commitinview $pending_select $curview]} {
1649 selectline [rowofcommit $pending_select] 1
1650 } else {
1651 set row [first_real_row]
1652 selectline $row 1
1655 if {$commitidx($curview) > 0} {
1656 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1657 #puts "overall $ms ms for $numcommits commits"
1658 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1659 } else {
1660 show_status [mc "No commits selected"]
1662 notbusy layout
1664 return 0
1667 proc do_readcommit {id} {
1668 global tclencoding
1670 # Invoke git-log to handle automatic encoding conversion
1671 set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1672 # Read the results using i18n.logoutputencoding
1673 fconfigure $fd -translation lf -eofchar {}
1674 if {$tclencoding != {}} {
1675 fconfigure $fd -encoding $tclencoding
1677 set contents [read $fd]
1678 close $fd
1679 # Remove the heading line
1680 regsub {^commit [0-9a-f]+\n} $contents {} contents
1682 return $contents
1685 proc readcommit {id} {
1686 if {[catch {set contents [do_readcommit $id]}]} return
1687 parsecommit $id $contents 1
1690 proc parsecommit {id contents listed} {
1691 global commitinfo
1693 set inhdr 1
1694 set comment {}
1695 set headline {}
1696 set auname {}
1697 set audate {}
1698 set comname {}
1699 set comdate {}
1700 set hdrend [string first "\n\n" $contents]
1701 if {$hdrend < 0} {
1702 # should never happen...
1703 set hdrend [string length $contents]
1705 set header [string range $contents 0 [expr {$hdrend - 1}]]
1706 set comment [string range $contents [expr {$hdrend + 2}] end]
1707 foreach line [split $header "\n"] {
1708 set line [split $line " "]
1709 set tag [lindex $line 0]
1710 if {$tag == "author"} {
1711 set audate [lrange $line end-1 end]
1712 set auname [join [lrange $line 1 end-2] " "]
1713 } elseif {$tag == "committer"} {
1714 set comdate [lrange $line end-1 end]
1715 set comname [join [lrange $line 1 end-2] " "]
1718 set headline {}
1719 # take the first non-blank line of the comment as the headline
1720 set headline [string trimleft $comment]
1721 set i [string first "\n" $headline]
1722 if {$i >= 0} {
1723 set headline [string range $headline 0 $i]
1725 set headline [string trimright $headline]
1726 set i [string first "\r" $headline]
1727 if {$i >= 0} {
1728 set headline [string trimright [string range $headline 0 $i]]
1730 if {!$listed} {
1731 # git log indents the comment by 4 spaces;
1732 # if we got this via git cat-file, add the indentation
1733 set newcomment {}
1734 foreach line [split $comment "\n"] {
1735 append newcomment " "
1736 append newcomment $line
1737 append newcomment "\n"
1739 set comment $newcomment
1741 set hasnote [string first "\nNotes:\n" $contents]
1742 set diff ""
1743 # If there is diff output shown in the git-log stream, split it
1744 # out. But get rid of the empty line that always precedes the
1745 # diff.
1746 set i [string first "\n\ndiff" $comment]
1747 if {$i >= 0} {
1748 set diff [string range $comment $i+1 end]
1749 set comment [string range $comment 0 $i-1]
1751 set commitinfo($id) [list $headline $auname $audate \
1752 $comname $comdate $comment $hasnote $diff]
1755 proc getcommit {id} {
1756 global commitdata commitinfo
1758 if {[info exists commitdata($id)]} {
1759 parsecommit $id $commitdata($id) 1
1760 } else {
1761 readcommit $id
1762 if {![info exists commitinfo($id)]} {
1763 set commitinfo($id) [list [mc "No commit information available"]]
1766 return 1
1769 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1770 # and are present in the current view.
1771 # This is fairly slow...
1772 proc longid {prefix} {
1773 global varcid curview vshortids
1775 set ids {}
1776 if {[string length $prefix] >= 4} {
1777 set vshortid $curview,[string range $prefix 0 3]
1778 if {[info exists vshortids($vshortid)]} {
1779 foreach id $vshortids($vshortid) {
1780 if {[string match "$prefix*" $id]} {
1781 if {[lsearch -exact $ids $id] < 0} {
1782 lappend ids $id
1783 if {[llength $ids] >= 2} break
1788 } else {
1789 foreach match [array names varcid "$curview,$prefix*"] {
1790 lappend ids [lindex [split $match ","] 1]
1791 if {[llength $ids] >= 2} break
1794 return $ids
1797 proc readrefs {} {
1798 global tagids idtags headids idheads tagobjid
1799 global otherrefids idotherrefs mainhead mainheadid
1800 global selecthead selectheadid
1801 global hideremotes
1802 global tclencoding
1804 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1805 unset -nocomplain $v
1807 set refd [open [list | git show-ref -d] r]
1808 if {$tclencoding != {}} {
1809 fconfigure $refd -encoding $tclencoding
1811 while {[gets $refd line] >= 0} {
1812 if {[string index $line 40] ne " "} continue
1813 set id [string range $line 0 39]
1814 set ref [string range $line 41 end]
1815 if {![string match "refs/*" $ref]} continue
1816 set name [string range $ref 5 end]
1817 if {[string match "remotes/*" $name]} {
1818 if {![string match "*/HEAD" $name] && !$hideremotes} {
1819 set headids($name) $id
1820 lappend idheads($id) $name
1822 } elseif {[string match "heads/*" $name]} {
1823 set name [string range $name 6 end]
1824 set headids($name) $id
1825 lappend idheads($id) $name
1826 } elseif {[string match "tags/*" $name]} {
1827 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1828 # which is what we want since the former is the commit ID
1829 set name [string range $name 5 end]
1830 if {[string match "*^{}" $name]} {
1831 set name [string range $name 0 end-3]
1832 } else {
1833 set tagobjid($name) $id
1835 set tagids($name) $id
1836 lappend idtags($id) $name
1837 } else {
1838 set otherrefids($name) $id
1839 lappend idotherrefs($id) $name
1842 catch {close $refd}
1843 set mainhead {}
1844 set mainheadid {}
1845 catch {
1846 set mainheadid [exec git rev-parse HEAD]
1847 set thehead [exec git symbolic-ref HEAD]
1848 if {[string match "refs/heads/*" $thehead]} {
1849 set mainhead [string range $thehead 11 end]
1852 set selectheadid {}
1853 if {$selecthead ne {}} {
1854 catch {
1855 set selectheadid [exec git rev-parse --verify $selecthead]
1860 # skip over fake commits
1861 proc first_real_row {} {
1862 global nullid nullid2 numcommits
1864 for {set row 0} {$row < $numcommits} {incr row} {
1865 set id [commitonrow $row]
1866 if {$id ne $nullid && $id ne $nullid2} {
1867 break
1870 return $row
1873 # update things for a head moved to a child of its previous location
1874 proc movehead {id name} {
1875 global headids idheads
1877 removehead $headids($name) $name
1878 set headids($name) $id
1879 lappend idheads($id) $name
1882 # update things when a head has been removed
1883 proc removehead {id name} {
1884 global headids idheads
1886 if {$idheads($id) eq $name} {
1887 unset idheads($id)
1888 } else {
1889 set i [lsearch -exact $idheads($id) $name]
1890 if {$i >= 0} {
1891 set idheads($id) [lreplace $idheads($id) $i $i]
1894 unset headids($name)
1897 proc ttk_toplevel {w args} {
1898 global use_ttk
1899 eval [linsert $args 0 ::toplevel $w]
1900 if {$use_ttk} {
1901 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1903 return $w
1906 proc make_transient {window origin} {
1907 global have_tk85
1909 # In MacOS Tk 8.4 transient appears to work by setting
1910 # overrideredirect, which is utterly useless, since the
1911 # windows get no border, and are not even kept above
1912 # the parent.
1913 if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1915 wm transient $window $origin
1917 # Windows fails to place transient windows normally, so
1918 # schedule a callback to center them on the parent.
1919 if {[tk windowingsystem] eq {win32}} {
1920 after idle [list tk::PlaceWindow $window widget $origin]
1924 proc show_error {w top msg} {
1925 global NS
1926 if {![info exists NS]} {set NS ""}
1927 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1928 message $w.m -text $msg -justify center -aspect 400
1929 pack $w.m -side top -fill x -padx 20 -pady 20
1930 ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1931 pack $w.ok -side bottom -fill x
1932 bind $top <Visibility> "grab $top; focus $top"
1933 bind $top <Key-Return> "destroy $top"
1934 bind $top <Key-space> "destroy $top"
1935 bind $top <Key-Escape> "destroy $top"
1936 tkwait window $top
1939 proc error_popup {msg {owner .}} {
1940 if {[tk windowingsystem] eq "win32"} {
1941 tk_messageBox -icon error -type ok -title [wm title .] \
1942 -parent $owner -message $msg
1943 } else {
1944 set w .error
1945 ttk_toplevel $w
1946 make_transient $w $owner
1947 show_error $w $w $msg
1951 proc confirm_popup {msg {owner .}} {
1952 global confirm_ok NS
1953 set confirm_ok 0
1954 set w .confirm
1955 ttk_toplevel $w
1956 make_transient $w $owner
1957 message $w.m -text $msg -justify center -aspect 400
1958 pack $w.m -side top -fill x -padx 20 -pady 20
1959 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1960 pack $w.ok -side left -fill x
1961 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1962 pack $w.cancel -side right -fill x
1963 bind $w <Visibility> "grab $w; focus $w"
1964 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1965 bind $w <Key-space> "set confirm_ok 1; destroy $w"
1966 bind $w <Key-Escape> "destroy $w"
1967 tk::PlaceWindow $w widget $owner
1968 tkwait window $w
1969 return $confirm_ok
1972 proc setoptions {} {
1973 global use_ttk
1975 if {[tk windowingsystem] ne "win32"} {
1976 option add *Panedwindow.showHandle 1 startupFile
1977 option add *Panedwindow.sashRelief raised startupFile
1978 if {[tk windowingsystem] ne "aqua"} {
1979 option add *Menu.font uifont startupFile
1981 } else {
1982 option add *Menu.TearOff 0 startupFile
1984 option add *Button.font uifont startupFile
1985 option add *Checkbutton.font uifont startupFile
1986 option add *Radiobutton.font uifont startupFile
1987 option add *Menubutton.font uifont startupFile
1988 option add *Label.font uifont startupFile
1989 option add *Message.font uifont startupFile
1990 option add *Entry.font textfont startupFile
1991 option add *Text.font textfont startupFile
1992 option add *Labelframe.font uifont startupFile
1993 option add *Spinbox.font textfont startupFile
1994 option add *Listbox.font mainfont startupFile
1997 proc setttkstyle {} {
1998 eval font configure TkDefaultFont [fontflags mainfont]
1999 eval font configure TkTextFont [fontflags textfont]
2000 eval font configure TkHeadingFont [fontflags mainfont]
2001 eval font configure TkCaptionFont [fontflags mainfont] -weight bold
2002 eval font configure TkTooltipFont [fontflags uifont]
2003 eval font configure TkFixedFont [fontflags textfont]
2004 eval font configure TkIconFont [fontflags uifont]
2005 eval font configure TkMenuFont [fontflags uifont]
2006 eval font configure TkSmallCaptionFont [fontflags uifont]
2009 # Make a menu and submenus.
2010 # m is the window name for the menu, items is the list of menu items to add.
2011 # Each item is a list {mc label type description options...}
2012 # mc is ignored; it's so we can put mc there to alert xgettext
2013 # label is the string that appears in the menu
2014 # type is cascade, command or radiobutton (should add checkbutton)
2015 # description depends on type; it's the sublist for cascade, the
2016 # command to invoke for command, or {variable value} for radiobutton
2017 proc makemenu {m items} {
2018 menu $m
2019 if {[tk windowingsystem] eq {aqua}} {
2020 set Meta1 Cmd
2021 } else {
2022 set Meta1 Ctrl
2024 foreach i $items {
2025 set name [mc [lindex $i 1]]
2026 set type [lindex $i 2]
2027 set thing [lindex $i 3]
2028 set params [list $type]
2029 if {$name ne {}} {
2030 set u [string first "&" [string map {&& x} $name]]
2031 lappend params -label [string map {&& & & {}} $name]
2032 if {$u >= 0} {
2033 lappend params -underline $u
2036 switch -- $type {
2037 "cascade" {
2038 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
2039 lappend params -menu $m.$submenu
2041 "command" {
2042 lappend params -command $thing
2044 "radiobutton" {
2045 lappend params -variable [lindex $thing 0] \
2046 -value [lindex $thing 1]
2049 set tail [lrange $i 4 end]
2050 regsub -all {\yMeta1\y} $tail $Meta1 tail
2051 eval $m add $params $tail
2052 if {$type eq "cascade"} {
2053 makemenu $m.$submenu $thing
2058 # translate string and remove ampersands
2059 proc mca {str} {
2060 return [string map {&& & & {}} [mc $str]]
2063 proc cleardropsel {w} {
2064 $w selection clear
2066 proc makedroplist {w varname args} {
2067 global use_ttk
2068 if {$use_ttk} {
2069 set width 0
2070 foreach label $args {
2071 set cx [string length $label]
2072 if {$cx > $width} {set width $cx}
2074 set gm [ttk::combobox $w -width $width -state readonly\
2075 -textvariable $varname -values $args \
2076 -exportselection false]
2077 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2078 } else {
2079 set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2081 return $gm
2084 proc makewindow {} {
2085 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2086 global tabstop
2087 global findtype findtypemenu findloc findstring fstring geometry
2088 global entries sha1entry sha1string sha1but
2089 global diffcontextstring diffcontext
2090 global ignorespace
2091 global maincursor textcursor curtextcursor
2092 global rowctxmenu fakerowmenu mergemax wrapcomment
2093 global highlight_files gdttype
2094 global searchstring sstring
2095 global bgcolor fgcolor bglist fglist diffcolors diffbgcolors selectbgcolor
2096 global uifgcolor uifgdisabledcolor
2097 global filesepbgcolor filesepfgcolor
2098 global mergecolors foundbgcolor currentsearchhitbgcolor
2099 global headctxmenu progresscanv progressitem progresscoords statusw
2100 global fprogitem fprogcoord lastprogupdate progupdatepending
2101 global rprogitem rprogcoord rownumsel numcommits
2102 global have_tk85 use_ttk NS
2103 global git_version
2104 global worddiff
2106 # The "mc" arguments here are purely so that xgettext
2107 # sees the following string as needing to be translated
2108 set file {
2109 mc "&File" cascade {
2110 {mc "&Update" command updatecommits -accelerator F5}
2111 {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2112 {mc "Reread re&ferences" command rereadrefs}
2113 {mc "&List references" command showrefs -accelerator F2}
2114 {xx "" separator}
2115 {mc "Start git &gui" command {exec git gui &}}
2116 {xx "" separator}
2117 {mc "&Quit" command doquit -accelerator Meta1-Q}
2119 set edit {
2120 mc "&Edit" cascade {
2121 {mc "&Preferences" command doprefs}
2123 set view {
2124 mc "&View" cascade {
2125 {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2126 {mc "&Edit view..." command editview -state disabled -accelerator F4}
2127 {mc "&Delete view" command delview -state disabled}
2128 {xx "" separator}
2129 {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2131 if {[tk windowingsystem] ne "aqua"} {
2132 set help {
2133 mc "&Help" cascade {
2134 {mc "&About gitk" command about}
2135 {mc "&Key bindings" command keys}
2137 set bar [list $file $edit $view $help]
2138 } else {
2139 proc ::tk::mac::ShowPreferences {} {doprefs}
2140 proc ::tk::mac::Quit {} {doquit}
2141 lset file end [lreplace [lindex $file end] end-1 end]
2142 set apple {
2143 xx "&Apple" cascade {
2144 {mc "&About gitk" command about}
2145 {xx "" separator}
2147 set help {
2148 mc "&Help" cascade {
2149 {mc "&Key bindings" command keys}
2151 set bar [list $apple $file $view $help]
2153 makemenu .bar $bar
2154 . configure -menu .bar
2156 if {$use_ttk} {
2157 # cover the non-themed toplevel with a themed frame.
2158 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2161 # the gui has upper and lower half, parts of a paned window.
2162 ${NS}::panedwindow .ctop -orient vertical
2164 # possibly use assumed geometry
2165 if {![info exists geometry(pwsash0)]} {
2166 set geometry(topheight) [expr {15 * $linespc}]
2167 set geometry(topwidth) [expr {80 * $charspc}]
2168 set geometry(botheight) [expr {15 * $linespc}]
2169 set geometry(botwidth) [expr {50 * $charspc}]
2170 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2171 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2174 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2175 ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2176 ${NS}::frame .tf.histframe
2177 ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2178 if {!$use_ttk} {
2179 .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2182 # create three canvases
2183 set cscroll .tf.histframe.csb
2184 set canv .tf.histframe.pwclist.canv
2185 canvas $canv \
2186 -selectbackground $selectbgcolor \
2187 -background $bgcolor -bd 0 \
2188 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2189 .tf.histframe.pwclist add $canv
2190 set canv2 .tf.histframe.pwclist.canv2
2191 canvas $canv2 \
2192 -selectbackground $selectbgcolor \
2193 -background $bgcolor -bd 0 -yscrollincr $linespc
2194 .tf.histframe.pwclist add $canv2
2195 set canv3 .tf.histframe.pwclist.canv3
2196 canvas $canv3 \
2197 -selectbackground $selectbgcolor \
2198 -background $bgcolor -bd 0 -yscrollincr $linespc
2199 .tf.histframe.pwclist add $canv3
2200 if {$use_ttk} {
2201 bind .tf.histframe.pwclist <Map> {
2202 bind %W <Map> {}
2203 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2204 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2206 } else {
2207 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2208 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2211 # a scroll bar to rule them
2212 ${NS}::scrollbar $cscroll -command {allcanvs yview}
2213 if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2214 pack $cscroll -side right -fill y
2215 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2216 lappend bglist $canv $canv2 $canv3
2217 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2219 # we have two button bars at bottom of top frame. Bar 1
2220 ${NS}::frame .tf.bar
2221 ${NS}::frame .tf.lbar -height 15
2223 set sha1entry .tf.bar.sha1
2224 set entries $sha1entry
2225 set sha1but .tf.bar.sha1label
2226 button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2227 -command gotocommit -width 8
2228 $sha1but conf -disabledforeground [$sha1but cget -foreground]
2229 pack .tf.bar.sha1label -side left
2230 ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2231 trace add variable sha1string write sha1change
2232 pack $sha1entry -side left -pady 2
2234 set bm_left_data {
2235 #define left_width 16
2236 #define left_height 16
2237 static unsigned char left_bits[] = {
2238 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2239 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2240 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2242 set bm_right_data {
2243 #define right_width 16
2244 #define right_height 16
2245 static unsigned char right_bits[] = {
2246 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2247 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2248 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2250 image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2251 image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2252 image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2253 image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2255 ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2256 if {$use_ttk} {
2257 .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2258 } else {
2259 .tf.bar.leftbut configure -image bm-left
2261 pack .tf.bar.leftbut -side left -fill y
2262 ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2263 if {$use_ttk} {
2264 .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2265 } else {
2266 .tf.bar.rightbut configure -image bm-right
2268 pack .tf.bar.rightbut -side left -fill y
2270 ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2271 set rownumsel {}
2272 ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2273 -relief sunken -anchor e
2274 ${NS}::label .tf.bar.rowlabel2 -text "/"
2275 ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2276 -relief sunken -anchor e
2277 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2278 -side left
2279 if {!$use_ttk} {
2280 foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2282 global selectedline
2283 trace add variable selectedline write selectedline_change
2285 # Status label and progress bar
2286 set statusw .tf.bar.status
2287 ${NS}::label $statusw -width 15 -relief sunken
2288 pack $statusw -side left -padx 5
2289 if {$use_ttk} {
2290 set progresscanv [ttk::progressbar .tf.bar.progress]
2291 } else {
2292 set h [expr {[font metrics uifont -linespace] + 2}]
2293 set progresscanv .tf.bar.progress
2294 canvas $progresscanv -relief sunken -height $h -borderwidth 2
2295 set progressitem [$progresscanv create rect -1 0 0 $h -fill "#00ff00"]
2296 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2297 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2299 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2300 set progresscoords {0 0}
2301 set fprogcoord 0
2302 set rprogcoord 0
2303 bind $progresscanv <Configure> adjustprogress
2304 set lastprogupdate [clock clicks -milliseconds]
2305 set progupdatepending 0
2307 # build up the bottom bar of upper window
2308 ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2310 set bm_down_data {
2311 #define down_width 16
2312 #define down_height 16
2313 static unsigned char down_bits[] = {
2314 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2315 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2316 0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2317 0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2319 image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2320 ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2321 .tf.lbar.fnext configure -image bm-down
2323 set bm_up_data {
2324 #define up_width 16
2325 #define up_height 16
2326 static unsigned char up_bits[] = {
2327 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2328 0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2329 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2330 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2332 image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2333 ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2334 .tf.lbar.fprev configure -image bm-up
2336 ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2338 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2339 -side left -fill y
2340 set gdttype [mc "containing:"]
2341 set gm [makedroplist .tf.lbar.gdttype gdttype \
2342 [mc "containing:"] \
2343 [mc "touching paths:"] \
2344 [mc "adding/removing string:"] \
2345 [mc "changing lines matching:"]]
2346 trace add variable gdttype write gdttype_change
2347 pack .tf.lbar.gdttype -side left -fill y
2349 set findstring {}
2350 set fstring .tf.lbar.findstring
2351 lappend entries $fstring
2352 ${NS}::entry $fstring -width 30 -textvariable findstring
2353 trace add variable findstring write find_change
2354 set findtype [mc "Exact"]
2355 set findtypemenu [makedroplist .tf.lbar.findtype \
2356 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2357 trace add variable findtype write findcom_change
2358 set findloc [mc "All fields"]
2359 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2360 [mc "Comments"] [mc "Author"] [mc "Committer"]
2361 trace add variable findloc write find_change
2362 pack .tf.lbar.findloc -side right
2363 pack .tf.lbar.findtype -side right
2364 pack $fstring -side left -expand 1 -fill x
2366 # Finish putting the upper half of the viewer together
2367 pack .tf.lbar -in .tf -side bottom -fill x
2368 pack .tf.bar -in .tf -side bottom -fill x
2369 pack .tf.histframe -fill both -side top -expand 1
2370 .ctop add .tf
2371 if {!$use_ttk} {
2372 .ctop paneconfigure .tf -height $geometry(topheight)
2373 .ctop paneconfigure .tf -width $geometry(topwidth)
2376 # now build up the bottom
2377 ${NS}::panedwindow .pwbottom -orient horizontal
2379 # lower left, a text box over search bar, scroll bar to the right
2380 # if we know window height, then that will set the lower text height, otherwise
2381 # we set lower text height which will drive window height
2382 if {[info exists geometry(main)]} {
2383 ${NS}::frame .bleft -width $geometry(botwidth)
2384 } else {
2385 ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2387 ${NS}::frame .bleft.top
2388 ${NS}::frame .bleft.mid
2389 ${NS}::frame .bleft.bottom
2391 # gap between sub-widgets
2392 set wgap [font measure uifont "i"]
2394 ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2395 pack .bleft.top.search -side left -padx 5
2396 set sstring .bleft.top.sstring
2397 set searchstring ""
2398 ${NS}::entry $sstring -width 20 -textvariable searchstring
2399 lappend entries $sstring
2400 trace add variable searchstring write incrsearch
2401 pack $sstring -side left -expand 1 -fill x
2402 ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2403 -command changediffdisp -variable diffelide -value {0 0}
2404 ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2405 -command changediffdisp -variable diffelide -value {0 1}
2406 ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2407 -command changediffdisp -variable diffelide -value {1 0}
2409 ${NS}::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2410 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left -ipadx $wgap
2411 spinbox .bleft.mid.diffcontext -width 5 \
2412 -from 0 -increment 1 -to 10000000 \
2413 -validate all -validatecommand "diffcontextvalidate %P" \
2414 -textvariable diffcontextstring
2415 .bleft.mid.diffcontext set $diffcontext
2416 trace add variable diffcontextstring write diffcontextchange
2417 lappend entries .bleft.mid.diffcontext
2418 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left -ipadx $wgap
2419 ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2420 -command changeignorespace -variable ignorespace
2421 pack .bleft.mid.ignspace -side left -padx 5
2423 set worddiff [mc "Line diff"]
2424 if {[package vcompare $git_version "1.7.2"] >= 0} {
2425 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2426 [mc "Markup words"] [mc "Color words"]
2427 trace add variable worddiff write changeworddiff
2428 pack .bleft.mid.worddiff -side left -padx 5
2431 set ctext .bleft.bottom.ctext
2432 text $ctext -background $bgcolor -foreground $fgcolor \
2433 -state disabled -undo 0 -font textfont \
2434 -yscrollcommand scrolltext -wrap none \
2435 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2436 if {$have_tk85} {
2437 $ctext conf -tabstyle wordprocessor
2439 ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2440 ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2441 pack .bleft.top -side top -fill x
2442 pack .bleft.mid -side top -fill x
2443 grid $ctext .bleft.bottom.sb -sticky nsew
2444 grid .bleft.bottom.sbhorizontal -sticky ew
2445 grid columnconfigure .bleft.bottom 0 -weight 1
2446 grid rowconfigure .bleft.bottom 0 -weight 1
2447 grid rowconfigure .bleft.bottom 1 -weight 0
2448 pack .bleft.bottom -side top -fill both -expand 1
2449 lappend bglist $ctext
2450 lappend fglist $ctext
2452 $ctext tag conf comment -wrap $wrapcomment
2453 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2454 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2455 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2456 $ctext tag conf d0 -back [lindex $diffbgcolors 0]
2457 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2458 $ctext tag conf dresult -back [lindex $diffbgcolors 1]
2459 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2460 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2461 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2462 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2463 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2464 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2465 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2466 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2467 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2468 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2469 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2470 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2471 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2472 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2473 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2474 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2475 $ctext tag conf mmax -fore darkgrey
2476 set mergemax 16
2477 $ctext tag conf mresult -font textfontbold
2478 $ctext tag conf msep -font textfontbold
2479 $ctext tag conf found -back $foundbgcolor
2480 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2481 $ctext tag conf wwrap -wrap word -lmargin2 1c
2482 $ctext tag conf bold -font textfontbold
2483 # set these to the lowest priority:
2484 $ctext tag lower currentsearchhit
2485 $ctext tag lower found
2486 $ctext tag lower filesep
2487 $ctext tag lower dresult
2488 $ctext tag lower d0
2490 .pwbottom add .bleft
2491 if {!$use_ttk} {
2492 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2495 # lower right
2496 ${NS}::frame .bright
2497 ${NS}::frame .bright.mode
2498 ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2499 -command reselectline -variable cmitmode -value "patch"
2500 ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2501 -command reselectline -variable cmitmode -value "tree"
2502 grid .bright.mode.patch .bright.mode.tree -sticky ew
2503 pack .bright.mode -side top -fill x
2504 set cflist .bright.cfiles
2505 set indent [font measure mainfont "nn"]
2506 text $cflist \
2507 -selectbackground $selectbgcolor \
2508 -background $bgcolor -foreground $fgcolor \
2509 -font mainfont \
2510 -tabs [list $indent [expr {2 * $indent}]] \
2511 -yscrollcommand ".bright.sb set" \
2512 -cursor [. cget -cursor] \
2513 -spacing1 1 -spacing3 1
2514 lappend bglist $cflist
2515 lappend fglist $cflist
2516 ${NS}::scrollbar .bright.sb -command "$cflist yview"
2517 pack .bright.sb -side right -fill y
2518 pack $cflist -side left -fill both -expand 1
2519 $cflist tag configure highlight \
2520 -background [$cflist cget -selectbackground]
2521 $cflist tag configure bold -font mainfontbold
2523 .pwbottom add .bright
2524 .ctop add .pwbottom
2526 # restore window width & height if known
2527 if {[info exists geometry(main)]} {
2528 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2529 if {$w > [winfo screenwidth .]} {
2530 set w [winfo screenwidth .]
2532 if {$h > [winfo screenheight .]} {
2533 set h [winfo screenheight .]
2535 wm geometry . "${w}x$h"
2539 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2540 wm state . $geometry(state)
2543 if {[tk windowingsystem] eq {aqua}} {
2544 set M1B M1
2545 set ::BM "3"
2546 } else {
2547 set M1B Control
2548 set ::BM "2"
2551 if {$use_ttk} {
2552 bind .ctop <Map> {
2553 bind %W <Map> {}
2554 %W sashpos 0 $::geometry(topheight)
2556 bind .pwbottom <Map> {
2557 bind %W <Map> {}
2558 %W sashpos 0 $::geometry(botwidth)
2560 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2563 pack .ctop -fill both -expand 1
2564 bindall <1> {selcanvline %W %x %y}
2565 #bindall <B1-Motion> {selcanvline %W %x %y}
2566 if {[tk windowingsystem] == "win32"} {
2567 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2568 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2569 } else {
2570 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2571 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2572 bind $ctext <Button> {
2573 if {"%b" eq 6} {
2574 $ctext xview scroll -5 units
2575 } elseif {"%b" eq 7} {
2576 $ctext xview scroll 5 units
2579 if {[tk windowingsystem] eq "aqua"} {
2580 bindall <MouseWheel> {
2581 set delta [expr {- (%D)}]
2582 allcanvs yview scroll $delta units
2584 bindall <Shift-MouseWheel> {
2585 set delta [expr {- (%D)}]
2586 $canv xview scroll $delta units
2590 bindall <$::BM> "canvscan mark %W %x %y"
2591 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2592 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2593 bind . <$M1B-Key-w> doquit
2594 bindkey <Home> selfirstline
2595 bindkey <End> sellastline
2596 bind . <Key-Up> "selnextline -1"
2597 bind . <Key-Down> "selnextline 1"
2598 bind . <Shift-Key-Up> "dofind -1 0"
2599 bind . <Shift-Key-Down> "dofind 1 0"
2600 bindkey <Key-Right> "goforw"
2601 bindkey <Key-Left> "goback"
2602 bind . <Key-Prior> "selnextpage -1"
2603 bind . <Key-Next> "selnextpage 1"
2604 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2605 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2606 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2607 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2608 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2609 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2610 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2611 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2612 bindkey <Key-space> "$ctext yview scroll 1 pages"
2613 bindkey p "selnextline -1"
2614 bindkey n "selnextline 1"
2615 bindkey z "goback"
2616 bindkey x "goforw"
2617 bindkey k "selnextline -1"
2618 bindkey j "selnextline 1"
2619 bindkey h "goback"
2620 bindkey l "goforw"
2621 bindkey b prevfile
2622 bindkey d "$ctext yview scroll 18 units"
2623 bindkey u "$ctext yview scroll -18 units"
2624 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2625 bindkey / {focus $fstring}
2626 bindkey <Key-KP_Divide> {focus $fstring}
2627 bindkey <Key-Return> {dofind 1 1}
2628 bindkey ? {dofind -1 1}
2629 bindkey f nextfile
2630 bind . <F5> updatecommits
2631 bindmodfunctionkey Shift 5 reloadcommits
2632 bind . <F2> showrefs
2633 bindmodfunctionkey Shift 4 {newview 0}
2634 bind . <F4> edit_or_newview
2635 bind . <$M1B-q> doquit
2636 bind . <$M1B-f> {dofind 1 1}
2637 bind . <$M1B-g> {dofind 1 0}
2638 bind . <$M1B-r> dosearchback
2639 bind . <$M1B-s> dosearch
2640 bind . <$M1B-equal> {incrfont 1}
2641 bind . <$M1B-plus> {incrfont 1}
2642 bind . <$M1B-KP_Add> {incrfont 1}
2643 bind . <$M1B-minus> {incrfont -1}
2644 bind . <$M1B-KP_Subtract> {incrfont -1}
2645 wm protocol . WM_DELETE_WINDOW doquit
2646 bind . <Destroy> {stop_backends}
2647 bind . <Button-1> "click %W"
2648 bind $fstring <Key-Return> {dofind 1 1}
2649 bind $sha1entry <Key-Return> {gotocommit; break}
2650 bind $sha1entry <<PasteSelection>> clearsha1
2651 bind $sha1entry <<Paste>> clearsha1
2652 bind $cflist <1> {sel_flist %W %x %y; break}
2653 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2654 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2655 global ctxbut
2656 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2657 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2658 bind $ctext <Button-1> {focus %W}
2659 bind $ctext <<Selection>> rehighlight_search_results
2660 for {set i 1} {$i < 10} {incr i} {
2661 bind . <$M1B-Key-$i> [list go_to_parent $i]
2664 set maincursor [. cget -cursor]
2665 set textcursor [$ctext cget -cursor]
2666 set curtextcursor $textcursor
2668 set rowctxmenu .rowctxmenu
2669 makemenu $rowctxmenu {
2670 {mc "Diff this -> selected" command {diffvssel 0}}
2671 {mc "Diff selected -> this" command {diffvssel 1}}
2672 {mc "Make patch" command mkpatch}
2673 {mc "Create tag" command mktag}
2674 {mc "Copy commit reference" command copyreference}
2675 {mc "Write commit to file" command writecommit}
2676 {mc "Create new branch" command mkbranch}
2677 {mc "Cherry-pick this commit" command cherrypick}
2678 {mc "Reset HEAD branch to here" command resethead}
2679 {mc "Mark this commit" command markhere}
2680 {mc "Return to mark" command gotomark}
2681 {mc "Find descendant of this and mark" command find_common_desc}
2682 {mc "Compare with marked commit" command compare_commits}
2683 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2684 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2685 {mc "Revert this commit" command revert}
2687 $rowctxmenu configure -tearoff 0
2689 set fakerowmenu .fakerowmenu
2690 makemenu $fakerowmenu {
2691 {mc "Diff this -> selected" command {diffvssel 0}}
2692 {mc "Diff selected -> this" command {diffvssel 1}}
2693 {mc "Make patch" command mkpatch}
2694 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2695 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2697 $fakerowmenu configure -tearoff 0
2699 set headctxmenu .headctxmenu
2700 makemenu $headctxmenu {
2701 {mc "Check out this branch" command cobranch}
2702 {mc "Rename this branch" command mvbranch}
2703 {mc "Remove this branch" command rmbranch}
2704 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2706 $headctxmenu configure -tearoff 0
2708 global flist_menu
2709 set flist_menu .flistctxmenu
2710 makemenu $flist_menu {
2711 {mc "Highlight this too" command {flist_hl 0}}
2712 {mc "Highlight this only" command {flist_hl 1}}
2713 {mc "External diff" command {external_diff}}
2714 {mc "Blame parent commit" command {external_blame 1}}
2715 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2717 $flist_menu configure -tearoff 0
2719 global diff_menu
2720 set diff_menu .diffctxmenu
2721 makemenu $diff_menu {
2722 {mc "Show origin of this line" command show_line_source}
2723 {mc "Run git gui blame on this line" command {external_blame_diff}}
2725 $diff_menu configure -tearoff 0
2728 # Windows sends all mouse wheel events to the current focused window, not
2729 # the one where the mouse hovers, so bind those events here and redirect
2730 # to the correct window
2731 proc windows_mousewheel_redirector {W X Y D} {
2732 global canv canv2 canv3
2733 set w [winfo containing -displayof $W $X $Y]
2734 if {$w ne ""} {
2735 set u [expr {$D < 0 ? 5 : -5}]
2736 if {$w == $canv || $w == $canv2 || $w == $canv3} {
2737 allcanvs yview scroll $u units
2738 } else {
2739 catch {
2740 $w yview scroll $u units
2746 # Update row number label when selectedline changes
2747 proc selectedline_change {n1 n2 op} {
2748 global selectedline rownumsel
2750 if {$selectedline eq {}} {
2751 set rownumsel {}
2752 } else {
2753 set rownumsel [expr {$selectedline + 1}]
2757 # mouse-2 makes all windows scan vertically, but only the one
2758 # the cursor is in scans horizontally
2759 proc canvscan {op w x y} {
2760 global canv canv2 canv3
2761 foreach c [list $canv $canv2 $canv3] {
2762 if {$c == $w} {
2763 $c scan $op $x $y
2764 } else {
2765 $c scan $op 0 $y
2770 proc scrollcanv {cscroll f0 f1} {
2771 $cscroll set $f0 $f1
2772 drawvisible
2773 flushhighlights
2776 # when we make a key binding for the toplevel, make sure
2777 # it doesn't get triggered when that key is pressed in the
2778 # find string entry widget.
2779 proc bindkey {ev script} {
2780 global entries
2781 bind . $ev $script
2782 set escript [bind Entry $ev]
2783 if {$escript == {}} {
2784 set escript [bind Entry <Key>]
2786 foreach e $entries {
2787 bind $e $ev "$escript; break"
2791 proc bindmodfunctionkey {mod n script} {
2792 bind . <$mod-F$n> $script
2793 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2796 # set the focus back to the toplevel for any click outside
2797 # the entry widgets
2798 proc click {w} {
2799 global ctext entries
2800 foreach e [concat $entries $ctext] {
2801 if {$w == $e} return
2803 focus .
2806 # Adjust the progress bar for a change in requested extent or canvas size
2807 proc adjustprogress {} {
2808 global progresscanv progressitem progresscoords
2809 global fprogitem fprogcoord lastprogupdate progupdatepending
2810 global rprogitem rprogcoord use_ttk
2812 if {$use_ttk} {
2813 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2814 return
2817 set w [expr {[winfo width $progresscanv] - 4}]
2818 set x0 [expr {$w * [lindex $progresscoords 0]}]
2819 set x1 [expr {$w * [lindex $progresscoords 1]}]
2820 set h [winfo height $progresscanv]
2821 $progresscanv coords $progressitem $x0 0 $x1 $h
2822 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2823 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2824 set now [clock clicks -milliseconds]
2825 if {$now >= $lastprogupdate + 100} {
2826 set progupdatepending 0
2827 update
2828 } elseif {!$progupdatepending} {
2829 set progupdatepending 1
2830 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2834 proc doprogupdate {} {
2835 global lastprogupdate progupdatepending
2837 if {$progupdatepending} {
2838 set progupdatepending 0
2839 set lastprogupdate [clock clicks -milliseconds]
2840 update
2844 proc config_check_tmp_exists {tries_left} {
2845 global config_file_tmp
2847 if {[file exists $config_file_tmp]} {
2848 incr tries_left -1
2849 if {$tries_left > 0} {
2850 after 100 [list config_check_tmp_exists $tries_left]
2851 } else {
2852 error_popup "There appears to be a stale $config_file_tmp\
2853 file, which will prevent gitk from saving its configuration on exit.\
2854 Please remove it if it is not being used by any existing gitk process."
2859 proc config_init_trace {name} {
2860 global config_variable_changed config_variable_original
2862 upvar #0 $name var
2863 set config_variable_changed($name) 0
2864 set config_variable_original($name) $var
2867 proc config_variable_change_cb {name name2 op} {
2868 global config_variable_changed config_variable_original
2870 upvar #0 $name var
2871 if {$op eq "write" &&
2872 (![info exists config_variable_original($name)] ||
2873 $config_variable_original($name) ne $var)} {
2874 set config_variable_changed($name) 1
2878 proc savestuff {w} {
2879 global stuffsaved
2880 global config_file config_file_tmp
2881 global config_variables config_variable_changed
2882 global viewchanged
2884 upvar #0 viewname current_viewname
2885 upvar #0 viewfiles current_viewfiles
2886 upvar #0 viewargs current_viewargs
2887 upvar #0 viewargscmd current_viewargscmd
2888 upvar #0 viewperm current_viewperm
2889 upvar #0 nextviewnum current_nextviewnum
2890 upvar #0 use_ttk current_use_ttk
2892 if {$stuffsaved} return
2893 if {![winfo viewable .]} return
2894 set remove_tmp 0
2895 if {[catch {
2896 set try_count 0
2897 while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2898 if {[incr try_count] > 50} {
2899 error "Unable to write config file: $config_file_tmp exists"
2901 after 100
2903 set remove_tmp 1
2904 if {$::tcl_platform(platform) eq {windows}} {
2905 file attributes $config_file_tmp -hidden true
2907 if {[file exists $config_file]} {
2908 source $config_file
2910 foreach var_name $config_variables {
2911 upvar #0 $var_name var
2912 upvar 0 $var_name old_var
2913 if {!$config_variable_changed($var_name) && [info exists old_var]} {
2914 puts $f [list set $var_name $old_var]
2915 } else {
2916 puts $f [list set $var_name $var]
2920 puts $f "set geometry(main) [wm geometry .]"
2921 puts $f "set geometry(state) [wm state .]"
2922 puts $f "set geometry(topwidth) [winfo width .tf]"
2923 puts $f "set geometry(topheight) [winfo height .tf]"
2924 if {$current_use_ttk} {
2925 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2926 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2927 } else {
2928 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2929 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2931 puts $f "set geometry(botwidth) [winfo width .bleft]"
2932 puts $f "set geometry(botheight) [winfo height .bleft]"
2934 array set view_save {}
2935 array set views {}
2936 if {![info exists permviews]} { set permviews {} }
2937 foreach view $permviews {
2938 set view_save([lindex $view 0]) 1
2939 set views([lindex $view 0]) $view
2941 puts -nonewline $f "set permviews {"
2942 for {set v 1} {$v < $current_nextviewnum} {incr v} {
2943 if {$viewchanged($v)} {
2944 if {$current_viewperm($v)} {
2945 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2946 } else {
2947 set view_save($current_viewname($v)) 0
2951 # write old and updated view to their places and append remaining to the end
2952 foreach view $permviews {
2953 set view_name [lindex $view 0]
2954 if {$view_save($view_name)} {
2955 puts $f "{$views($view_name)}"
2957 unset views($view_name)
2959 foreach view_name [array names views] {
2960 puts $f "{$views($view_name)}"
2962 puts $f "}"
2963 close $f
2964 file rename -force $config_file_tmp $config_file
2965 set remove_tmp 0
2966 } err]} {
2967 puts "Error saving config: $err"
2969 if {$remove_tmp} {
2970 file delete -force $config_file_tmp
2972 set stuffsaved 1
2975 proc resizeclistpanes {win w} {
2976 global oldwidth oldsash use_ttk
2977 if {[info exists oldwidth($win)]} {
2978 if {[info exists oldsash($win)]} {
2979 set s0 [lindex $oldsash($win) 0]
2980 set s1 [lindex $oldsash($win) 1]
2981 } elseif {$use_ttk} {
2982 set s0 [$win sashpos 0]
2983 set s1 [$win sashpos 1]
2984 } else {
2985 set s0 [$win sash coord 0]
2986 set s1 [$win sash coord 1]
2988 if {$w < 60} {
2989 set sash0 [expr {int($w/2 - 2)}]
2990 set sash1 [expr {int($w*5/6 - 2)}]
2991 } else {
2992 set factor [expr {1.0 * $w / $oldwidth($win)}]
2993 set sash0 [expr {int($factor * [lindex $s0 0])}]
2994 set sash1 [expr {int($factor * [lindex $s1 0])}]
2995 if {$sash0 < 30} {
2996 set sash0 30
2998 if {$sash1 < $sash0 + 20} {
2999 set sash1 [expr {$sash0 + 20}]
3001 if {$sash1 > $w - 10} {
3002 set sash1 [expr {$w - 10}]
3003 if {$sash0 > $sash1 - 20} {
3004 set sash0 [expr {$sash1 - 20}]
3008 if {$use_ttk} {
3009 $win sashpos 0 $sash0
3010 $win sashpos 1 $sash1
3011 } else {
3012 $win sash place 0 $sash0 [lindex $s0 1]
3013 $win sash place 1 $sash1 [lindex $s1 1]
3014 set sash0 [list $sash0 [lindex $s0 1]]
3015 set sash1 [list $sash1 [lindex $s1 1]]
3017 set oldsash($win) [list $sash0 $sash1]
3019 set oldwidth($win) $w
3022 proc resizecdetpanes {win w} {
3023 global oldwidth oldsash use_ttk
3024 if {[info exists oldwidth($win)]} {
3025 if {[info exists oldsash($win)]} {
3026 set s0 $oldsash($win)
3027 } elseif {$use_ttk} {
3028 set s0 [$win sashpos 0]
3029 } else {
3030 set s0 [$win sash coord 0]
3032 if {$w < 60} {
3033 set sash0 [expr {int($w*3/4 - 2)}]
3034 } else {
3035 set factor [expr {1.0 * $w / $oldwidth($win)}]
3036 set sash0 [expr {int($factor * [lindex $s0 0])}]
3037 if {$sash0 < 45} {
3038 set sash0 45
3040 if {$sash0 > $w - 15} {
3041 set sash0 [expr {$w - 15}]
3044 if {$use_ttk} {
3045 $win sashpos 0 $sash0
3046 } else {
3047 $win sash place 0 $sash0 [lindex $s0 1]
3048 set sash0 [list $sash0 [lindex $s0 1]]
3050 set oldsash($win) $sash0
3052 set oldwidth($win) $w
3055 proc allcanvs args {
3056 global canv canv2 canv3
3057 eval $canv $args
3058 eval $canv2 $args
3059 eval $canv3 $args
3062 proc bindall {event action} {
3063 global canv canv2 canv3
3064 bind $canv $event $action
3065 bind $canv2 $event $action
3066 bind $canv3 $event $action
3069 proc about {} {
3070 global bgcolor NS
3071 set w .about
3072 if {[winfo exists $w]} {
3073 raise $w
3074 return
3076 ttk_toplevel $w
3077 wm title $w [mc "About gitk"]
3078 make_transient $w .
3079 message $w.m -text [mc "
3080 Gitk - a commit viewer for git
3082 Copyright \u00a9 2005-2016 Paul Mackerras
3084 Use and redistribute under the terms of the GNU General Public License"] \
3085 -justify center -aspect 400 -border 2 -bg $bgcolor -relief groove
3086 pack $w.m -side top -fill x -padx 2 -pady 2
3087 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3088 pack $w.ok -side bottom
3089 bind $w <Visibility> "focus $w.ok"
3090 bind $w <Key-Escape> "destroy $w"
3091 bind $w <Key-Return> "destroy $w"
3092 tk::PlaceWindow $w widget .
3095 proc keys {} {
3096 global bgcolor NS
3097 set w .keys
3098 if {[winfo exists $w]} {
3099 raise $w
3100 return
3102 if {[tk windowingsystem] eq {aqua}} {
3103 set M1T Cmd
3104 } else {
3105 set M1T Ctrl
3107 ttk_toplevel $w
3108 wm title $w [mc "Gitk key bindings"]
3109 make_transient $w .
3110 message $w.m -text "
3111 [mc "Gitk key bindings:"]
3113 [mc "<%s-Q> Quit" $M1T]
3114 [mc "<%s-W> Close window" $M1T]
3115 [mc "<Home> Move to first commit"]
3116 [mc "<End> Move to last commit"]
3117 [mc "<Up>, p, k Move up one commit"]
3118 [mc "<Down>, n, j Move down one commit"]
3119 [mc "<Left>, z, h Go back in history list"]
3120 [mc "<Right>, x, l Go forward in history list"]
3121 [mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3122 [mc "<PageUp> Move up one page in commit list"]
3123 [mc "<PageDown> Move down one page in commit list"]
3124 [mc "<%s-Home> Scroll to top of commit list" $M1T]
3125 [mc "<%s-End> Scroll to bottom of commit list" $M1T]
3126 [mc "<%s-Up> Scroll commit list up one line" $M1T]
3127 [mc "<%s-Down> Scroll commit list down one line" $M1T]
3128 [mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3129 [mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3130 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3131 [mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3132 [mc "<Delete>, b Scroll diff view up one page"]
3133 [mc "<Backspace> Scroll diff view up one page"]
3134 [mc "<Space> Scroll diff view down one page"]
3135 [mc "u Scroll diff view up 18 lines"]
3136 [mc "d Scroll diff view down 18 lines"]
3137 [mc "<%s-F> Find" $M1T]
3138 [mc "<%s-G> Move to next find hit" $M1T]
3139 [mc "<Return> Move to next find hit"]
3140 [mc "g Go to commit"]
3141 [mc "/ Focus the search box"]
3142 [mc "? Move to previous find hit"]
3143 [mc "f Scroll diff view to next file"]
3144 [mc "<%s-S> Search for next hit in diff view" $M1T]
3145 [mc "<%s-R> Search for previous hit in diff view" $M1T]
3146 [mc "<%s-KP+> Increase font size" $M1T]
3147 [mc "<%s-plus> Increase font size" $M1T]
3148 [mc "<%s-KP-> Decrease font size" $M1T]
3149 [mc "<%s-minus> Decrease font size" $M1T]
3150 [mc "<F5> Update"]
3152 -justify left -bg $bgcolor -border 2 -relief groove
3153 pack $w.m -side top -fill both -padx 2 -pady 2
3154 ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3155 bind $w <Key-Escape> [list destroy $w]
3156 pack $w.ok -side bottom
3157 bind $w <Visibility> "focus $w.ok"
3158 bind $w <Key-Escape> "destroy $w"
3159 bind $w <Key-Return> "destroy $w"
3162 # Procedures for manipulating the file list window at the
3163 # bottom right of the overall window.
3165 proc treeview {w l openlevs} {
3166 global treecontents treediropen treeheight treeparent treeindex
3168 set ix 0
3169 set treeindex() 0
3170 set lev 0
3171 set prefix {}
3172 set prefixend -1
3173 set prefendstack {}
3174 set htstack {}
3175 set ht 0
3176 set treecontents() {}
3177 $w conf -state normal
3178 foreach f $l {
3179 while {[string range $f 0 $prefixend] ne $prefix} {
3180 if {$lev <= $openlevs} {
3181 $w mark set e:$treeindex($prefix) "end -1c"
3182 $w mark gravity e:$treeindex($prefix) left
3184 set treeheight($prefix) $ht
3185 incr ht [lindex $htstack end]
3186 set htstack [lreplace $htstack end end]
3187 set prefixend [lindex $prefendstack end]
3188 set prefendstack [lreplace $prefendstack end end]
3189 set prefix [string range $prefix 0 $prefixend]
3190 incr lev -1
3192 set tail [string range $f [expr {$prefixend+1}] end]
3193 while {[set slash [string first "/" $tail]] >= 0} {
3194 lappend htstack $ht
3195 set ht 0
3196 lappend prefendstack $prefixend
3197 incr prefixend [expr {$slash + 1}]
3198 set d [string range $tail 0 $slash]
3199 lappend treecontents($prefix) $d
3200 set oldprefix $prefix
3201 append prefix $d
3202 set treecontents($prefix) {}
3203 set treeindex($prefix) [incr ix]
3204 set treeparent($prefix) $oldprefix
3205 set tail [string range $tail [expr {$slash+1}] end]
3206 if {$lev <= $openlevs} {
3207 set ht 1
3208 set treediropen($prefix) [expr {$lev < $openlevs}]
3209 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3210 $w mark set d:$ix "end -1c"
3211 $w mark gravity d:$ix left
3212 set str "\n"
3213 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3214 $w insert end $str
3215 $w image create end -align center -image $bm -padx 1 \
3216 -name a:$ix
3217 $w insert end $d [highlight_tag $prefix]
3218 $w mark set s:$ix "end -1c"
3219 $w mark gravity s:$ix left
3221 incr lev
3223 if {$tail ne {}} {
3224 if {$lev <= $openlevs} {
3225 incr ht
3226 set str "\n"
3227 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3228 $w insert end $str
3229 $w insert end $tail [highlight_tag $f]
3231 lappend treecontents($prefix) $tail
3234 while {$htstack ne {}} {
3235 set treeheight($prefix) $ht
3236 incr ht [lindex $htstack end]
3237 set htstack [lreplace $htstack end end]
3238 set prefixend [lindex $prefendstack end]
3239 set prefendstack [lreplace $prefendstack end end]
3240 set prefix [string range $prefix 0 $prefixend]
3242 $w conf -state disabled
3245 proc linetoelt {l} {
3246 global treeheight treecontents
3248 set y 2
3249 set prefix {}
3250 while {1} {
3251 foreach e $treecontents($prefix) {
3252 if {$y == $l} {
3253 return "$prefix$e"
3255 set n 1
3256 if {[string index $e end] eq "/"} {
3257 set n $treeheight($prefix$e)
3258 if {$y + $n > $l} {
3259 append prefix $e
3260 incr y
3261 break
3264 incr y $n
3269 proc highlight_tree {y prefix} {
3270 global treeheight treecontents cflist
3272 foreach e $treecontents($prefix) {
3273 set path $prefix$e
3274 if {[highlight_tag $path] ne {}} {
3275 $cflist tag add bold $y.0 "$y.0 lineend"
3277 incr y
3278 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3279 set y [highlight_tree $y $path]
3282 return $y
3285 proc treeclosedir {w dir} {
3286 global treediropen treeheight treeparent treeindex
3288 set ix $treeindex($dir)
3289 $w conf -state normal
3290 $w delete s:$ix e:$ix
3291 set treediropen($dir) 0
3292 $w image configure a:$ix -image tri-rt
3293 $w conf -state disabled
3294 set n [expr {1 - $treeheight($dir)}]
3295 while {$dir ne {}} {
3296 incr treeheight($dir) $n
3297 set dir $treeparent($dir)
3301 proc treeopendir {w dir} {
3302 global treediropen treeheight treeparent treecontents treeindex
3304 set ix $treeindex($dir)
3305 $w conf -state normal
3306 $w image configure a:$ix -image tri-dn
3307 $w mark set e:$ix s:$ix
3308 $w mark gravity e:$ix right
3309 set lev 0
3310 set str "\n"
3311 set n [llength $treecontents($dir)]
3312 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3313 incr lev
3314 append str "\t"
3315 incr treeheight($x) $n
3317 foreach e $treecontents($dir) {
3318 set de $dir$e
3319 if {[string index $e end] eq "/"} {
3320 set iy $treeindex($de)
3321 $w mark set d:$iy e:$ix
3322 $w mark gravity d:$iy left
3323 $w insert e:$ix $str
3324 set treediropen($de) 0
3325 $w image create e:$ix -align center -image tri-rt -padx 1 \
3326 -name a:$iy
3327 $w insert e:$ix $e [highlight_tag $de]
3328 $w mark set s:$iy e:$ix
3329 $w mark gravity s:$iy left
3330 set treeheight($de) 1
3331 } else {
3332 $w insert e:$ix $str
3333 $w insert e:$ix $e [highlight_tag $de]
3336 $w mark gravity e:$ix right
3337 $w conf -state disabled
3338 set treediropen($dir) 1
3339 set top [lindex [split [$w index @0,0] .] 0]
3340 set ht [$w cget -height]
3341 set l [lindex [split [$w index s:$ix] .] 0]
3342 if {$l < $top} {
3343 $w yview $l.0
3344 } elseif {$l + $n + 1 > $top + $ht} {
3345 set top [expr {$l + $n + 2 - $ht}]
3346 if {$l < $top} {
3347 set top $l
3349 $w yview $top.0
3353 proc treeclick {w x y} {
3354 global treediropen cmitmode ctext cflist cflist_top
3356 if {$cmitmode ne "tree"} return
3357 if {![info exists cflist_top]} return
3358 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3359 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3360 $cflist tag add highlight $l.0 "$l.0 lineend"
3361 set cflist_top $l
3362 if {$l == 1} {
3363 $ctext yview 1.0
3364 return
3366 set e [linetoelt $l]
3367 if {[string index $e end] ne "/"} {
3368 showfile $e
3369 } elseif {$treediropen($e)} {
3370 treeclosedir $w $e
3371 } else {
3372 treeopendir $w $e
3376 proc setfilelist {id} {
3377 global treefilelist cflist jump_to_here
3379 treeview $cflist $treefilelist($id) 0
3380 if {$jump_to_here ne {}} {
3381 set f [lindex $jump_to_here 0]
3382 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3383 showfile $f
3388 image create bitmap tri-rt -background black -foreground blue -data {
3389 #define tri-rt_width 13
3390 #define tri-rt_height 13
3391 static unsigned char tri-rt_bits[] = {
3392 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3393 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3394 0x00, 0x00};
3395 } -maskdata {
3396 #define tri-rt-mask_width 13
3397 #define tri-rt-mask_height 13
3398 static unsigned char tri-rt-mask_bits[] = {
3399 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3400 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3401 0x08, 0x00};
3403 image create bitmap tri-dn -background black -foreground blue -data {
3404 #define tri-dn_width 13
3405 #define tri-dn_height 13
3406 static unsigned char tri-dn_bits[] = {
3407 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3408 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3409 0x00, 0x00};
3410 } -maskdata {
3411 #define tri-dn-mask_width 13
3412 #define tri-dn-mask_height 13
3413 static unsigned char tri-dn-mask_bits[] = {
3414 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3415 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3416 0x00, 0x00};
3419 image create bitmap reficon-T -background black -foreground yellow -data {
3420 #define tagicon_width 13
3421 #define tagicon_height 9
3422 static unsigned char tagicon_bits[] = {
3423 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3424 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3425 } -maskdata {
3426 #define tagicon-mask_width 13
3427 #define tagicon-mask_height 9
3428 static unsigned char tagicon-mask_bits[] = {
3429 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3430 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3432 set rectdata {
3433 #define headicon_width 13
3434 #define headicon_height 9
3435 static unsigned char headicon_bits[] = {
3436 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3437 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3439 set rectmask {
3440 #define headicon-mask_width 13
3441 #define headicon-mask_height 9
3442 static unsigned char headicon-mask_bits[] = {
3443 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3444 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3446 image create bitmap reficon-H -background black -foreground "#00ff00" \
3447 -data $rectdata -maskdata $rectmask
3448 image create bitmap reficon-R -background black -foreground "#ffddaa" \
3449 -data $rectdata -maskdata $rectmask
3450 image create bitmap reficon-o -background black -foreground "#ddddff" \
3451 -data $rectdata -maskdata $rectmask
3453 proc init_flist {first} {
3454 global cflist cflist_top difffilestart
3456 $cflist conf -state normal
3457 $cflist delete 0.0 end
3458 if {$first ne {}} {
3459 $cflist insert end $first
3460 set cflist_top 1
3461 $cflist tag add highlight 1.0 "1.0 lineend"
3462 } else {
3463 unset -nocomplain cflist_top
3465 $cflist conf -state disabled
3466 set difffilestart {}
3469 proc highlight_tag {f} {
3470 global highlight_paths
3472 foreach p $highlight_paths {
3473 if {[string match $p $f]} {
3474 return "bold"
3477 return {}
3480 proc highlight_filelist {} {
3481 global cmitmode cflist
3483 $cflist conf -state normal
3484 if {$cmitmode ne "tree"} {
3485 set end [lindex [split [$cflist index end] .] 0]
3486 for {set l 2} {$l < $end} {incr l} {
3487 set line [$cflist get $l.0 "$l.0 lineend"]
3488 if {[highlight_tag $line] ne {}} {
3489 $cflist tag add bold $l.0 "$l.0 lineend"
3492 } else {
3493 highlight_tree 2 {}
3495 $cflist conf -state disabled
3498 proc unhighlight_filelist {} {
3499 global cflist
3501 $cflist conf -state normal
3502 $cflist tag remove bold 1.0 end
3503 $cflist conf -state disabled
3506 proc add_flist {fl} {
3507 global cflist
3509 $cflist conf -state normal
3510 foreach f $fl {
3511 $cflist insert end "\n"
3512 $cflist insert end $f [highlight_tag $f]
3514 $cflist conf -state disabled
3517 proc sel_flist {w x y} {
3518 global ctext difffilestart cflist cflist_top cmitmode
3520 if {$cmitmode eq "tree"} return
3521 if {![info exists cflist_top]} return
3522 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3523 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3524 $cflist tag add highlight $l.0 "$l.0 lineend"
3525 set cflist_top $l
3526 if {$l == 1} {
3527 $ctext yview 1.0
3528 } else {
3529 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3531 suppress_highlighting_file_for_current_scrollpos
3534 proc pop_flist_menu {w X Y x y} {
3535 global ctext cflist cmitmode flist_menu flist_menu_file
3536 global treediffs diffids
3538 stopfinding
3539 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3540 if {$l <= 1} return
3541 if {$cmitmode eq "tree"} {
3542 set e [linetoelt $l]
3543 if {[string index $e end] eq "/"} return
3544 } else {
3545 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3547 set flist_menu_file $e
3548 set xdiffstate "normal"
3549 if {$cmitmode eq "tree"} {
3550 set xdiffstate "disabled"
3552 # Disable "External diff" item in tree mode
3553 $flist_menu entryconf 2 -state $xdiffstate
3554 tk_popup $flist_menu $X $Y
3557 proc find_ctext_fileinfo {line} {
3558 global ctext_file_names ctext_file_lines
3560 set ok [bsearch $ctext_file_lines $line]
3561 set tline [lindex $ctext_file_lines $ok]
3563 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3564 return {}
3565 } else {
3566 return [list [lindex $ctext_file_names $ok] $tline]
3570 proc pop_diff_menu {w X Y x y} {
3571 global ctext diff_menu flist_menu_file
3572 global diff_menu_txtpos diff_menu_line
3573 global diff_menu_filebase
3575 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3576 set diff_menu_line [lindex $diff_menu_txtpos 0]
3577 # don't pop up the menu on hunk-separator or file-separator lines
3578 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3579 return
3581 stopfinding
3582 set f [find_ctext_fileinfo $diff_menu_line]
3583 if {$f eq {}} return
3584 set flist_menu_file [lindex $f 0]
3585 set diff_menu_filebase [lindex $f 1]
3586 tk_popup $diff_menu $X $Y
3589 proc flist_hl {only} {
3590 global flist_menu_file findstring gdttype
3592 set x [shellquote $flist_menu_file]
3593 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3594 set findstring $x
3595 } else {
3596 append findstring " " $x
3598 set gdttype [mc "touching paths:"]
3601 proc gitknewtmpdir {} {
3602 global diffnum gitktmpdir gitdir env
3604 if {![info exists gitktmpdir]} {
3605 if {[info exists env(GITK_TMPDIR)]} {
3606 set tmpdir $env(GITK_TMPDIR)
3607 } elseif {[info exists env(TMPDIR)]} {
3608 set tmpdir $env(TMPDIR)
3609 } else {
3610 set tmpdir $gitdir
3612 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3613 if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3614 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3616 if {[catch {file mkdir $gitktmpdir} err]} {
3617 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3618 unset gitktmpdir
3619 return {}
3621 set diffnum 0
3623 incr diffnum
3624 set diffdir [file join $gitktmpdir $diffnum]
3625 if {[catch {file mkdir $diffdir} err]} {
3626 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3627 return {}
3629 return $diffdir
3632 proc save_file_from_commit {filename output what} {
3633 global nullfile
3635 if {[catch {exec git show $filename -- > $output} err]} {
3636 if {[string match "fatal: bad revision *" $err]} {
3637 return $nullfile
3639 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3640 return {}
3642 return $output
3645 proc external_diff_get_one_file {diffid filename diffdir} {
3646 global nullid nullid2 nullfile
3647 global worktree
3649 if {$diffid == $nullid} {
3650 set difffile [file join $worktree $filename]
3651 if {[file exists $difffile]} {
3652 return $difffile
3654 return $nullfile
3656 if {$diffid == $nullid2} {
3657 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3658 return [save_file_from_commit :$filename $difffile index]
3660 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3661 return [save_file_from_commit $diffid:$filename $difffile \
3662 "revision $diffid"]
3665 proc external_diff {} {
3666 global nullid nullid2
3667 global flist_menu_file
3668 global diffids
3669 global extdifftool
3671 if {[llength $diffids] == 1} {
3672 # no reference commit given
3673 set diffidto [lindex $diffids 0]
3674 if {$diffidto eq $nullid} {
3675 # diffing working copy with index
3676 set diffidfrom $nullid2
3677 } elseif {$diffidto eq $nullid2} {
3678 # diffing index with HEAD
3679 set diffidfrom "HEAD"
3680 } else {
3681 # use first parent commit
3682 global parentlist selectedline
3683 set diffidfrom [lindex $parentlist $selectedline 0]
3685 } else {
3686 set diffidfrom [lindex $diffids 0]
3687 set diffidto [lindex $diffids 1]
3690 # make sure that several diffs wont collide
3691 set diffdir [gitknewtmpdir]
3692 if {$diffdir eq {}} return
3694 # gather files to diff
3695 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3696 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3698 if {$difffromfile ne {} && $difftofile ne {}} {
3699 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3700 if {[catch {set fl [open |$cmd r]} err]} {
3701 file delete -force $diffdir
3702 error_popup "$extdifftool: [mc "command failed:"] $err"
3703 } else {
3704 fconfigure $fl -blocking 0
3705 filerun $fl [list delete_at_eof $fl $diffdir]
3710 proc find_hunk_blamespec {base line} {
3711 global ctext
3713 # Find and parse the hunk header
3714 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3715 if {$s_lix eq {}} return
3717 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3718 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3719 s_line old_specs osz osz1 new_line nsz]} {
3720 return
3723 # base lines for the parents
3724 set base_lines [list $new_line]
3725 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3726 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3727 old_spec old_line osz]} {
3728 return
3730 lappend base_lines $old_line
3733 # Now scan the lines to determine offset within the hunk
3734 set max_parent [expr {[llength $base_lines]-2}]
3735 set dline 0
3736 set s_lno [lindex [split $s_lix "."] 0]
3738 # Determine if the line is removed
3739 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3740 if {[string match {[-+ ]*} $chunk]} {
3741 set removed_idx [string first "-" $chunk]
3742 # Choose a parent index
3743 if {$removed_idx >= 0} {
3744 set parent $removed_idx
3745 } else {
3746 set unchanged_idx [string first " " $chunk]
3747 if {$unchanged_idx >= 0} {
3748 set parent $unchanged_idx
3749 } else {
3750 # blame the current commit
3751 set parent -1
3754 # then count other lines that belong to it
3755 for {set i $line} {[incr i -1] > $s_lno} {} {
3756 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3757 # Determine if the line is removed
3758 set removed_idx [string first "-" $chunk]
3759 if {$parent >= 0} {
3760 set code [string index $chunk $parent]
3761 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3762 incr dline
3764 } else {
3765 if {$removed_idx < 0} {
3766 incr dline
3770 incr parent
3771 } else {
3772 set parent 0
3775 incr dline [lindex $base_lines $parent]
3776 return [list $parent $dline]
3779 proc external_blame_diff {} {
3780 global currentid cmitmode
3781 global diff_menu_txtpos diff_menu_line
3782 global diff_menu_filebase flist_menu_file
3784 if {$cmitmode eq "tree"} {
3785 set parent_idx 0
3786 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3787 } else {
3788 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3789 if {$hinfo ne {}} {
3790 set parent_idx [lindex $hinfo 0]
3791 set line [lindex $hinfo 1]
3792 } else {
3793 set parent_idx 0
3794 set line 0
3798 external_blame $parent_idx $line
3801 # Find the SHA1 ID of the blob for file $fname in the index
3802 # at stage 0 or 2
3803 proc index_sha1 {fname} {
3804 set f [open [list | git ls-files -s $fname] r]
3805 while {[gets $f line] >= 0} {
3806 set info [lindex [split $line "\t"] 0]
3807 set stage [lindex $info 2]
3808 if {$stage eq "0" || $stage eq "2"} {
3809 close $f
3810 return [lindex $info 1]
3813 close $f
3814 return {}
3817 # Turn an absolute path into one relative to the current directory
3818 proc make_relative {f} {
3819 if {[file pathtype $f] eq "relative"} {
3820 return $f
3822 set elts [file split $f]
3823 set here [file split [pwd]]
3824 set ei 0
3825 set hi 0
3826 set res {}
3827 foreach d $here {
3828 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3829 lappend res ".."
3830 } else {
3831 incr ei
3833 incr hi
3835 set elts [concat $res [lrange $elts $ei end]]
3836 return [eval file join $elts]
3839 proc external_blame {parent_idx {line {}}} {
3840 global flist_menu_file cdup
3841 global nullid nullid2
3842 global parentlist selectedline currentid
3844 if {$parent_idx > 0} {
3845 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3846 } else {
3847 set base_commit $currentid
3850 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3851 error_popup [mc "No such commit"]
3852 return
3855 set cmdline [list git gui blame]
3856 if {$line ne {} && $line > 1} {
3857 lappend cmdline "--line=$line"
3859 set f [file join $cdup $flist_menu_file]
3860 # Unfortunately it seems git gui blame doesn't like
3861 # being given an absolute path...
3862 set f [make_relative $f]
3863 lappend cmdline $base_commit $f
3864 if {[catch {eval exec $cmdline &} err]} {
3865 error_popup "[mc "git gui blame: command failed:"] $err"
3869 proc show_line_source {} {
3870 global cmitmode currentid parents curview blamestuff blameinst
3871 global diff_menu_line diff_menu_filebase flist_menu_file
3872 global nullid nullid2 gitdir cdup
3874 set from_index {}
3875 if {$cmitmode eq "tree"} {
3876 set id $currentid
3877 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3878 } else {
3879 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3880 if {$h eq {}} return
3881 set pi [lindex $h 0]
3882 if {$pi == 0} {
3883 mark_ctext_line $diff_menu_line
3884 return
3886 incr pi -1
3887 if {$currentid eq $nullid} {
3888 if {$pi > 0} {
3889 # must be a merge in progress...
3890 if {[catch {
3891 # get the last line from .git/MERGE_HEAD
3892 set f [open [file join $gitdir MERGE_HEAD] r]
3893 set id [lindex [split [read $f] "\n"] end-1]
3894 close $f
3895 } err]} {
3896 error_popup [mc "Couldn't read merge head: %s" $err]
3897 return
3899 } elseif {$parents($curview,$currentid) eq $nullid2} {
3900 # need to do the blame from the index
3901 if {[catch {
3902 set from_index [index_sha1 $flist_menu_file]
3903 } err]} {
3904 error_popup [mc "Error reading index: %s" $err]
3905 return
3907 } else {
3908 set id $parents($curview,$currentid)
3910 } else {
3911 set id [lindex $parents($curview,$currentid) $pi]
3913 set line [lindex $h 1]
3915 set blameargs {}
3916 if {$from_index ne {}} {
3917 lappend blameargs | git cat-file blob $from_index
3919 lappend blameargs | git blame -p -L$line,+1
3920 if {$from_index ne {}} {
3921 lappend blameargs --contents -
3922 } else {
3923 lappend blameargs $id
3925 lappend blameargs -- [file join $cdup $flist_menu_file]
3926 if {[catch {
3927 set f [open $blameargs r]
3928 } err]} {
3929 error_popup [mc "Couldn't start git blame: %s" $err]
3930 return
3932 nowbusy blaming [mc "Searching"]
3933 fconfigure $f -blocking 0
3934 set i [reg_instance $f]
3935 set blamestuff($i) {}
3936 set blameinst $i
3937 filerun $f [list read_line_source $f $i]
3940 proc stopblaming {} {
3941 global blameinst
3943 if {[info exists blameinst]} {
3944 stop_instance $blameinst
3945 unset blameinst
3946 notbusy blaming
3950 proc read_line_source {fd inst} {
3951 global blamestuff curview commfd blameinst nullid nullid2
3953 while {[gets $fd line] >= 0} {
3954 lappend blamestuff($inst) $line
3956 if {![eof $fd]} {
3957 return 1
3959 unset commfd($inst)
3960 unset blameinst
3961 notbusy blaming
3962 fconfigure $fd -blocking 1
3963 if {[catch {close $fd} err]} {
3964 error_popup [mc "Error running git blame: %s" $err]
3965 return 0
3968 set fname {}
3969 set line [split [lindex $blamestuff($inst) 0] " "]
3970 set id [lindex $line 0]
3971 set lnum [lindex $line 1]
3972 if {[string length $id] == 40 && [string is xdigit $id] &&
3973 [string is digit -strict $lnum]} {
3974 # look for "filename" line
3975 foreach l $blamestuff($inst) {
3976 if {[string match "filename *" $l]} {
3977 set fname [string range $l 9 end]
3978 break
3982 if {$fname ne {}} {
3983 # all looks good, select it
3984 if {$id eq $nullid} {
3985 # blame uses all-zeroes to mean not committed,
3986 # which would mean a change in the index
3987 set id $nullid2
3989 if {[commitinview $id $curview]} {
3990 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3991 } else {
3992 error_popup [mc "That line comes from commit %s, \
3993 which is not in this view" [shortids $id]]
3995 } else {
3996 puts "oops couldn't parse git blame output"
3998 return 0
4001 # delete $dir when we see eof on $f (presumably because the child has exited)
4002 proc delete_at_eof {f dir} {
4003 while {[gets $f line] >= 0} {}
4004 if {[eof $f]} {
4005 if {[catch {close $f} err]} {
4006 error_popup "[mc "External diff viewer failed:"] $err"
4008 file delete -force $dir
4009 return 0
4011 return 1
4014 # Functions for adding and removing shell-type quoting
4016 proc shellquote {str} {
4017 if {![string match "*\['\"\\ \t]*" $str]} {
4018 return $str
4020 if {![string match "*\['\"\\]*" $str]} {
4021 return "\"$str\""
4023 if {![string match "*'*" $str]} {
4024 return "'$str'"
4026 return "\"[string map {\" \\\" \\ \\\\} $str]\""
4029 proc shellarglist {l} {
4030 set str {}
4031 foreach a $l {
4032 if {$str ne {}} {
4033 append str " "
4035 append str [shellquote $a]
4037 return $str
4040 proc shelldequote {str} {
4041 set ret {}
4042 set used -1
4043 while {1} {
4044 incr used
4045 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
4046 append ret [string range $str $used end]
4047 set used [string length $str]
4048 break
4050 set first [lindex $first 0]
4051 set ch [string index $str $first]
4052 if {$first > $used} {
4053 append ret [string range $str $used [expr {$first - 1}]]
4054 set used $first
4056 if {$ch eq " " || $ch eq "\t"} break
4057 incr used
4058 if {$ch eq "'"} {
4059 set first [string first "'" $str $used]
4060 if {$first < 0} {
4061 error "unmatched single-quote"
4063 append ret [string range $str $used [expr {$first - 1}]]
4064 set used $first
4065 continue
4067 if {$ch eq "\\"} {
4068 if {$used >= [string length $str]} {
4069 error "trailing backslash"
4071 append ret [string index $str $used]
4072 continue
4074 # here ch == "\""
4075 while {1} {
4076 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4077 error "unmatched double-quote"
4079 set first [lindex $first 0]
4080 set ch [string index $str $first]
4081 if {$first > $used} {
4082 append ret [string range $str $used [expr {$first - 1}]]
4083 set used $first
4085 if {$ch eq "\""} break
4086 incr used
4087 append ret [string index $str $used]
4088 incr used
4091 return [list $used $ret]
4094 proc shellsplit {str} {
4095 set l {}
4096 while {1} {
4097 set str [string trimleft $str]
4098 if {$str eq {}} break
4099 set dq [shelldequote $str]
4100 set n [lindex $dq 0]
4101 set word [lindex $dq 1]
4102 set str [string range $str $n end]
4103 lappend l $word
4105 return $l
4108 proc set_window_title {} {
4109 global appname curview viewname vrevs
4110 set rev [mc "All files"]
4111 if {$curview ne 0} {
4112 if {$viewname($curview) eq [mc "Command line"]} {
4113 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4114 } else {
4115 set rev $viewname($curview)
4118 wm title . "[reponame]: $rev - $appname"
4121 # Code to implement multiple views
4123 proc newview {ishighlight} {
4124 global nextviewnum newviewname newishighlight
4125 global revtreeargs viewargscmd newviewopts curview
4127 set newishighlight $ishighlight
4128 set top .gitkview
4129 if {[winfo exists $top]} {
4130 raise $top
4131 return
4133 decode_view_opts $nextviewnum $revtreeargs
4134 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4135 set newviewopts($nextviewnum,perm) 0
4136 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4137 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4140 set known_view_options {
4141 {perm b . {} {mc "Remember this view"}}
4142 {reflabel l + {} {mc "References (space separated list):"}}
4143 {refs t15 .. {} {mc "Branches & tags:"}}
4144 {allrefs b *. "--all" {mc "All refs"}}
4145 {branches b . "--branches" {mc "All (local) branches"}}
4146 {tags b . "--tags" {mc "All tags"}}
4147 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4148 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4149 {author t15 .. "--author=*" {mc "Author:"}}
4150 {committer t15 . "--committer=*" {mc "Committer:"}}
4151 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4152 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4153 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4154 {changes_l l + {} {mc "Changes to Files:"}}
4155 {pickaxe_s r0 . {} {mc "Fixed String"}}
4156 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4157 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4158 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4159 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4160 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4161 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4162 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4163 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4164 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4165 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4166 {lright b . "--left-right" {mc "Mark branch sides"}}
4167 {first b . "--first-parent" {mc "Limit to first parent"}}
4168 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4169 {args t50 *. {} {mc "Additional arguments to git log:"}}
4170 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4171 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4174 # Convert $newviewopts($n, ...) into args for git log.
4175 proc encode_view_opts {n} {
4176 global known_view_options newviewopts
4178 set rargs [list]
4179 foreach opt $known_view_options {
4180 set patterns [lindex $opt 3]
4181 if {$patterns eq {}} continue
4182 set pattern [lindex $patterns 0]
4184 if {[lindex $opt 1] eq "b"} {
4185 set val $newviewopts($n,[lindex $opt 0])
4186 if {$val} {
4187 lappend rargs $pattern
4189 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4190 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4191 set val $newviewopts($n,$button_id)
4192 if {$val eq $value} {
4193 lappend rargs $pattern
4195 } else {
4196 set val $newviewopts($n,[lindex $opt 0])
4197 set val [string trim $val]
4198 if {$val ne {}} {
4199 set pfix [string range $pattern 0 end-1]
4200 lappend rargs $pfix$val
4204 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4205 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4208 # Fill $newviewopts($n, ...) based on args for git log.
4209 proc decode_view_opts {n view_args} {
4210 global known_view_options newviewopts
4212 foreach opt $known_view_options {
4213 set id [lindex $opt 0]
4214 if {[lindex $opt 1] eq "b"} {
4215 # Checkboxes
4216 set val 0
4217 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4218 # Radiobuttons
4219 regexp {^(.*_)} $id uselessvar id
4220 set val 0
4221 } else {
4222 # Text fields
4223 set val {}
4225 set newviewopts($n,$id) $val
4227 set oargs [list]
4228 set refargs [list]
4229 foreach arg $view_args {
4230 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4231 && ![info exists found(limit)]} {
4232 set newviewopts($n,limit) $cnt
4233 set found(limit) 1
4234 continue
4236 catch { unset val }
4237 foreach opt $known_view_options {
4238 set id [lindex $opt 0]
4239 if {[info exists found($id)]} continue
4240 foreach pattern [lindex $opt 3] {
4241 if {![string match $pattern $arg]} continue
4242 if {[lindex $opt 1] eq "b"} {
4243 # Check buttons
4244 set val 1
4245 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4246 # Radio buttons
4247 regexp {^(.*_)} $id uselessvar id
4248 set val $num
4249 } else {
4250 # Text input fields
4251 set size [string length $pattern]
4252 set val [string range $arg [expr {$size-1}] end]
4254 set newviewopts($n,$id) $val
4255 set found($id) 1
4256 break
4258 if {[info exists val]} break
4260 if {[info exists val]} continue
4261 if {[regexp {^-} $arg]} {
4262 lappend oargs $arg
4263 } else {
4264 lappend refargs $arg
4267 set newviewopts($n,refs) [shellarglist $refargs]
4268 set newviewopts($n,args) [shellarglist $oargs]
4271 proc edit_or_newview {} {
4272 global curview
4274 if {$curview > 0} {
4275 editview
4276 } else {
4277 newview 0
4281 proc editview {} {
4282 global curview
4283 global viewname viewperm newviewname newviewopts
4284 global viewargs viewargscmd
4286 set top .gitkvedit-$curview
4287 if {[winfo exists $top]} {
4288 raise $top
4289 return
4291 decode_view_opts $curview $viewargs($curview)
4292 set newviewname($curview) $viewname($curview)
4293 set newviewopts($curview,perm) $viewperm($curview)
4294 set newviewopts($curview,cmd) $viewargscmd($curview)
4295 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4298 proc vieweditor {top n title} {
4299 global newviewname newviewopts viewfiles bgcolor
4300 global known_view_options NS
4302 ttk_toplevel $top
4303 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4304 make_transient $top .
4306 # View name
4307 ${NS}::frame $top.nfr
4308 ${NS}::label $top.nl -text [mc "View Name"]
4309 ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4310 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4311 pack $top.nl -in $top.nfr -side left -padx {0 5}
4312 pack $top.name -in $top.nfr -side left -padx {0 25}
4314 # View options
4315 set cframe $top.nfr
4316 set cexpand 0
4317 set cnt 0
4318 foreach opt $known_view_options {
4319 set id [lindex $opt 0]
4320 set type [lindex $opt 1]
4321 set flags [lindex $opt 2]
4322 set title [eval [lindex $opt 4]]
4323 set lxpad 0
4325 if {$flags eq "+" || $flags eq "*"} {
4326 set cframe $top.fr$cnt
4327 incr cnt
4328 ${NS}::frame $cframe
4329 pack $cframe -in $top -fill x -pady 3 -padx 3
4330 set cexpand [expr {$flags eq "*"}]
4331 } elseif {$flags eq ".." || $flags eq "*."} {
4332 set cframe $top.fr$cnt
4333 incr cnt
4334 ${NS}::frame $cframe
4335 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4336 set cexpand [expr {$flags eq "*."}]
4337 } else {
4338 set lxpad 5
4341 if {$type eq "l"} {
4342 ${NS}::label $cframe.l_$id -text $title
4343 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4344 } elseif {$type eq "b"} {
4345 ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4346 pack $cframe.c_$id -in $cframe -side left \
4347 -padx [list $lxpad 0] -expand $cexpand -anchor w
4348 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4349 regexp {^(.*_)} $id uselessvar button_id
4350 ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4351 pack $cframe.c_$id -in $cframe -side left \
4352 -padx [list $lxpad 0] -expand $cexpand -anchor w
4353 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4354 ${NS}::label $cframe.l_$id -text $title
4355 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4356 -textvariable newviewopts($n,$id)
4357 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4358 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4359 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4360 ${NS}::label $cframe.l_$id -text $title
4361 ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4362 -textvariable newviewopts($n,$id)
4363 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4364 pack $cframe.e_$id -in $cframe -side top -fill x
4365 } elseif {$type eq "path"} {
4366 ${NS}::label $top.l -text $title
4367 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4368 text $top.t -width 40 -height 5 -background $bgcolor
4369 if {[info exists viewfiles($n)]} {
4370 foreach f $viewfiles($n) {
4371 $top.t insert end $f
4372 $top.t insert end "\n"
4374 $top.t delete {end - 1c} end
4375 $top.t mark set insert 0.0
4377 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4381 ${NS}::frame $top.buts
4382 ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4383 ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4384 ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4385 bind $top <Control-Return> [list newviewok $top $n]
4386 bind $top <F5> [list newviewok $top $n 1]
4387 bind $top <Escape> [list destroy $top]
4388 grid $top.buts.ok $top.buts.apply $top.buts.can
4389 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4390 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4391 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4392 pack $top.buts -in $top -side top -fill x
4393 focus $top.t
4396 proc doviewmenu {m first cmd op argv} {
4397 set nmenu [$m index end]
4398 for {set i $first} {$i <= $nmenu} {incr i} {
4399 if {[$m entrycget $i -command] eq $cmd} {
4400 eval $m $op $i $argv
4401 break
4406 proc allviewmenus {n op args} {
4407 # global viewhlmenu
4409 doviewmenu .bar.view 5 [list showview $n] $op $args
4410 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4413 proc newviewok {top n {apply 0}} {
4414 global nextviewnum newviewperm newviewname newishighlight
4415 global viewname viewfiles viewperm viewchanged selectedview curview
4416 global viewargs viewargscmd newviewopts viewhlmenu
4418 if {[catch {
4419 set newargs [encode_view_opts $n]
4420 } err]} {
4421 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4422 return
4424 set files {}
4425 foreach f [split [$top.t get 0.0 end] "\n"] {
4426 set ft [string trim $f]
4427 if {$ft ne {}} {
4428 lappend files $ft
4431 if {![info exists viewfiles($n)]} {
4432 # creating a new view
4433 incr nextviewnum
4434 set viewname($n) $newviewname($n)
4435 set viewperm($n) $newviewopts($n,perm)
4436 set viewchanged($n) 1
4437 set viewfiles($n) $files
4438 set viewargs($n) $newargs
4439 set viewargscmd($n) $newviewopts($n,cmd)
4440 addviewmenu $n
4441 if {!$newishighlight} {
4442 run showview $n
4443 } else {
4444 run addvhighlight $n
4446 } else {
4447 # editing an existing view
4448 set viewperm($n) $newviewopts($n,perm)
4449 set viewchanged($n) 1
4450 if {$newviewname($n) ne $viewname($n)} {
4451 set viewname($n) $newviewname($n)
4452 doviewmenu .bar.view 5 [list showview $n] \
4453 entryconf [list -label $viewname($n)]
4454 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4455 # entryconf [list -label $viewname($n) -value $viewname($n)]
4457 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4458 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4459 set viewfiles($n) $files
4460 set viewargs($n) $newargs
4461 set viewargscmd($n) $newviewopts($n,cmd)
4462 if {$curview == $n} {
4463 run reloadcommits
4467 if {$apply} return
4468 catch {destroy $top}
4471 proc delview {} {
4472 global curview viewperm hlview selectedhlview viewchanged
4474 if {$curview == 0} return
4475 if {[info exists hlview] && $hlview == $curview} {
4476 set selectedhlview [mc "None"]
4477 unset hlview
4479 allviewmenus $curview delete
4480 set viewperm($curview) 0
4481 set viewchanged($curview) 1
4482 showview 0
4485 proc addviewmenu {n} {
4486 global viewname viewhlmenu
4488 .bar.view add radiobutton -label $viewname($n) \
4489 -command [list showview $n] -variable selectedview -value $n
4490 #$viewhlmenu add radiobutton -label $viewname($n) \
4491 # -command [list addvhighlight $n] -variable selectedhlview
4494 proc showview {n} {
4495 global curview cached_commitrow ordertok
4496 global displayorder parentlist rowidlist rowisopt rowfinal
4497 global colormap rowtextx nextcolor canvxmax
4498 global numcommits viewcomplete
4499 global selectedline currentid canv canvy0
4500 global treediffs
4501 global pending_select mainheadid
4502 global commitidx
4503 global selectedview
4504 global hlview selectedhlview commitinterest
4506 if {$n == $curview} return
4507 set selid {}
4508 set ymax [lindex [$canv cget -scrollregion] 3]
4509 set span [$canv yview]
4510 set ytop [expr {[lindex $span 0] * $ymax}]
4511 set ybot [expr {[lindex $span 1] * $ymax}]
4512 set yscreen [expr {($ybot - $ytop) / 2}]
4513 if {$selectedline ne {}} {
4514 set selid $currentid
4515 set y [yc $selectedline]
4516 if {$ytop < $y && $y < $ybot} {
4517 set yscreen [expr {$y - $ytop}]
4519 } elseif {[info exists pending_select]} {
4520 set selid $pending_select
4521 unset pending_select
4523 unselectline
4524 normalline
4525 unset -nocomplain treediffs
4526 clear_display
4527 if {[info exists hlview] && $hlview == $n} {
4528 unset hlview
4529 set selectedhlview [mc "None"]
4531 unset -nocomplain commitinterest
4532 unset -nocomplain cached_commitrow
4533 unset -nocomplain ordertok
4535 set curview $n
4536 set selectedview $n
4537 .bar.view entryconf [mca "&Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4538 .bar.view entryconf [mca "&Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4540 run refill_reflist
4541 if {![info exists viewcomplete($n)]} {
4542 getcommits $selid
4543 return
4546 set displayorder {}
4547 set parentlist {}
4548 set rowidlist {}
4549 set rowisopt {}
4550 set rowfinal {}
4551 set numcommits $commitidx($n)
4553 unset -nocomplain colormap
4554 unset -nocomplain rowtextx
4555 set nextcolor 0
4556 set canvxmax [$canv cget -width]
4557 set curview $n
4558 set row 0
4559 setcanvscroll
4560 set yf 0
4561 set row {}
4562 if {$selid ne {} && [commitinview $selid $n]} {
4563 set row [rowofcommit $selid]
4564 # try to get the selected row in the same position on the screen
4565 set ymax [lindex [$canv cget -scrollregion] 3]
4566 set ytop [expr {[yc $row] - $yscreen}]
4567 if {$ytop < 0} {
4568 set ytop 0
4570 set yf [expr {$ytop * 1.0 / $ymax}]
4572 allcanvs yview moveto $yf
4573 drawvisible
4574 if {$row ne {}} {
4575 selectline $row 0
4576 } elseif {!$viewcomplete($n)} {
4577 reset_pending_select $selid
4578 } else {
4579 reset_pending_select {}
4581 if {[commitinview $pending_select $curview]} {
4582 selectline [rowofcommit $pending_select] 1
4583 } else {
4584 set row [first_real_row]
4585 if {$row < $numcommits} {
4586 selectline $row 0
4590 if {!$viewcomplete($n)} {
4591 if {$numcommits == 0} {
4592 show_status [mc "Reading commits..."]
4594 } elseif {$numcommits == 0} {
4595 show_status [mc "No commits selected"]
4597 set_window_title
4600 # Stuff relating to the highlighting facility
4602 proc ishighlighted {id} {
4603 global vhighlights fhighlights nhighlights rhighlights
4605 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4606 return $nhighlights($id)
4608 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4609 return $vhighlights($id)
4611 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4612 return $fhighlights($id)
4614 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4615 return $rhighlights($id)
4617 return 0
4620 proc bolden {id font} {
4621 global canv linehtag currentid boldids need_redisplay markedid
4623 # need_redisplay = 1 means the display is stale and about to be redrawn
4624 if {$need_redisplay} return
4625 lappend boldids $id
4626 $canv itemconf $linehtag($id) -font $font
4627 if {[info exists currentid] && $id eq $currentid} {
4628 $canv delete secsel
4629 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4630 -outline {{}} -tags secsel \
4631 -fill [$canv cget -selectbackground]]
4632 $canv lower $t
4634 if {[info exists markedid] && $id eq $markedid} {
4635 make_idmark $id
4639 proc bolden_name {id font} {
4640 global canv2 linentag currentid boldnameids need_redisplay
4642 if {$need_redisplay} return
4643 lappend boldnameids $id
4644 $canv2 itemconf $linentag($id) -font $font
4645 if {[info exists currentid] && $id eq $currentid} {
4646 $canv2 delete secsel
4647 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4648 -outline {{}} -tags secsel \
4649 -fill [$canv2 cget -selectbackground]]
4650 $canv2 lower $t
4654 proc unbolden {} {
4655 global boldids
4657 set stillbold {}
4658 foreach id $boldids {
4659 if {![ishighlighted $id]} {
4660 bolden $id mainfont
4661 } else {
4662 lappend stillbold $id
4665 set boldids $stillbold
4668 proc addvhighlight {n} {
4669 global hlview viewcomplete curview vhl_done commitidx
4671 if {[info exists hlview]} {
4672 delvhighlight
4674 set hlview $n
4675 if {$n != $curview && ![info exists viewcomplete($n)]} {
4676 start_rev_list $n
4678 set vhl_done $commitidx($hlview)
4679 if {$vhl_done > 0} {
4680 drawvisible
4684 proc delvhighlight {} {
4685 global hlview vhighlights
4687 if {![info exists hlview]} return
4688 unset hlview
4689 unset -nocomplain vhighlights
4690 unbolden
4693 proc vhighlightmore {} {
4694 global hlview vhl_done commitidx vhighlights curview
4696 set max $commitidx($hlview)
4697 set vr [visiblerows]
4698 set r0 [lindex $vr 0]
4699 set r1 [lindex $vr 1]
4700 for {set i $vhl_done} {$i < $max} {incr i} {
4701 set id [commitonrow $i $hlview]
4702 if {[commitinview $id $curview]} {
4703 set row [rowofcommit $id]
4704 if {$r0 <= $row && $row <= $r1} {
4705 if {![highlighted $row]} {
4706 bolden $id mainfontbold
4708 set vhighlights($id) 1
4712 set vhl_done $max
4713 return 0
4716 proc askvhighlight {row id} {
4717 global hlview vhighlights iddrawn
4719 if {[commitinview $id $hlview]} {
4720 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4721 bolden $id mainfontbold
4723 set vhighlights($id) 1
4724 } else {
4725 set vhighlights($id) 0
4729 proc hfiles_change {} {
4730 global highlight_files filehighlight fhighlights fh_serial
4731 global highlight_paths
4733 if {[info exists filehighlight]} {
4734 # delete previous highlights
4735 catch {close $filehighlight}
4736 unset filehighlight
4737 unset -nocomplain fhighlights
4738 unbolden
4739 unhighlight_filelist
4741 set highlight_paths {}
4742 after cancel do_file_hl $fh_serial
4743 incr fh_serial
4744 if {$highlight_files ne {}} {
4745 after 300 do_file_hl $fh_serial
4749 proc gdttype_change {name ix op} {
4750 global gdttype highlight_files findstring findpattern
4752 stopfinding
4753 if {$findstring ne {}} {
4754 if {$gdttype eq [mc "containing:"]} {
4755 if {$highlight_files ne {}} {
4756 set highlight_files {}
4757 hfiles_change
4759 findcom_change
4760 } else {
4761 if {$findpattern ne {}} {
4762 set findpattern {}
4763 findcom_change
4765 set highlight_files $findstring
4766 hfiles_change
4768 drawvisible
4770 # enable/disable findtype/findloc menus too
4773 proc find_change {name ix op} {
4774 global gdttype findstring highlight_files
4776 stopfinding
4777 if {$gdttype eq [mc "containing:"]} {
4778 findcom_change
4779 } else {
4780 if {$highlight_files ne $findstring} {
4781 set highlight_files $findstring
4782 hfiles_change
4785 drawvisible
4788 proc findcom_change args {
4789 global nhighlights boldnameids
4790 global findpattern findtype findstring gdttype
4792 stopfinding
4793 # delete previous highlights, if any
4794 foreach id $boldnameids {
4795 bolden_name $id mainfont
4797 set boldnameids {}
4798 unset -nocomplain nhighlights
4799 unbolden
4800 unmarkmatches
4801 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4802 set findpattern {}
4803 } elseif {$findtype eq [mc "Regexp"]} {
4804 set findpattern $findstring
4805 } else {
4806 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4807 $findstring]
4808 set findpattern "*$e*"
4812 proc makepatterns {l} {
4813 set ret {}
4814 foreach e $l {
4815 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4816 if {[string index $ee end] eq "/"} {
4817 lappend ret "$ee*"
4818 } else {
4819 lappend ret $ee
4820 lappend ret "$ee/*"
4823 return $ret
4826 proc do_file_hl {serial} {
4827 global highlight_files filehighlight highlight_paths gdttype fhl_list
4828 global cdup findtype
4830 if {$gdttype eq [mc "touching paths:"]} {
4831 # If "exact" match then convert backslashes to forward slashes.
4832 # Most useful to support Windows-flavoured file paths.
4833 if {$findtype eq [mc "Exact"]} {
4834 set highlight_files [string map {"\\" "/"} $highlight_files]
4836 if {[catch {set paths [shellsplit $highlight_files]}]} return
4837 set highlight_paths [makepatterns $paths]
4838 highlight_filelist
4839 set relative_paths {}
4840 foreach path $paths {
4841 lappend relative_paths [file join $cdup $path]
4843 set gdtargs [concat -- $relative_paths]
4844 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4845 set gdtargs [list "-S$highlight_files"]
4846 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4847 set gdtargs [list "-G$highlight_files"]
4848 } else {
4849 # must be "containing:", i.e. we're searching commit info
4850 return
4852 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4853 set filehighlight [open $cmd r+]
4854 fconfigure $filehighlight -blocking 0
4855 filerun $filehighlight readfhighlight
4856 set fhl_list {}
4857 drawvisible
4858 flushhighlights
4861 proc flushhighlights {} {
4862 global filehighlight fhl_list
4864 if {[info exists filehighlight]} {
4865 lappend fhl_list {}
4866 puts $filehighlight ""
4867 flush $filehighlight
4871 proc askfilehighlight {row id} {
4872 global filehighlight fhighlights fhl_list
4874 lappend fhl_list $id
4875 set fhighlights($id) -1
4876 puts $filehighlight $id
4879 proc readfhighlight {} {
4880 global filehighlight fhighlights curview iddrawn
4881 global fhl_list find_dirn
4883 if {![info exists filehighlight]} {
4884 return 0
4886 set nr 0
4887 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4888 set line [string trim $line]
4889 set i [lsearch -exact $fhl_list $line]
4890 if {$i < 0} continue
4891 for {set j 0} {$j < $i} {incr j} {
4892 set id [lindex $fhl_list $j]
4893 set fhighlights($id) 0
4895 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4896 if {$line eq {}} continue
4897 if {![commitinview $line $curview]} continue
4898 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4899 bolden $line mainfontbold
4901 set fhighlights($line) 1
4903 if {[eof $filehighlight]} {
4904 # strange...
4905 puts "oops, git diff-tree died"
4906 catch {close $filehighlight}
4907 unset filehighlight
4908 return 0
4910 if {[info exists find_dirn]} {
4911 run findmore
4913 return 1
4916 proc doesmatch {f} {
4917 global findtype findpattern
4919 if {$findtype eq [mc "Regexp"]} {
4920 return [regexp $findpattern $f]
4921 } elseif {$findtype eq [mc "IgnCase"]} {
4922 return [string match -nocase $findpattern $f]
4923 } else {
4924 return [string match $findpattern $f]
4928 proc askfindhighlight {row id} {
4929 global nhighlights commitinfo iddrawn
4930 global findloc
4931 global markingmatches
4933 if {![info exists commitinfo($id)]} {
4934 getcommit $id
4936 set info $commitinfo($id)
4937 set isbold 0
4938 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4939 foreach f $info ty $fldtypes {
4940 if {$ty eq ""} continue
4941 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4942 [doesmatch $f]} {
4943 if {$ty eq [mc "Author"]} {
4944 set isbold 2
4945 break
4947 set isbold 1
4950 if {$isbold && [info exists iddrawn($id)]} {
4951 if {![ishighlighted $id]} {
4952 bolden $id mainfontbold
4953 if {$isbold > 1} {
4954 bolden_name $id mainfontbold
4957 if {$markingmatches} {
4958 markrowmatches $row $id
4961 set nhighlights($id) $isbold
4964 proc markrowmatches {row id} {
4965 global canv canv2 linehtag linentag commitinfo findloc
4967 set headline [lindex $commitinfo($id) 0]
4968 set author [lindex $commitinfo($id) 1]
4969 $canv delete match$row
4970 $canv2 delete match$row
4971 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4972 set m [findmatches $headline]
4973 if {$m ne {}} {
4974 markmatches $canv $row $headline $linehtag($id) $m \
4975 [$canv itemcget $linehtag($id) -font] $row
4978 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4979 set m [findmatches $author]
4980 if {$m ne {}} {
4981 markmatches $canv2 $row $author $linentag($id) $m \
4982 [$canv2 itemcget $linentag($id) -font] $row
4987 proc vrel_change {name ix op} {
4988 global highlight_related
4990 rhighlight_none
4991 if {$highlight_related ne [mc "None"]} {
4992 run drawvisible
4996 # prepare for testing whether commits are descendents or ancestors of a
4997 proc rhighlight_sel {a} {
4998 global descendent desc_todo ancestor anc_todo
4999 global highlight_related
5001 unset -nocomplain descendent
5002 set desc_todo [list $a]
5003 unset -nocomplain ancestor
5004 set anc_todo [list $a]
5005 if {$highlight_related ne [mc "None"]} {
5006 rhighlight_none
5007 run drawvisible
5011 proc rhighlight_none {} {
5012 global rhighlights
5014 unset -nocomplain rhighlights
5015 unbolden
5018 proc is_descendent {a} {
5019 global curview children descendent desc_todo
5021 set v $curview
5022 set la [rowofcommit $a]
5023 set todo $desc_todo
5024 set leftover {}
5025 set done 0
5026 for {set i 0} {$i < [llength $todo]} {incr i} {
5027 set do [lindex $todo $i]
5028 if {[rowofcommit $do] < $la} {
5029 lappend leftover $do
5030 continue
5032 foreach nk $children($v,$do) {
5033 if {![info exists descendent($nk)]} {
5034 set descendent($nk) 1
5035 lappend todo $nk
5036 if {$nk eq $a} {
5037 set done 1
5041 if {$done} {
5042 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5043 return
5046 set descendent($a) 0
5047 set desc_todo $leftover
5050 proc is_ancestor {a} {
5051 global curview parents ancestor anc_todo
5053 set v $curview
5054 set la [rowofcommit $a]
5055 set todo $anc_todo
5056 set leftover {}
5057 set done 0
5058 for {set i 0} {$i < [llength $todo]} {incr i} {
5059 set do [lindex $todo $i]
5060 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
5061 lappend leftover $do
5062 continue
5064 foreach np $parents($v,$do) {
5065 if {![info exists ancestor($np)]} {
5066 set ancestor($np) 1
5067 lappend todo $np
5068 if {$np eq $a} {
5069 set done 1
5073 if {$done} {
5074 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5075 return
5078 set ancestor($a) 0
5079 set anc_todo $leftover
5082 proc askrelhighlight {row id} {
5083 global descendent highlight_related iddrawn rhighlights
5084 global selectedline ancestor
5086 if {$selectedline eq {}} return
5087 set isbold 0
5088 if {$highlight_related eq [mc "Descendant"] ||
5089 $highlight_related eq [mc "Not descendant"]} {
5090 if {![info exists descendent($id)]} {
5091 is_descendent $id
5093 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5094 set isbold 1
5096 } elseif {$highlight_related eq [mc "Ancestor"] ||
5097 $highlight_related eq [mc "Not ancestor"]} {
5098 if {![info exists ancestor($id)]} {
5099 is_ancestor $id
5101 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5102 set isbold 1
5105 if {[info exists iddrawn($id)]} {
5106 if {$isbold && ![ishighlighted $id]} {
5107 bolden $id mainfontbold
5110 set rhighlights($id) $isbold
5113 # Graph layout functions
5115 proc shortids {ids} {
5116 set res {}
5117 foreach id $ids {
5118 if {[llength $id] > 1} {
5119 lappend res [shortids $id]
5120 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5121 lappend res [string range $id 0 7]
5122 } else {
5123 lappend res $id
5126 return $res
5129 proc ntimes {n o} {
5130 set ret {}
5131 set o [list $o]
5132 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5133 if {($n & $mask) != 0} {
5134 set ret [concat $ret $o]
5136 set o [concat $o $o]
5138 return $ret
5141 proc ordertoken {id} {
5142 global ordertok curview varcid varcstart varctok curview parents children
5143 global nullid nullid2
5145 if {[info exists ordertok($id)]} {
5146 return $ordertok($id)
5148 set origid $id
5149 set todo {}
5150 while {1} {
5151 if {[info exists varcid($curview,$id)]} {
5152 set a $varcid($curview,$id)
5153 set p [lindex $varcstart($curview) $a]
5154 } else {
5155 set p [lindex $children($curview,$id) 0]
5157 if {[info exists ordertok($p)]} {
5158 set tok $ordertok($p)
5159 break
5161 set id [first_real_child $curview,$p]
5162 if {$id eq {}} {
5163 # it's a root
5164 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5165 break
5167 if {[llength $parents($curview,$id)] == 1} {
5168 lappend todo [list $p {}]
5169 } else {
5170 set j [lsearch -exact $parents($curview,$id) $p]
5171 if {$j < 0} {
5172 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5174 lappend todo [list $p [strrep $j]]
5177 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5178 set p [lindex $todo $i 0]
5179 append tok [lindex $todo $i 1]
5180 set ordertok($p) $tok
5182 set ordertok($origid) $tok
5183 return $tok
5186 # Work out where id should go in idlist so that order-token
5187 # values increase from left to right
5188 proc idcol {idlist id {i 0}} {
5189 set t [ordertoken $id]
5190 if {$i < 0} {
5191 set i 0
5193 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5194 if {$i > [llength $idlist]} {
5195 set i [llength $idlist]
5197 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5198 incr i
5199 } else {
5200 if {$t > [ordertoken [lindex $idlist $i]]} {
5201 while {[incr i] < [llength $idlist] &&
5202 $t >= [ordertoken [lindex $idlist $i]]} {}
5205 return $i
5208 proc initlayout {} {
5209 global rowidlist rowisopt rowfinal displayorder parentlist
5210 global numcommits canvxmax canv
5211 global nextcolor
5212 global colormap rowtextx
5214 set numcommits 0
5215 set displayorder {}
5216 set parentlist {}
5217 set nextcolor 0
5218 set rowidlist {}
5219 set rowisopt {}
5220 set rowfinal {}
5221 set canvxmax [$canv cget -width]
5222 unset -nocomplain colormap
5223 unset -nocomplain rowtextx
5224 setcanvscroll
5227 proc setcanvscroll {} {
5228 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5229 global lastscrollset lastscrollrows
5231 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5232 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5233 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5234 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5235 set lastscrollset [clock clicks -milliseconds]
5236 set lastscrollrows $numcommits
5239 proc visiblerows {} {
5240 global canv numcommits linespc
5242 set ymax [lindex [$canv cget -scrollregion] 3]
5243 if {$ymax eq {} || $ymax == 0} return
5244 set f [$canv yview]
5245 set y0 [expr {int([lindex $f 0] * $ymax)}]
5246 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5247 if {$r0 < 0} {
5248 set r0 0
5250 set y1 [expr {int([lindex $f 1] * $ymax)}]
5251 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5252 if {$r1 >= $numcommits} {
5253 set r1 [expr {$numcommits - 1}]
5255 return [list $r0 $r1]
5258 proc layoutmore {} {
5259 global commitidx viewcomplete curview
5260 global numcommits pending_select curview
5261 global lastscrollset lastscrollrows
5263 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5264 [clock clicks -milliseconds] - $lastscrollset > 500} {
5265 setcanvscroll
5267 if {[info exists pending_select] &&
5268 [commitinview $pending_select $curview]} {
5269 update
5270 selectline [rowofcommit $pending_select] 1
5272 drawvisible
5275 # With path limiting, we mightn't get the actual HEAD commit,
5276 # so ask git rev-list what is the first ancestor of HEAD that
5277 # touches a file in the path limit.
5278 proc get_viewmainhead {view} {
5279 global viewmainheadid vfilelimit viewinstances mainheadid
5281 catch {
5282 set rfd [open [concat | git rev-list -1 $mainheadid \
5283 -- $vfilelimit($view)] r]
5284 set j [reg_instance $rfd]
5285 lappend viewinstances($view) $j
5286 fconfigure $rfd -blocking 0
5287 filerun $rfd [list getviewhead $rfd $j $view]
5288 set viewmainheadid($curview) {}
5292 # git rev-list should give us just 1 line to use as viewmainheadid($view)
5293 proc getviewhead {fd inst view} {
5294 global viewmainheadid commfd curview viewinstances showlocalchanges
5296 set id {}
5297 if {[gets $fd line] < 0} {
5298 if {![eof $fd]} {
5299 return 1
5301 } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5302 set id $line
5304 set viewmainheadid($view) $id
5305 close $fd
5306 unset commfd($inst)
5307 set i [lsearch -exact $viewinstances($view) $inst]
5308 if {$i >= 0} {
5309 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5311 if {$showlocalchanges && $id ne {} && $view == $curview} {
5312 doshowlocalchanges
5314 return 0
5317 proc doshowlocalchanges {} {
5318 global curview viewmainheadid
5320 if {$viewmainheadid($curview) eq {}} return
5321 if {[commitinview $viewmainheadid($curview) $curview]} {
5322 dodiffindex
5323 } else {
5324 interestedin $viewmainheadid($curview) dodiffindex
5328 proc dohidelocalchanges {} {
5329 global nullid nullid2 lserial curview
5331 if {[commitinview $nullid $curview]} {
5332 removefakerow $nullid
5334 if {[commitinview $nullid2 $curview]} {
5335 removefakerow $nullid2
5337 incr lserial
5340 # spawn off a process to do git diff-index --cached HEAD
5341 proc dodiffindex {} {
5342 global lserial showlocalchanges vfilelimit curview
5343 global hasworktree git_version
5345 if {!$showlocalchanges || !$hasworktree} return
5346 incr lserial
5347 if {[package vcompare $git_version "1.7.2"] >= 0} {
5348 set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5349 } else {
5350 set cmd "|git diff-index --cached HEAD"
5352 if {$vfilelimit($curview) ne {}} {
5353 set cmd [concat $cmd -- $vfilelimit($curview)]
5355 set fd [open $cmd r]
5356 fconfigure $fd -blocking 0
5357 set i [reg_instance $fd]
5358 filerun $fd [list readdiffindex $fd $lserial $i]
5361 proc readdiffindex {fd serial inst} {
5362 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5363 global vfilelimit
5365 set isdiff 1
5366 if {[gets $fd line] < 0} {
5367 if {![eof $fd]} {
5368 return 1
5370 set isdiff 0
5372 # we only need to see one line and we don't really care what it says...
5373 stop_instance $inst
5375 if {$serial != $lserial} {
5376 return 0
5379 # now see if there are any local changes not checked in to the index
5380 set cmd "|git diff-files"
5381 if {$vfilelimit($curview) ne {}} {
5382 set cmd [concat $cmd -- $vfilelimit($curview)]
5384 set fd [open $cmd r]
5385 fconfigure $fd -blocking 0
5386 set i [reg_instance $fd]
5387 filerun $fd [list readdifffiles $fd $serial $i]
5389 if {$isdiff && ![commitinview $nullid2 $curview]} {
5390 # add the line for the changes in the index to the graph
5391 set hl [mc "Local changes checked in to index but not committed"]
5392 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5393 set commitdata($nullid2) "\n $hl\n"
5394 if {[commitinview $nullid $curview]} {
5395 removefakerow $nullid
5397 insertfakerow $nullid2 $viewmainheadid($curview)
5398 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5399 if {[commitinview $nullid $curview]} {
5400 removefakerow $nullid
5402 removefakerow $nullid2
5404 return 0
5407 proc readdifffiles {fd serial inst} {
5408 global viewmainheadid nullid nullid2 curview
5409 global commitinfo commitdata lserial
5411 set isdiff 1
5412 if {[gets $fd line] < 0} {
5413 if {![eof $fd]} {
5414 return 1
5416 set isdiff 0
5418 # we only need to see one line and we don't really care what it says...
5419 stop_instance $inst
5421 if {$serial != $lserial} {
5422 return 0
5425 if {$isdiff && ![commitinview $nullid $curview]} {
5426 # add the line for the local diff to the graph
5427 set hl [mc "Local uncommitted changes, not checked in to index"]
5428 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5429 set commitdata($nullid) "\n $hl\n"
5430 if {[commitinview $nullid2 $curview]} {
5431 set p $nullid2
5432 } else {
5433 set p $viewmainheadid($curview)
5435 insertfakerow $nullid $p
5436 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5437 removefakerow $nullid
5439 return 0
5442 proc nextuse {id row} {
5443 global curview children
5445 if {[info exists children($curview,$id)]} {
5446 foreach kid $children($curview,$id) {
5447 if {![commitinview $kid $curview]} {
5448 return -1
5450 if {[rowofcommit $kid] > $row} {
5451 return [rowofcommit $kid]
5455 if {[commitinview $id $curview]} {
5456 return [rowofcommit $id]
5458 return -1
5461 proc prevuse {id row} {
5462 global curview children
5464 set ret -1
5465 if {[info exists children($curview,$id)]} {
5466 foreach kid $children($curview,$id) {
5467 if {![commitinview $kid $curview]} break
5468 if {[rowofcommit $kid] < $row} {
5469 set ret [rowofcommit $kid]
5473 return $ret
5476 proc make_idlist {row} {
5477 global displayorder parentlist uparrowlen downarrowlen mingaplen
5478 global commitidx curview children
5480 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5481 if {$r < 0} {
5482 set r 0
5484 set ra [expr {$row - $downarrowlen}]
5485 if {$ra < 0} {
5486 set ra 0
5488 set rb [expr {$row + $uparrowlen}]
5489 if {$rb > $commitidx($curview)} {
5490 set rb $commitidx($curview)
5492 make_disporder $r [expr {$rb + 1}]
5493 set ids {}
5494 for {} {$r < $ra} {incr r} {
5495 set nextid [lindex $displayorder [expr {$r + 1}]]
5496 foreach p [lindex $parentlist $r] {
5497 if {$p eq $nextid} continue
5498 set rn [nextuse $p $r]
5499 if {$rn >= $row &&
5500 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5501 lappend ids [list [ordertoken $p] $p]
5505 for {} {$r < $row} {incr r} {
5506 set nextid [lindex $displayorder [expr {$r + 1}]]
5507 foreach p [lindex $parentlist $r] {
5508 if {$p eq $nextid} continue
5509 set rn [nextuse $p $r]
5510 if {$rn < 0 || $rn >= $row} {
5511 lappend ids [list [ordertoken $p] $p]
5515 set id [lindex $displayorder $row]
5516 lappend ids [list [ordertoken $id] $id]
5517 while {$r < $rb} {
5518 foreach p [lindex $parentlist $r] {
5519 set firstkid [lindex $children($curview,$p) 0]
5520 if {[rowofcommit $firstkid] < $row} {
5521 lappend ids [list [ordertoken $p] $p]
5524 incr r
5525 set id [lindex $displayorder $r]
5526 if {$id ne {}} {
5527 set firstkid [lindex $children($curview,$id) 0]
5528 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5529 lappend ids [list [ordertoken $id] $id]
5533 set idlist {}
5534 foreach idx [lsort -unique $ids] {
5535 lappend idlist [lindex $idx 1]
5537 return $idlist
5540 proc rowsequal {a b} {
5541 while {[set i [lsearch -exact $a {}]] >= 0} {
5542 set a [lreplace $a $i $i]
5544 while {[set i [lsearch -exact $b {}]] >= 0} {
5545 set b [lreplace $b $i $i]
5547 return [expr {$a eq $b}]
5550 proc makeupline {id row rend col} {
5551 global rowidlist uparrowlen downarrowlen mingaplen
5553 for {set r $rend} {1} {set r $rstart} {
5554 set rstart [prevuse $id $r]
5555 if {$rstart < 0} return
5556 if {$rstart < $row} break
5558 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5559 set rstart [expr {$rend - $uparrowlen - 1}]
5561 for {set r $rstart} {[incr r] <= $row} {} {
5562 set idlist [lindex $rowidlist $r]
5563 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5564 set col [idcol $idlist $id $col]
5565 lset rowidlist $r [linsert $idlist $col $id]
5566 changedrow $r
5571 proc layoutrows {row endrow} {
5572 global rowidlist rowisopt rowfinal displayorder
5573 global uparrowlen downarrowlen maxwidth mingaplen
5574 global children parentlist
5575 global commitidx viewcomplete curview
5577 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5578 set idlist {}
5579 if {$row > 0} {
5580 set rm1 [expr {$row - 1}]
5581 foreach id [lindex $rowidlist $rm1] {
5582 if {$id ne {}} {
5583 lappend idlist $id
5586 set final [lindex $rowfinal $rm1]
5588 for {} {$row < $endrow} {incr row} {
5589 set rm1 [expr {$row - 1}]
5590 if {$rm1 < 0 || $idlist eq {}} {
5591 set idlist [make_idlist $row]
5592 set final 1
5593 } else {
5594 set id [lindex $displayorder $rm1]
5595 set col [lsearch -exact $idlist $id]
5596 set idlist [lreplace $idlist $col $col]
5597 foreach p [lindex $parentlist $rm1] {
5598 if {[lsearch -exact $idlist $p] < 0} {
5599 set col [idcol $idlist $p $col]
5600 set idlist [linsert $idlist $col $p]
5601 # if not the first child, we have to insert a line going up
5602 if {$id ne [lindex $children($curview,$p) 0]} {
5603 makeupline $p $rm1 $row $col
5607 set id [lindex $displayorder $row]
5608 if {$row > $downarrowlen} {
5609 set termrow [expr {$row - $downarrowlen - 1}]
5610 foreach p [lindex $parentlist $termrow] {
5611 set i [lsearch -exact $idlist $p]
5612 if {$i < 0} continue
5613 set nr [nextuse $p $termrow]
5614 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5615 set idlist [lreplace $idlist $i $i]
5619 set col [lsearch -exact $idlist $id]
5620 if {$col < 0} {
5621 set col [idcol $idlist $id]
5622 set idlist [linsert $idlist $col $id]
5623 if {$children($curview,$id) ne {}} {
5624 makeupline $id $rm1 $row $col
5627 set r [expr {$row + $uparrowlen - 1}]
5628 if {$r < $commitidx($curview)} {
5629 set x $col
5630 foreach p [lindex $parentlist $r] {
5631 if {[lsearch -exact $idlist $p] >= 0} continue
5632 set fk [lindex $children($curview,$p) 0]
5633 if {[rowofcommit $fk] < $row} {
5634 set x [idcol $idlist $p $x]
5635 set idlist [linsert $idlist $x $p]
5638 if {[incr r] < $commitidx($curview)} {
5639 set p [lindex $displayorder $r]
5640 if {[lsearch -exact $idlist $p] < 0} {
5641 set fk [lindex $children($curview,$p) 0]
5642 if {$fk ne {} && [rowofcommit $fk] < $row} {
5643 set x [idcol $idlist $p $x]
5644 set idlist [linsert $idlist $x $p]
5650 if {$final && !$viewcomplete($curview) &&
5651 $row + $uparrowlen + $mingaplen + $downarrowlen
5652 >= $commitidx($curview)} {
5653 set final 0
5655 set l [llength $rowidlist]
5656 if {$row == $l} {
5657 lappend rowidlist $idlist
5658 lappend rowisopt 0
5659 lappend rowfinal $final
5660 } elseif {$row < $l} {
5661 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5662 lset rowidlist $row $idlist
5663 changedrow $row
5665 lset rowfinal $row $final
5666 } else {
5667 set pad [ntimes [expr {$row - $l}] {}]
5668 set rowidlist [concat $rowidlist $pad]
5669 lappend rowidlist $idlist
5670 set rowfinal [concat $rowfinal $pad]
5671 lappend rowfinal $final
5672 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5675 return $row
5678 proc changedrow {row} {
5679 global displayorder iddrawn rowisopt need_redisplay
5681 set l [llength $rowisopt]
5682 if {$row < $l} {
5683 lset rowisopt $row 0
5684 if {$row + 1 < $l} {
5685 lset rowisopt [expr {$row + 1}] 0
5686 if {$row + 2 < $l} {
5687 lset rowisopt [expr {$row + 2}] 0
5691 set id [lindex $displayorder $row]
5692 if {[info exists iddrawn($id)]} {
5693 set need_redisplay 1
5697 proc insert_pad {row col npad} {
5698 global rowidlist
5700 set pad [ntimes $npad {}]
5701 set idlist [lindex $rowidlist $row]
5702 set bef [lrange $idlist 0 [expr {$col - 1}]]
5703 set aft [lrange $idlist $col end]
5704 set i [lsearch -exact $aft {}]
5705 if {$i > 0} {
5706 set aft [lreplace $aft $i $i]
5708 lset rowidlist $row [concat $bef $pad $aft]
5709 changedrow $row
5712 proc optimize_rows {row col endrow} {
5713 global rowidlist rowisopt displayorder curview children
5715 if {$row < 1} {
5716 set row 1
5718 for {} {$row < $endrow} {incr row; set col 0} {
5719 if {[lindex $rowisopt $row]} continue
5720 set haspad 0
5721 set y0 [expr {$row - 1}]
5722 set ym [expr {$row - 2}]
5723 set idlist [lindex $rowidlist $row]
5724 set previdlist [lindex $rowidlist $y0]
5725 if {$idlist eq {} || $previdlist eq {}} continue
5726 if {$ym >= 0} {
5727 set pprevidlist [lindex $rowidlist $ym]
5728 if {$pprevidlist eq {}} continue
5729 } else {
5730 set pprevidlist {}
5732 set x0 -1
5733 set xm -1
5734 for {} {$col < [llength $idlist]} {incr col} {
5735 set id [lindex $idlist $col]
5736 if {[lindex $previdlist $col] eq $id} continue
5737 if {$id eq {}} {
5738 set haspad 1
5739 continue
5741 set x0 [lsearch -exact $previdlist $id]
5742 if {$x0 < 0} continue
5743 set z [expr {$x0 - $col}]
5744 set isarrow 0
5745 set z0 {}
5746 if {$ym >= 0} {
5747 set xm [lsearch -exact $pprevidlist $id]
5748 if {$xm >= 0} {
5749 set z0 [expr {$xm - $x0}]
5752 if {$z0 eq {}} {
5753 # if row y0 is the first child of $id then it's not an arrow
5754 if {[lindex $children($curview,$id) 0] ne
5755 [lindex $displayorder $y0]} {
5756 set isarrow 1
5759 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5760 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5761 set isarrow 1
5763 # Looking at lines from this row to the previous row,
5764 # make them go straight up if they end in an arrow on
5765 # the previous row; otherwise make them go straight up
5766 # or at 45 degrees.
5767 if {$z < -1 || ($z < 0 && $isarrow)} {
5768 # Line currently goes left too much;
5769 # insert pads in the previous row, then optimize it
5770 set npad [expr {-1 - $z + $isarrow}]
5771 insert_pad $y0 $x0 $npad
5772 if {$y0 > 0} {
5773 optimize_rows $y0 $x0 $row
5775 set previdlist [lindex $rowidlist $y0]
5776 set x0 [lsearch -exact $previdlist $id]
5777 set z [expr {$x0 - $col}]
5778 if {$z0 ne {}} {
5779 set pprevidlist [lindex $rowidlist $ym]
5780 set xm [lsearch -exact $pprevidlist $id]
5781 set z0 [expr {$xm - $x0}]
5783 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5784 # Line currently goes right too much;
5785 # insert pads in this line
5786 set npad [expr {$z - 1 + $isarrow}]
5787 insert_pad $row $col $npad
5788 set idlist [lindex $rowidlist $row]
5789 incr col $npad
5790 set z [expr {$x0 - $col}]
5791 set haspad 1
5793 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5794 # this line links to its first child on row $row-2
5795 set id [lindex $displayorder $ym]
5796 set xc [lsearch -exact $pprevidlist $id]
5797 if {$xc >= 0} {
5798 set z0 [expr {$xc - $x0}]
5801 # avoid lines jigging left then immediately right
5802 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5803 insert_pad $y0 $x0 1
5804 incr x0
5805 optimize_rows $y0 $x0 $row
5806 set previdlist [lindex $rowidlist $y0]
5809 if {!$haspad} {
5810 # Find the first column that doesn't have a line going right
5811 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5812 set id [lindex $idlist $col]
5813 if {$id eq {}} break
5814 set x0 [lsearch -exact $previdlist $id]
5815 if {$x0 < 0} {
5816 # check if this is the link to the first child
5817 set kid [lindex $displayorder $y0]
5818 if {[lindex $children($curview,$id) 0] eq $kid} {
5819 # it is, work out offset to child
5820 set x0 [lsearch -exact $previdlist $kid]
5823 if {$x0 <= $col} break
5825 # Insert a pad at that column as long as it has a line and
5826 # isn't the last column
5827 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5828 set idlist [linsert $idlist $col {}]
5829 lset rowidlist $row $idlist
5830 changedrow $row
5836 proc xc {row col} {
5837 global canvx0 linespc
5838 return [expr {$canvx0 + $col * $linespc}]
5841 proc yc {row} {
5842 global canvy0 linespc
5843 return [expr {$canvy0 + $row * $linespc}]
5846 proc linewidth {id} {
5847 global thickerline lthickness
5849 set wid $lthickness
5850 if {[info exists thickerline] && $id eq $thickerline} {
5851 set wid [expr {2 * $lthickness}]
5853 return $wid
5856 proc rowranges {id} {
5857 global curview children uparrowlen downarrowlen
5858 global rowidlist
5860 set kids $children($curview,$id)
5861 if {$kids eq {}} {
5862 return {}
5864 set ret {}
5865 lappend kids $id
5866 foreach child $kids {
5867 if {![commitinview $child $curview]} break
5868 set row [rowofcommit $child]
5869 if {![info exists prev]} {
5870 lappend ret [expr {$row + 1}]
5871 } else {
5872 if {$row <= $prevrow} {
5873 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5875 # see if the line extends the whole way from prevrow to row
5876 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5877 [lsearch -exact [lindex $rowidlist \
5878 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5879 # it doesn't, see where it ends
5880 set r [expr {$prevrow + $downarrowlen}]
5881 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5882 while {[incr r -1] > $prevrow &&
5883 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5884 } else {
5885 while {[incr r] <= $row &&
5886 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5887 incr r -1
5889 lappend ret $r
5890 # see where it starts up again
5891 set r [expr {$row - $uparrowlen}]
5892 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5893 while {[incr r] < $row &&
5894 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5895 } else {
5896 while {[incr r -1] >= $prevrow &&
5897 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5898 incr r
5900 lappend ret $r
5903 if {$child eq $id} {
5904 lappend ret $row
5906 set prev $child
5907 set prevrow $row
5909 return $ret
5912 proc drawlineseg {id row endrow arrowlow} {
5913 global rowidlist displayorder iddrawn linesegs
5914 global canv colormap linespc curview maxlinelen parentlist
5916 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5917 set le [expr {$row + 1}]
5918 set arrowhigh 1
5919 while {1} {
5920 set c [lsearch -exact [lindex $rowidlist $le] $id]
5921 if {$c < 0} {
5922 incr le -1
5923 break
5925 lappend cols $c
5926 set x [lindex $displayorder $le]
5927 if {$x eq $id} {
5928 set arrowhigh 0
5929 break
5931 if {[info exists iddrawn($x)] || $le == $endrow} {
5932 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5933 if {$c >= 0} {
5934 lappend cols $c
5935 set arrowhigh 0
5937 break
5939 incr le
5941 if {$le <= $row} {
5942 return $row
5945 set lines {}
5946 set i 0
5947 set joinhigh 0
5948 if {[info exists linesegs($id)]} {
5949 set lines $linesegs($id)
5950 foreach li $lines {
5951 set r0 [lindex $li 0]
5952 if {$r0 > $row} {
5953 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5954 set joinhigh 1
5956 break
5958 incr i
5961 set joinlow 0
5962 if {$i > 0} {
5963 set li [lindex $lines [expr {$i-1}]]
5964 set r1 [lindex $li 1]
5965 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5966 set joinlow 1
5970 set x [lindex $cols [expr {$le - $row}]]
5971 set xp [lindex $cols [expr {$le - 1 - $row}]]
5972 set dir [expr {$xp - $x}]
5973 if {$joinhigh} {
5974 set ith [lindex $lines $i 2]
5975 set coords [$canv coords $ith]
5976 set ah [$canv itemcget $ith -arrow]
5977 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5978 set x2 [lindex $cols [expr {$le + 1 - $row}]]
5979 if {$x2 ne {} && $x - $x2 == $dir} {
5980 set coords [lrange $coords 0 end-2]
5982 } else {
5983 set coords [list [xc $le $x] [yc $le]]
5985 if {$joinlow} {
5986 set itl [lindex $lines [expr {$i-1}] 2]
5987 set al [$canv itemcget $itl -arrow]
5988 set arrowlow [expr {$al eq "last" || $al eq "both"}]
5989 } elseif {$arrowlow} {
5990 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5991 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5992 set arrowlow 0
5995 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5996 for {set y $le} {[incr y -1] > $row} {} {
5997 set x $xp
5998 set xp [lindex $cols [expr {$y - 1 - $row}]]
5999 set ndir [expr {$xp - $x}]
6000 if {$dir != $ndir || $xp < 0} {
6001 lappend coords [xc $y $x] [yc $y]
6003 set dir $ndir
6005 if {!$joinlow} {
6006 if {$xp < 0} {
6007 # join parent line to first child
6008 set ch [lindex $displayorder $row]
6009 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
6010 if {$xc < 0} {
6011 puts "oops: drawlineseg: child $ch not on row $row"
6012 } elseif {$xc != $x} {
6013 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
6014 set d [expr {int(0.5 * $linespc)}]
6015 set x1 [xc $row $x]
6016 if {$xc < $x} {
6017 set x2 [expr {$x1 - $d}]
6018 } else {
6019 set x2 [expr {$x1 + $d}]
6021 set y2 [yc $row]
6022 set y1 [expr {$y2 + $d}]
6023 lappend coords $x1 $y1 $x2 $y2
6024 } elseif {$xc < $x - 1} {
6025 lappend coords [xc $row [expr {$x-1}]] [yc $row]
6026 } elseif {$xc > $x + 1} {
6027 lappend coords [xc $row [expr {$x+1}]] [yc $row]
6029 set x $xc
6031 lappend coords [xc $row $x] [yc $row]
6032 } else {
6033 set xn [xc $row $xp]
6034 set yn [yc $row]
6035 lappend coords $xn $yn
6037 if {!$joinhigh} {
6038 assigncolor $id
6039 set t [$canv create line $coords -width [linewidth $id] \
6040 -fill $colormap($id) -tags lines.$id -arrow $arrow]
6041 $canv lower $t
6042 bindline $t $id
6043 set lines [linsert $lines $i [list $row $le $t]]
6044 } else {
6045 $canv coords $ith $coords
6046 if {$arrow ne $ah} {
6047 $canv itemconf $ith -arrow $arrow
6049 lset lines $i 0 $row
6051 } else {
6052 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
6053 set ndir [expr {$xo - $xp}]
6054 set clow [$canv coords $itl]
6055 if {$dir == $ndir} {
6056 set clow [lrange $clow 2 end]
6058 set coords [concat $coords $clow]
6059 if {!$joinhigh} {
6060 lset lines [expr {$i-1}] 1 $le
6061 } else {
6062 # coalesce two pieces
6063 $canv delete $ith
6064 set b [lindex $lines [expr {$i-1}] 0]
6065 set e [lindex $lines $i 1]
6066 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6068 $canv coords $itl $coords
6069 if {$arrow ne $al} {
6070 $canv itemconf $itl -arrow $arrow
6074 set linesegs($id) $lines
6075 return $le
6078 proc drawparentlinks {id row} {
6079 global rowidlist canv colormap curview parentlist
6080 global idpos linespc
6082 set rowids [lindex $rowidlist $row]
6083 set col [lsearch -exact $rowids $id]
6084 if {$col < 0} return
6085 set olds [lindex $parentlist $row]
6086 set row2 [expr {$row + 1}]
6087 set x [xc $row $col]
6088 set y [yc $row]
6089 set y2 [yc $row2]
6090 set d [expr {int(0.5 * $linespc)}]
6091 set ymid [expr {$y + $d}]
6092 set ids [lindex $rowidlist $row2]
6093 # rmx = right-most X coord used
6094 set rmx 0
6095 foreach p $olds {
6096 set i [lsearch -exact $ids $p]
6097 if {$i < 0} {
6098 puts "oops, parent $p of $id not in list"
6099 continue
6101 set x2 [xc $row2 $i]
6102 if {$x2 > $rmx} {
6103 set rmx $x2
6105 set j [lsearch -exact $rowids $p]
6106 if {$j < 0} {
6107 # drawlineseg will do this one for us
6108 continue
6110 assigncolor $p
6111 # should handle duplicated parents here...
6112 set coords [list $x $y]
6113 if {$i != $col} {
6114 # if attaching to a vertical segment, draw a smaller
6115 # slant for visual distinctness
6116 if {$i == $j} {
6117 if {$i < $col} {
6118 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6119 } else {
6120 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6122 } elseif {$i < $col && $i < $j} {
6123 # segment slants towards us already
6124 lappend coords [xc $row $j] $y
6125 } else {
6126 if {$i < $col - 1} {
6127 lappend coords [expr {$x2 + $linespc}] $y
6128 } elseif {$i > $col + 1} {
6129 lappend coords [expr {$x2 - $linespc}] $y
6131 lappend coords $x2 $y2
6133 } else {
6134 lappend coords $x2 $y2
6136 set t [$canv create line $coords -width [linewidth $p] \
6137 -fill $colormap($p) -tags lines.$p]
6138 $canv lower $t
6139 bindline $t $p
6141 if {$rmx > [lindex $idpos($id) 1]} {
6142 lset idpos($id) 1 $rmx
6143 redrawtags $id
6147 proc drawlines {id} {
6148 global canv
6150 $canv itemconf lines.$id -width [linewidth $id]
6153 proc drawcmittext {id row col} {
6154 global linespc canv canv2 canv3 fgcolor curview
6155 global cmitlisted commitinfo rowidlist parentlist
6156 global rowtextx idpos idtags idheads idotherrefs
6157 global linehtag linentag linedtag selectedline
6158 global canvxmax boldids boldnameids fgcolor markedid
6159 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6160 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6161 global circleoutlinecolor
6163 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6164 set listed $cmitlisted($curview,$id)
6165 if {$id eq $nullid} {
6166 set ofill $workingfilescirclecolor
6167 } elseif {$id eq $nullid2} {
6168 set ofill $indexcirclecolor
6169 } elseif {$id eq $mainheadid} {
6170 set ofill $mainheadcirclecolor
6171 } else {
6172 set ofill [lindex $circlecolors $listed]
6174 set x [xc $row $col]
6175 set y [yc $row]
6176 set orad [expr {$linespc / 3}]
6177 if {$listed <= 2} {
6178 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6179 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6180 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6181 } elseif {$listed == 3} {
6182 # triangle pointing left for left-side commits
6183 set t [$canv create polygon \
6184 [expr {$x - $orad}] $y \
6185 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6186 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6187 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6188 } else {
6189 # triangle pointing right for right-side commits
6190 set t [$canv create polygon \
6191 [expr {$x + $orad - 1}] $y \
6192 [expr {$x - $orad}] [expr {$y - $orad}] \
6193 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6194 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6196 set circleitem($row) $t
6197 $canv raise $t
6198 $canv bind $t <1> {selcanvline {} %x %y}
6199 set rmx [llength [lindex $rowidlist $row]]
6200 set olds [lindex $parentlist $row]
6201 if {$olds ne {}} {
6202 set nextids [lindex $rowidlist [expr {$row + 1}]]
6203 foreach p $olds {
6204 set i [lsearch -exact $nextids $p]
6205 if {$i > $rmx} {
6206 set rmx $i
6210 set xt [xc $row $rmx]
6211 set rowtextx($row) $xt
6212 set idpos($id) [list $x $xt $y]
6213 if {[info exists idtags($id)] || [info exists idheads($id)]
6214 || [info exists idotherrefs($id)]} {
6215 set xt [drawtags $id $x $xt $y]
6217 if {[lindex $commitinfo($id) 6] > 0} {
6218 set xt [drawnotesign $xt $y]
6220 set headline [lindex $commitinfo($id) 0]
6221 set name [lindex $commitinfo($id) 1]
6222 set date [lindex $commitinfo($id) 2]
6223 set date [formatdate $date]
6224 set font mainfont
6225 set nfont mainfont
6226 set isbold [ishighlighted $id]
6227 if {$isbold > 0} {
6228 lappend boldids $id
6229 set font mainfontbold
6230 if {$isbold > 1} {
6231 lappend boldnameids $id
6232 set nfont mainfontbold
6235 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6236 -text $headline -font $font -tags text]
6237 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6238 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6239 -text $name -font $nfont -tags text]
6240 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6241 -text $date -font mainfont -tags text]
6242 if {$selectedline == $row} {
6243 make_secsel $id
6245 if {[info exists markedid] && $markedid eq $id} {
6246 make_idmark $id
6248 set xr [expr {$xt + [font measure $font $headline]}]
6249 if {$xr > $canvxmax} {
6250 set canvxmax $xr
6251 setcanvscroll
6255 proc drawcmitrow {row} {
6256 global displayorder rowidlist nrows_drawn
6257 global iddrawn markingmatches
6258 global commitinfo numcommits
6259 global filehighlight fhighlights findpattern nhighlights
6260 global hlview vhighlights
6261 global highlight_related rhighlights
6263 if {$row >= $numcommits} return
6265 set id [lindex $displayorder $row]
6266 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6267 askvhighlight $row $id
6269 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6270 askfilehighlight $row $id
6272 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6273 askfindhighlight $row $id
6275 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6276 askrelhighlight $row $id
6278 if {![info exists iddrawn($id)]} {
6279 set col [lsearch -exact [lindex $rowidlist $row] $id]
6280 if {$col < 0} {
6281 puts "oops, row $row id $id not in list"
6282 return
6284 if {![info exists commitinfo($id)]} {
6285 getcommit $id
6287 assigncolor $id
6288 drawcmittext $id $row $col
6289 set iddrawn($id) 1
6290 incr nrows_drawn
6292 if {$markingmatches} {
6293 markrowmatches $row $id
6297 proc drawcommits {row {endrow {}}} {
6298 global numcommits iddrawn displayorder curview need_redisplay
6299 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6301 if {$row < 0} {
6302 set row 0
6304 if {$endrow eq {}} {
6305 set endrow $row
6307 if {$endrow >= $numcommits} {
6308 set endrow [expr {$numcommits - 1}]
6311 set rl1 [expr {$row - $downarrowlen - 3}]
6312 if {$rl1 < 0} {
6313 set rl1 0
6315 set ro1 [expr {$row - 3}]
6316 if {$ro1 < 0} {
6317 set ro1 0
6319 set r2 [expr {$endrow + $uparrowlen + 3}]
6320 if {$r2 > $numcommits} {
6321 set r2 $numcommits
6323 for {set r $rl1} {$r < $r2} {incr r} {
6324 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6325 if {$rl1 < $r} {
6326 layoutrows $rl1 $r
6328 set rl1 [expr {$r + 1}]
6331 if {$rl1 < $r} {
6332 layoutrows $rl1 $r
6334 optimize_rows $ro1 0 $r2
6335 if {$need_redisplay || $nrows_drawn > 2000} {
6336 clear_display
6339 # make the lines join to already-drawn rows either side
6340 set r [expr {$row - 1}]
6341 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6342 set r $row
6344 set er [expr {$endrow + 1}]
6345 if {$er >= $numcommits ||
6346 ![info exists iddrawn([lindex $displayorder $er])]} {
6347 set er $endrow
6349 for {} {$r <= $er} {incr r} {
6350 set id [lindex $displayorder $r]
6351 set wasdrawn [info exists iddrawn($id)]
6352 drawcmitrow $r
6353 if {$r == $er} break
6354 set nextid [lindex $displayorder [expr {$r + 1}]]
6355 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6356 drawparentlinks $id $r
6358 set rowids [lindex $rowidlist $r]
6359 foreach lid $rowids {
6360 if {$lid eq {}} continue
6361 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6362 if {$lid eq $id} {
6363 # see if this is the first child of any of its parents
6364 foreach p [lindex $parentlist $r] {
6365 if {[lsearch -exact $rowids $p] < 0} {
6366 # make this line extend up to the child
6367 set lineend($p) [drawlineseg $p $r $er 0]
6370 } else {
6371 set lineend($lid) [drawlineseg $lid $r $er 1]
6377 proc undolayout {row} {
6378 global uparrowlen mingaplen downarrowlen
6379 global rowidlist rowisopt rowfinal need_redisplay
6381 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6382 if {$r < 0} {
6383 set r 0
6385 if {[llength $rowidlist] > $r} {
6386 incr r -1
6387 set rowidlist [lrange $rowidlist 0 $r]
6388 set rowfinal [lrange $rowfinal 0 $r]
6389 set rowisopt [lrange $rowisopt 0 $r]
6390 set need_redisplay 1
6391 run drawvisible
6395 proc drawvisible {} {
6396 global canv linespc curview vrowmod selectedline targetrow targetid
6397 global need_redisplay cscroll numcommits
6399 set fs [$canv yview]
6400 set ymax [lindex [$canv cget -scrollregion] 3]
6401 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6402 set f0 [lindex $fs 0]
6403 set f1 [lindex $fs 1]
6404 set y0 [expr {int($f0 * $ymax)}]
6405 set y1 [expr {int($f1 * $ymax)}]
6407 if {[info exists targetid]} {
6408 if {[commitinview $targetid $curview]} {
6409 set r [rowofcommit $targetid]
6410 if {$r != $targetrow} {
6411 # Fix up the scrollregion and change the scrolling position
6412 # now that our target row has moved.
6413 set diff [expr {($r - $targetrow) * $linespc}]
6414 set targetrow $r
6415 setcanvscroll
6416 set ymax [lindex [$canv cget -scrollregion] 3]
6417 incr y0 $diff
6418 incr y1 $diff
6419 set f0 [expr {$y0 / $ymax}]
6420 set f1 [expr {$y1 / $ymax}]
6421 allcanvs yview moveto $f0
6422 $cscroll set $f0 $f1
6423 set need_redisplay 1
6425 } else {
6426 unset targetid
6430 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6431 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6432 if {$endrow >= $vrowmod($curview)} {
6433 update_arcrows $curview
6435 if {$selectedline ne {} &&
6436 $row <= $selectedline && $selectedline <= $endrow} {
6437 set targetrow $selectedline
6438 } elseif {[info exists targetid]} {
6439 set targetrow [expr {int(($row + $endrow) / 2)}]
6441 if {[info exists targetrow]} {
6442 if {$targetrow >= $numcommits} {
6443 set targetrow [expr {$numcommits - 1}]
6445 set targetid [commitonrow $targetrow]
6447 drawcommits $row $endrow
6450 proc clear_display {} {
6451 global iddrawn linesegs need_redisplay nrows_drawn
6452 global vhighlights fhighlights nhighlights rhighlights
6453 global linehtag linentag linedtag boldids boldnameids
6455 allcanvs delete all
6456 unset -nocomplain iddrawn
6457 unset -nocomplain linesegs
6458 unset -nocomplain linehtag
6459 unset -nocomplain linentag
6460 unset -nocomplain linedtag
6461 set boldids {}
6462 set boldnameids {}
6463 unset -nocomplain vhighlights
6464 unset -nocomplain fhighlights
6465 unset -nocomplain nhighlights
6466 unset -nocomplain rhighlights
6467 set need_redisplay 0
6468 set nrows_drawn 0
6471 proc findcrossings {id} {
6472 global rowidlist parentlist numcommits displayorder
6474 set cross {}
6475 set ccross {}
6476 foreach {s e} [rowranges $id] {
6477 if {$e >= $numcommits} {
6478 set e [expr {$numcommits - 1}]
6480 if {$e <= $s} continue
6481 for {set row $e} {[incr row -1] >= $s} {} {
6482 set x [lsearch -exact [lindex $rowidlist $row] $id]
6483 if {$x < 0} break
6484 set olds [lindex $parentlist $row]
6485 set kid [lindex $displayorder $row]
6486 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6487 if {$kidx < 0} continue
6488 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6489 foreach p $olds {
6490 set px [lsearch -exact $nextrow $p]
6491 if {$px < 0} continue
6492 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6493 if {[lsearch -exact $ccross $p] >= 0} continue
6494 if {$x == $px + ($kidx < $px? -1: 1)} {
6495 lappend ccross $p
6496 } elseif {[lsearch -exact $cross $p] < 0} {
6497 lappend cross $p
6503 return [concat $ccross {{}} $cross]
6506 proc assigncolor {id} {
6507 global colormap colors nextcolor
6508 global parents children children curview
6510 if {[info exists colormap($id)]} return
6511 set ncolors [llength $colors]
6512 if {[info exists children($curview,$id)]} {
6513 set kids $children($curview,$id)
6514 } else {
6515 set kids {}
6517 if {[llength $kids] == 1} {
6518 set child [lindex $kids 0]
6519 if {[info exists colormap($child)]
6520 && [llength $parents($curview,$child)] == 1} {
6521 set colormap($id) $colormap($child)
6522 return
6525 set badcolors {}
6526 set origbad {}
6527 foreach x [findcrossings $id] {
6528 if {$x eq {}} {
6529 # delimiter between corner crossings and other crossings
6530 if {[llength $badcolors] >= $ncolors - 1} break
6531 set origbad $badcolors
6533 if {[info exists colormap($x)]
6534 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6535 lappend badcolors $colormap($x)
6538 if {[llength $badcolors] >= $ncolors} {
6539 set badcolors $origbad
6541 set origbad $badcolors
6542 if {[llength $badcolors] < $ncolors - 1} {
6543 foreach child $kids {
6544 if {[info exists colormap($child)]
6545 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6546 lappend badcolors $colormap($child)
6548 foreach p $parents($curview,$child) {
6549 if {[info exists colormap($p)]
6550 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6551 lappend badcolors $colormap($p)
6555 if {[llength $badcolors] >= $ncolors} {
6556 set badcolors $origbad
6559 for {set i 0} {$i <= $ncolors} {incr i} {
6560 set c [lindex $colors $nextcolor]
6561 if {[incr nextcolor] >= $ncolors} {
6562 set nextcolor 0
6564 if {[lsearch -exact $badcolors $c]} break
6566 set colormap($id) $c
6569 proc bindline {t id} {
6570 global canv
6572 $canv bind $t <Enter> "lineenter %x %y $id"
6573 $canv bind $t <Motion> "linemotion %x %y $id"
6574 $canv bind $t <Leave> "lineleave $id"
6575 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6578 proc graph_pane_width {} {
6579 global use_ttk
6581 if {$use_ttk} {
6582 set g [.tf.histframe.pwclist sashpos 0]
6583 } else {
6584 set g [.tf.histframe.pwclist sash coord 0]
6586 return [lindex $g 0]
6589 proc totalwidth {l font extra} {
6590 set tot 0
6591 foreach str $l {
6592 set tot [expr {$tot + [font measure $font $str] + $extra}]
6594 return $tot
6597 proc drawtags {id x xt y1} {
6598 global idtags idheads idotherrefs mainhead
6599 global linespc lthickness
6600 global canv rowtextx curview fgcolor bgcolor ctxbut
6601 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6602 global tagbgcolor tagfgcolor tagoutlinecolor
6603 global reflinecolor
6605 set marks {}
6606 set ntags 0
6607 set nheads 0
6608 set singletag 0
6609 set maxtags 3
6610 set maxtagpct 25
6611 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6612 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6613 set extra [expr {$delta + $lthickness + $linespc}]
6615 if {[info exists idtags($id)]} {
6616 set marks $idtags($id)
6617 set ntags [llength $marks]
6618 if {$ntags > $maxtags ||
6619 [totalwidth $marks mainfont $extra] > $maxwidth} {
6620 # show just a single "n tags..." tag
6621 set singletag 1
6622 if {$ntags == 1} {
6623 set marks [list "tag..."]
6624 } else {
6625 set marks [list [format "%d tags..." $ntags]]
6627 set ntags 1
6630 if {[info exists idheads($id)]} {
6631 set marks [concat $marks $idheads($id)]
6632 set nheads [llength $idheads($id)]
6634 if {[info exists idotherrefs($id)]} {
6635 set marks [concat $marks $idotherrefs($id)]
6637 if {$marks eq {}} {
6638 return $xt
6641 set yt [expr {$y1 - 0.5 * $linespc}]
6642 set yb [expr {$yt + $linespc - 1}]
6643 set xvals {}
6644 set wvals {}
6645 set i -1
6646 foreach tag $marks {
6647 incr i
6648 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6649 set wid [font measure mainfontbold $tag]
6650 } else {
6651 set wid [font measure mainfont $tag]
6653 lappend xvals $xt
6654 lappend wvals $wid
6655 set xt [expr {$xt + $wid + $extra}]
6657 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6658 -width $lthickness -fill $reflinecolor -tags tag.$id]
6659 $canv lower $t
6660 foreach tag $marks x $xvals wid $wvals {
6661 set tag_quoted [string map {% %%} $tag]
6662 set xl [expr {$x + $delta}]
6663 set xr [expr {$x + $delta + $wid + $lthickness}]
6664 set font mainfont
6665 if {[incr ntags -1] >= 0} {
6666 # draw a tag
6667 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6668 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6669 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6670 -tags tag.$id]
6671 if {$singletag} {
6672 set tagclick [list showtags $id 1]
6673 } else {
6674 set tagclick [list showtag $tag_quoted 1]
6676 $canv bind $t <1> $tagclick
6677 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6678 } else {
6679 # draw a head or other ref
6680 if {[incr nheads -1] >= 0} {
6681 set col $headbgcolor
6682 if {$tag eq $mainhead} {
6683 set font mainfontbold
6685 } else {
6686 set col "#ddddff"
6688 set xl [expr {$xl - $delta/2}]
6689 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6690 -width 1 -outline black -fill $col -tags tag.$id
6691 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6692 set rwid [font measure mainfont $remoteprefix]
6693 set xi [expr {$x + 1}]
6694 set yti [expr {$yt + 1}]
6695 set xri [expr {$x + $rwid}]
6696 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6697 -width 0 -fill $remotebgcolor -tags tag.$id
6700 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6701 -font $font -tags [list tag.$id text]]
6702 if {$ntags >= 0} {
6703 $canv bind $t <1> $tagclick
6704 } elseif {$nheads >= 0} {
6705 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6708 return $xt
6711 proc drawnotesign {xt y} {
6712 global linespc canv fgcolor
6714 set orad [expr {$linespc / 3}]
6715 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6716 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6717 -fill yellow -outline $fgcolor -width 1 -tags circle]
6718 set xt [expr {$xt + $orad * 3}]
6719 return $xt
6722 proc xcoord {i level ln} {
6723 global canvx0 xspc1 xspc2
6725 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6726 if {$i > 0 && $i == $level} {
6727 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6728 } elseif {$i > $level} {
6729 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6731 return $x
6734 proc show_status {msg} {
6735 global canv fgcolor
6737 clear_display
6738 set_window_title
6739 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6740 -tags text -fill $fgcolor
6743 # Don't change the text pane cursor if it is currently the hand cursor,
6744 # showing that we are over a sha1 ID link.
6745 proc settextcursor {c} {
6746 global ctext curtextcursor
6748 if {[$ctext cget -cursor] == $curtextcursor} {
6749 $ctext config -cursor $c
6751 set curtextcursor $c
6754 proc nowbusy {what {name {}}} {
6755 global isbusy busyname statusw
6757 if {[array names isbusy] eq {}} {
6758 . config -cursor watch
6759 settextcursor watch
6761 set isbusy($what) 1
6762 set busyname($what) $name
6763 if {$name ne {}} {
6764 $statusw conf -text $name
6768 proc notbusy {what} {
6769 global isbusy maincursor textcursor busyname statusw
6771 catch {
6772 unset isbusy($what)
6773 if {$busyname($what) ne {} &&
6774 [$statusw cget -text] eq $busyname($what)} {
6775 $statusw conf -text {}
6778 if {[array names isbusy] eq {}} {
6779 . config -cursor $maincursor
6780 settextcursor $textcursor
6784 proc findmatches {f} {
6785 global findtype findstring
6786 if {$findtype == [mc "Regexp"]} {
6787 set matches [regexp -indices -all -inline $findstring $f]
6788 } else {
6789 set fs $findstring
6790 if {$findtype == [mc "IgnCase"]} {
6791 set f [string tolower $f]
6792 set fs [string tolower $fs]
6794 set matches {}
6795 set i 0
6796 set l [string length $fs]
6797 while {[set j [string first $fs $f $i]] >= 0} {
6798 lappend matches [list $j [expr {$j+$l-1}]]
6799 set i [expr {$j + $l}]
6802 return $matches
6805 proc dofind {{dirn 1} {wrap 1}} {
6806 global findstring findstartline findcurline selectedline numcommits
6807 global gdttype filehighlight fh_serial find_dirn findallowwrap
6809 if {[info exists find_dirn]} {
6810 if {$find_dirn == $dirn} return
6811 stopfinding
6813 focus .
6814 if {$findstring eq {} || $numcommits == 0} return
6815 if {$selectedline eq {}} {
6816 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6817 } else {
6818 set findstartline $selectedline
6820 set findcurline $findstartline
6821 nowbusy finding [mc "Searching"]
6822 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6823 after cancel do_file_hl $fh_serial
6824 do_file_hl $fh_serial
6826 set find_dirn $dirn
6827 set findallowwrap $wrap
6828 run findmore
6831 proc stopfinding {} {
6832 global find_dirn findcurline fprogcoord
6834 if {[info exists find_dirn]} {
6835 unset find_dirn
6836 unset findcurline
6837 notbusy finding
6838 set fprogcoord 0
6839 adjustprogress
6841 stopblaming
6844 proc findmore {} {
6845 global commitdata commitinfo numcommits findpattern findloc
6846 global findstartline findcurline findallowwrap
6847 global find_dirn gdttype fhighlights fprogcoord
6848 global curview varcorder vrownum varccommits vrowmod
6850 if {![info exists find_dirn]} {
6851 return 0
6853 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6854 set l $findcurline
6855 set moretodo 0
6856 if {$find_dirn > 0} {
6857 incr l
6858 if {$l >= $numcommits} {
6859 set l 0
6861 if {$l <= $findstartline} {
6862 set lim [expr {$findstartline + 1}]
6863 } else {
6864 set lim $numcommits
6865 set moretodo $findallowwrap
6867 } else {
6868 if {$l == 0} {
6869 set l $numcommits
6871 incr l -1
6872 if {$l >= $findstartline} {
6873 set lim [expr {$findstartline - 1}]
6874 } else {
6875 set lim -1
6876 set moretodo $findallowwrap
6879 set n [expr {($lim - $l) * $find_dirn}]
6880 if {$n > 500} {
6881 set n 500
6882 set moretodo 1
6884 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6885 update_arcrows $curview
6887 set found 0
6888 set domore 1
6889 set ai [bsearch $vrownum($curview) $l]
6890 set a [lindex $varcorder($curview) $ai]
6891 set arow [lindex $vrownum($curview) $ai]
6892 set ids [lindex $varccommits($curview,$a)]
6893 set arowend [expr {$arow + [llength $ids]}]
6894 if {$gdttype eq [mc "containing:"]} {
6895 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6896 if {$l < $arow || $l >= $arowend} {
6897 incr ai $find_dirn
6898 set a [lindex $varcorder($curview) $ai]
6899 set arow [lindex $vrownum($curview) $ai]
6900 set ids [lindex $varccommits($curview,$a)]
6901 set arowend [expr {$arow + [llength $ids]}]
6903 set id [lindex $ids [expr {$l - $arow}]]
6904 # shouldn't happen unless git log doesn't give all the commits...
6905 if {![info exists commitdata($id)] ||
6906 ![doesmatch $commitdata($id)]} {
6907 continue
6909 if {![info exists commitinfo($id)]} {
6910 getcommit $id
6912 set info $commitinfo($id)
6913 foreach f $info ty $fldtypes {
6914 if {$ty eq ""} continue
6915 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6916 [doesmatch $f]} {
6917 set found 1
6918 break
6921 if {$found} break
6923 } else {
6924 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6925 if {$l < $arow || $l >= $arowend} {
6926 incr ai $find_dirn
6927 set a [lindex $varcorder($curview) $ai]
6928 set arow [lindex $vrownum($curview) $ai]
6929 set ids [lindex $varccommits($curview,$a)]
6930 set arowend [expr {$arow + [llength $ids]}]
6932 set id [lindex $ids [expr {$l - $arow}]]
6933 if {![info exists fhighlights($id)]} {
6934 # this sets fhighlights($id) to -1
6935 askfilehighlight $l $id
6937 if {$fhighlights($id) > 0} {
6938 set found $domore
6939 break
6941 if {$fhighlights($id) < 0} {
6942 if {$domore} {
6943 set domore 0
6944 set findcurline [expr {$l - $find_dirn}]
6949 if {$found || ($domore && !$moretodo)} {
6950 unset findcurline
6951 unset find_dirn
6952 notbusy finding
6953 set fprogcoord 0
6954 adjustprogress
6955 if {$found} {
6956 findselectline $l
6957 } else {
6958 bell
6960 return 0
6962 if {!$domore} {
6963 flushhighlights
6964 } else {
6965 set findcurline [expr {$l - $find_dirn}]
6967 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6968 if {$n < 0} {
6969 incr n $numcommits
6971 set fprogcoord [expr {$n * 1.0 / $numcommits}]
6972 adjustprogress
6973 return $domore
6976 proc findselectline {l} {
6977 global findloc commentend ctext findcurline markingmatches gdttype
6979 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6980 set findcurline $l
6981 selectline $l 1
6982 if {$markingmatches &&
6983 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6984 # highlight the matches in the comments
6985 set f [$ctext get 1.0 $commentend]
6986 set matches [findmatches $f]
6987 foreach match $matches {
6988 set start [lindex $match 0]
6989 set end [expr {[lindex $match 1] + 1}]
6990 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6993 drawvisible
6996 # mark the bits of a headline or author that match a find string
6997 proc markmatches {canv l str tag matches font row} {
6998 global selectedline
7000 set bbox [$canv bbox $tag]
7001 set x0 [lindex $bbox 0]
7002 set y0 [lindex $bbox 1]
7003 set y1 [lindex $bbox 3]
7004 foreach match $matches {
7005 set start [lindex $match 0]
7006 set end [lindex $match 1]
7007 if {$start > $end} continue
7008 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
7009 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
7010 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
7011 [expr {$x0+$xlen+2}] $y1 \
7012 -outline {} -tags [list match$l matches] -fill yellow]
7013 $canv lower $t
7014 if {$row == $selectedline} {
7015 $canv raise $t secsel
7020 proc unmarkmatches {} {
7021 global markingmatches
7023 allcanvs delete matches
7024 set markingmatches 0
7025 stopfinding
7028 proc selcanvline {w x y} {
7029 global canv canvy0 ctext linespc
7030 global rowtextx
7031 set ymax [lindex [$canv cget -scrollregion] 3]
7032 if {$ymax == {}} return
7033 set yfrac [lindex [$canv yview] 0]
7034 set y [expr {$y + $yfrac * $ymax}]
7035 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
7036 if {$l < 0} {
7037 set l 0
7039 if {$w eq $canv} {
7040 set xmax [lindex [$canv cget -scrollregion] 2]
7041 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
7042 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
7044 unmarkmatches
7045 selectline $l 1
7048 proc commit_descriptor {p} {
7049 global commitinfo
7050 if {![info exists commitinfo($p)]} {
7051 getcommit $p
7053 set l "..."
7054 if {[llength $commitinfo($p)] > 1} {
7055 set l [lindex $commitinfo($p) 0]
7057 return "$p ($l)\n"
7060 # append some text to the ctext widget, and make any SHA1 ID
7061 # that we know about be a clickable link.
7062 # Also look for URLs of the form "http[s]://..." and make them web links.
7063 proc appendwithlinks {text tags} {
7064 global ctext linknum curview
7066 set start [$ctext index "end - 1c"]
7067 $ctext insert end $text $tags
7068 set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
7069 foreach l $links {
7070 set s [lindex $l 0]
7071 set e [lindex $l 1]
7072 set linkid [string range $text $s $e]
7073 incr e
7074 $ctext tag delete link$linknum
7075 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7076 setlink $linkid link$linknum
7077 incr linknum
7079 set wlinks [regexp -indices -all -inline -line \
7080 {https?://[^[:space:]]+} $text]
7081 foreach l $wlinks {
7082 set s2 [lindex $l 0]
7083 set e2 [lindex $l 1]
7084 set url [string range $text $s2 $e2]
7085 incr e2
7086 $ctext tag delete link$linknum
7087 $ctext tag add link$linknum "$start + $s2 c" "$start + $e2 c"
7088 setwlink $url link$linknum
7089 incr linknum
7093 proc setlink {id lk} {
7094 global curview ctext pendinglinks
7095 global linkfgcolor
7097 if {[string range $id 0 1] eq "-g"} {
7098 set id [string range $id 2 end]
7101 set known 0
7102 if {[string length $id] < 40} {
7103 set matches [longid $id]
7104 if {[llength $matches] > 0} {
7105 if {[llength $matches] > 1} return
7106 set known 1
7107 set id [lindex $matches 0]
7109 } else {
7110 set known [commitinview $id $curview]
7112 if {$known} {
7113 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7114 $ctext tag bind $lk <1> [list selbyid $id]
7115 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7116 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7117 } else {
7118 lappend pendinglinks($id) $lk
7119 interestedin $id {makelink %P}
7123 proc setwlink {url lk} {
7124 global ctext
7125 global linkfgcolor
7126 global web_browser
7128 if {$web_browser eq {}} return
7129 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7130 $ctext tag bind $lk <1> [list browseweb $url]
7131 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7132 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7135 proc appendshortlink {id {pre {}} {post {}}} {
7136 global ctext linknum
7138 $ctext insert end $pre
7139 $ctext tag delete link$linknum
7140 $ctext insert end [string range $id 0 7] link$linknum
7141 $ctext insert end $post
7142 setlink $id link$linknum
7143 incr linknum
7146 proc makelink {id} {
7147 global pendinglinks
7149 if {![info exists pendinglinks($id)]} return
7150 foreach lk $pendinglinks($id) {
7151 setlink $id $lk
7153 unset pendinglinks($id)
7156 proc linkcursor {w inc} {
7157 global linkentercount curtextcursor
7159 if {[incr linkentercount $inc] > 0} {
7160 $w configure -cursor hand2
7161 } else {
7162 $w configure -cursor $curtextcursor
7163 if {$linkentercount < 0} {
7164 set linkentercount 0
7169 proc browseweb {url} {
7170 global web_browser
7172 if {$web_browser eq {}} return
7173 # Use eval here in case $web_browser is a command plus some arguments
7174 if {[catch {eval exec $web_browser [list $url] &} err]} {
7175 error_popup "[mc "Error starting web browser:"] $err"
7179 proc viewnextline {dir} {
7180 global canv linespc
7182 $canv delete hover
7183 set ymax [lindex [$canv cget -scrollregion] 3]
7184 set wnow [$canv yview]
7185 set wtop [expr {[lindex $wnow 0] * $ymax}]
7186 set newtop [expr {$wtop + $dir * $linespc}]
7187 if {$newtop < 0} {
7188 set newtop 0
7189 } elseif {$newtop > $ymax} {
7190 set newtop $ymax
7192 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7195 # add a list of tag or branch names at position pos
7196 # returns the number of names inserted
7197 proc appendrefs {pos ids var} {
7198 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7200 if {[catch {$ctext index $pos}]} {
7201 return 0
7203 $ctext conf -state normal
7204 $ctext delete $pos "$pos lineend"
7205 set tags {}
7206 foreach id $ids {
7207 foreach tag [set $var\($id\)] {
7208 lappend tags [list $tag $id]
7212 set sep {}
7213 set tags [lsort -index 0 -decreasing $tags]
7214 set nutags 0
7216 if {[llength $tags] > $maxrefs} {
7217 # If we are displaying heads, and there are too many,
7218 # see if there are some important heads to display.
7219 # Currently that are the current head and heads listed in $visiblerefs option
7220 set itags {}
7221 if {$var eq "idheads"} {
7222 set utags {}
7223 foreach ti $tags {
7224 set hname [lindex $ti 0]
7225 set id [lindex $ti 1]
7226 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7227 [llength $itags] < $maxrefs} {
7228 lappend itags $ti
7229 } else {
7230 lappend utags $ti
7233 set tags $utags
7235 if {$itags ne {}} {
7236 set str [mc "and many more"]
7237 set sep " "
7238 } else {
7239 set str [mc "many"]
7241 $ctext insert $pos "$str ([llength $tags])"
7242 set nutags [llength $tags]
7243 set tags $itags
7246 foreach ti $tags {
7247 set id [lindex $ti 1]
7248 set lk link$linknum
7249 incr linknum
7250 $ctext tag delete $lk
7251 $ctext insert $pos $sep
7252 $ctext insert $pos [lindex $ti 0] $lk
7253 setlink $id $lk
7254 set sep ", "
7256 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7257 $ctext conf -state disabled
7258 return [expr {[llength $tags] + $nutags}]
7261 # called when we have finished computing the nearby tags
7262 proc dispneartags {delay} {
7263 global selectedline currentid showneartags tagphase
7265 if {$selectedline eq {} || !$showneartags} return
7266 after cancel dispnexttag
7267 if {$delay} {
7268 after 200 dispnexttag
7269 set tagphase -1
7270 } else {
7271 after idle dispnexttag
7272 set tagphase 0
7276 proc dispnexttag {} {
7277 global selectedline currentid showneartags tagphase ctext
7279 if {$selectedline eq {} || !$showneartags} return
7280 switch -- $tagphase {
7282 set dtags [desctags $currentid]
7283 if {$dtags ne {}} {
7284 appendrefs precedes $dtags idtags
7288 set atags [anctags $currentid]
7289 if {$atags ne {}} {
7290 appendrefs follows $atags idtags
7294 set dheads [descheads $currentid]
7295 if {$dheads ne {}} {
7296 if {[appendrefs branch $dheads idheads] > 1
7297 && [$ctext get "branch -3c"] eq "h"} {
7298 # turn "Branch" into "Branches"
7299 $ctext conf -state normal
7300 $ctext insert "branch -2c" "es"
7301 $ctext conf -state disabled
7306 if {[incr tagphase] <= 2} {
7307 after idle dispnexttag
7311 proc make_secsel {id} {
7312 global linehtag linentag linedtag canv canv2 canv3
7314 if {![info exists linehtag($id)]} return
7315 $canv delete secsel
7316 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7317 -tags secsel -fill [$canv cget -selectbackground]]
7318 $canv lower $t
7319 $canv2 delete secsel
7320 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7321 -tags secsel -fill [$canv2 cget -selectbackground]]
7322 $canv2 lower $t
7323 $canv3 delete secsel
7324 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7325 -tags secsel -fill [$canv3 cget -selectbackground]]
7326 $canv3 lower $t
7329 proc make_idmark {id} {
7330 global linehtag canv fgcolor
7332 if {![info exists linehtag($id)]} return
7333 $canv delete markid
7334 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7335 -tags markid -outline $fgcolor]
7336 $canv raise $t
7339 proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7340 global canv ctext commitinfo selectedline
7341 global canvy0 linespc parents children curview
7342 global currentid sha1entry
7343 global commentend idtags linknum
7344 global mergemax numcommits pending_select
7345 global cmitmode showneartags allcommits
7346 global targetrow targetid lastscrollrows
7347 global autoselect autosellen jump_to_here
7348 global vinlinediff
7350 unset -nocomplain pending_select
7351 $canv delete hover
7352 normalline
7353 unsel_reflist
7354 stopfinding
7355 if {$l < 0 || $l >= $numcommits} return
7356 set id [commitonrow $l]
7357 set targetid $id
7358 set targetrow $l
7359 set selectedline $l
7360 set currentid $id
7361 if {$lastscrollrows < $numcommits} {
7362 setcanvscroll
7365 if {$cmitmode ne "patch" && $switch_to_patch} {
7366 set cmitmode "patch"
7369 set y [expr {$canvy0 + $l * $linespc}]
7370 set ymax [lindex [$canv cget -scrollregion] 3]
7371 set ytop [expr {$y - $linespc - 1}]
7372 set ybot [expr {$y + $linespc + 1}]
7373 set wnow [$canv yview]
7374 set wtop [expr {[lindex $wnow 0] * $ymax}]
7375 set wbot [expr {[lindex $wnow 1] * $ymax}]
7376 set wh [expr {$wbot - $wtop}]
7377 set newtop $wtop
7378 if {$ytop < $wtop} {
7379 if {$ybot < $wtop} {
7380 set newtop [expr {$y - $wh / 2.0}]
7381 } else {
7382 set newtop $ytop
7383 if {$newtop > $wtop - $linespc} {
7384 set newtop [expr {$wtop - $linespc}]
7387 } elseif {$ybot > $wbot} {
7388 if {$ytop > $wbot} {
7389 set newtop [expr {$y - $wh / 2.0}]
7390 } else {
7391 set newtop [expr {$ybot - $wh}]
7392 if {$newtop < $wtop + $linespc} {
7393 set newtop [expr {$wtop + $linespc}]
7397 if {$newtop != $wtop} {
7398 if {$newtop < 0} {
7399 set newtop 0
7401 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7402 drawvisible
7405 make_secsel $id
7407 if {$isnew} {
7408 addtohistory [list selbyid $id 0] savecmitpos
7411 $sha1entry delete 0 end
7412 $sha1entry insert 0 $id
7413 if {$autoselect} {
7414 $sha1entry selection range 0 $autosellen
7416 rhighlight_sel $id
7418 $ctext conf -state normal
7419 clear_ctext
7420 set linknum 0
7421 if {![info exists commitinfo($id)]} {
7422 getcommit $id
7424 set info $commitinfo($id)
7425 set date [formatdate [lindex $info 2]]
7426 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7427 set date [formatdate [lindex $info 4]]
7428 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7429 if {[info exists idtags($id)]} {
7430 $ctext insert end [mc "Tags:"]
7431 foreach tag $idtags($id) {
7432 $ctext insert end " $tag"
7434 $ctext insert end "\n"
7437 set headers {}
7438 set olds $parents($curview,$id)
7439 if {[llength $olds] > 1} {
7440 set np 0
7441 foreach p $olds {
7442 if {$np >= $mergemax} {
7443 set tag mmax
7444 } else {
7445 set tag m$np
7447 $ctext insert end "[mc "Parent"]: " $tag
7448 appendwithlinks [commit_descriptor $p] {}
7449 incr np
7451 } else {
7452 foreach p $olds {
7453 append headers "[mc "Parent"]: [commit_descriptor $p]"
7457 foreach c $children($curview,$id) {
7458 append headers "[mc "Child"]: [commit_descriptor $c]"
7461 # make anything that looks like a SHA1 ID be a clickable link
7462 appendwithlinks $headers {}
7463 if {$showneartags} {
7464 if {![info exists allcommits]} {
7465 getallcommits
7467 $ctext insert end "[mc "Branch"]: "
7468 $ctext mark set branch "end -1c"
7469 $ctext mark gravity branch left
7470 $ctext insert end "\n[mc "Follows"]: "
7471 $ctext mark set follows "end -1c"
7472 $ctext mark gravity follows left
7473 $ctext insert end "\n[mc "Precedes"]: "
7474 $ctext mark set precedes "end -1c"
7475 $ctext mark gravity precedes left
7476 $ctext insert end "\n"
7477 dispneartags 1
7479 $ctext insert end "\n"
7480 set comment [lindex $info 5]
7481 if {[string first "\r" $comment] >= 0} {
7482 set comment [string map {"\r" "\n "} $comment]
7484 appendwithlinks $comment {comment}
7486 $ctext tag remove found 1.0 end
7487 $ctext conf -state disabled
7488 set commentend [$ctext index "end - 1c"]
7490 set jump_to_here $desired_loc
7491 init_flist [mc "Comments"]
7492 if {$cmitmode eq "tree"} {
7493 gettree $id
7494 } elseif {$vinlinediff($curview) == 1} {
7495 showinlinediff $id
7496 } elseif {[llength $olds] <= 1} {
7497 startdiff $id
7498 } else {
7499 mergediff $id
7503 proc selfirstline {} {
7504 unmarkmatches
7505 selectline 0 1
7508 proc sellastline {} {
7509 global numcommits
7510 unmarkmatches
7511 set l [expr {$numcommits - 1}]
7512 selectline $l 1
7515 proc selnextline {dir} {
7516 global selectedline
7517 focus .
7518 if {$selectedline eq {}} return
7519 set l [expr {$selectedline + $dir}]
7520 unmarkmatches
7521 selectline $l 1
7524 proc selnextpage {dir} {
7525 global canv linespc selectedline numcommits
7527 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7528 if {$lpp < 1} {
7529 set lpp 1
7531 allcanvs yview scroll [expr {$dir * $lpp}] units
7532 drawvisible
7533 if {$selectedline eq {}} return
7534 set l [expr {$selectedline + $dir * $lpp}]
7535 if {$l < 0} {
7536 set l 0
7537 } elseif {$l >= $numcommits} {
7538 set l [expr $numcommits - 1]
7540 unmarkmatches
7541 selectline $l 1
7544 proc unselectline {} {
7545 global selectedline currentid
7547 set selectedline {}
7548 unset -nocomplain currentid
7549 allcanvs delete secsel
7550 rhighlight_none
7553 proc reselectline {} {
7554 global selectedline
7556 if {$selectedline ne {}} {
7557 selectline $selectedline 0
7561 proc addtohistory {cmd {saveproc {}}} {
7562 global history historyindex curview
7564 unset_posvars
7565 save_position
7566 set elt [list $curview $cmd $saveproc {}]
7567 if {$historyindex > 0
7568 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7569 return
7572 if {$historyindex < [llength $history]} {
7573 set history [lreplace $history $historyindex end $elt]
7574 } else {
7575 lappend history $elt
7577 incr historyindex
7578 if {$historyindex > 1} {
7579 .tf.bar.leftbut conf -state normal
7580 } else {
7581 .tf.bar.leftbut conf -state disabled
7583 .tf.bar.rightbut conf -state disabled
7586 # save the scrolling position of the diff display pane
7587 proc save_position {} {
7588 global historyindex history
7590 if {$historyindex < 1} return
7591 set hi [expr {$historyindex - 1}]
7592 set fn [lindex $history $hi 2]
7593 if {$fn ne {}} {
7594 lset history $hi 3 [eval $fn]
7598 proc unset_posvars {} {
7599 global last_posvars
7601 if {[info exists last_posvars]} {
7602 foreach {var val} $last_posvars {
7603 global $var
7604 unset -nocomplain $var
7606 unset last_posvars
7610 proc godo {elt} {
7611 global curview last_posvars
7613 set view [lindex $elt 0]
7614 set cmd [lindex $elt 1]
7615 set pv [lindex $elt 3]
7616 if {$curview != $view} {
7617 showview $view
7619 unset_posvars
7620 foreach {var val} $pv {
7621 global $var
7622 set $var $val
7624 set last_posvars $pv
7625 eval $cmd
7628 proc goback {} {
7629 global history historyindex
7630 focus .
7632 if {$historyindex > 1} {
7633 save_position
7634 incr historyindex -1
7635 godo [lindex $history [expr {$historyindex - 1}]]
7636 .tf.bar.rightbut conf -state normal
7638 if {$historyindex <= 1} {
7639 .tf.bar.leftbut conf -state disabled
7643 proc goforw {} {
7644 global history historyindex
7645 focus .
7647 if {$historyindex < [llength $history]} {
7648 save_position
7649 set cmd [lindex $history $historyindex]
7650 incr historyindex
7651 godo $cmd
7652 .tf.bar.leftbut conf -state normal
7654 if {$historyindex >= [llength $history]} {
7655 .tf.bar.rightbut conf -state disabled
7659 proc go_to_parent {i} {
7660 global parents curview targetid
7661 set ps $parents($curview,$targetid)
7662 if {[llength $ps] >= $i} {
7663 selbyid [lindex $ps [expr $i - 1]]
7667 proc gettree {id} {
7668 global treefilelist treeidlist diffids diffmergeid treepending
7669 global nullid nullid2
7671 set diffids $id
7672 unset -nocomplain diffmergeid
7673 if {![info exists treefilelist($id)]} {
7674 if {![info exists treepending]} {
7675 if {$id eq $nullid} {
7676 set cmd [list | git ls-files]
7677 } elseif {$id eq $nullid2} {
7678 set cmd [list | git ls-files --stage -t]
7679 } else {
7680 set cmd [list | git ls-tree -r $id]
7682 if {[catch {set gtf [open $cmd r]}]} {
7683 return
7685 set treepending $id
7686 set treefilelist($id) {}
7687 set treeidlist($id) {}
7688 fconfigure $gtf -blocking 0 -encoding binary
7689 filerun $gtf [list gettreeline $gtf $id]
7691 } else {
7692 setfilelist $id
7696 proc gettreeline {gtf id} {
7697 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7699 set nl 0
7700 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7701 if {$diffids eq $nullid} {
7702 set fname $line
7703 } else {
7704 set i [string first "\t" $line]
7705 if {$i < 0} continue
7706 set fname [string range $line [expr {$i+1}] end]
7707 set line [string range $line 0 [expr {$i-1}]]
7708 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7709 set sha1 [lindex $line 2]
7710 lappend treeidlist($id) $sha1
7712 if {[string index $fname 0] eq "\""} {
7713 set fname [lindex $fname 0]
7715 set fname [encoding convertfrom $fname]
7716 lappend treefilelist($id) $fname
7718 if {![eof $gtf]} {
7719 return [expr {$nl >= 1000? 2: 1}]
7721 close $gtf
7722 unset treepending
7723 if {$cmitmode ne "tree"} {
7724 if {![info exists diffmergeid]} {
7725 gettreediffs $diffids
7727 } elseif {$id ne $diffids} {
7728 gettree $diffids
7729 } else {
7730 setfilelist $id
7732 return 0
7735 proc showfile {f} {
7736 global treefilelist treeidlist diffids nullid nullid2
7737 global ctext_file_names ctext_file_lines
7738 global ctext commentend
7740 set i [lsearch -exact $treefilelist($diffids) $f]
7741 if {$i < 0} {
7742 puts "oops, $f not in list for id $diffids"
7743 return
7745 if {$diffids eq $nullid} {
7746 if {[catch {set bf [open $f r]} err]} {
7747 puts "oops, can't read $f: $err"
7748 return
7750 } else {
7751 set blob [lindex $treeidlist($diffids) $i]
7752 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7753 puts "oops, error reading blob $blob: $err"
7754 return
7757 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7758 filerun $bf [list getblobline $bf $diffids]
7759 $ctext config -state normal
7760 clear_ctext $commentend
7761 lappend ctext_file_names $f
7762 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7763 $ctext insert end "\n"
7764 $ctext insert end "$f\n" filesep
7765 $ctext config -state disabled
7766 $ctext yview $commentend
7767 settabs 0
7770 proc getblobline {bf id} {
7771 global diffids cmitmode ctext
7773 if {$id ne $diffids || $cmitmode ne "tree"} {
7774 catch {close $bf}
7775 return 0
7777 $ctext config -state normal
7778 set nl 0
7779 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7780 $ctext insert end "$line\n"
7782 if {[eof $bf]} {
7783 global jump_to_here ctext_file_names commentend
7785 # delete last newline
7786 $ctext delete "end - 2c" "end - 1c"
7787 close $bf
7788 if {$jump_to_here ne {} &&
7789 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7790 set lnum [expr {[lindex $jump_to_here 1] +
7791 [lindex [split $commentend .] 0]}]
7792 mark_ctext_line $lnum
7794 $ctext config -state disabled
7795 return 0
7797 $ctext config -state disabled
7798 return [expr {$nl >= 1000? 2: 1}]
7801 proc mark_ctext_line {lnum} {
7802 global ctext markbgcolor
7804 $ctext tag delete omark
7805 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7806 $ctext tag conf omark -background $markbgcolor
7807 $ctext see $lnum.0
7810 proc mergediff {id} {
7811 global diffmergeid
7812 global diffids treediffs
7813 global parents curview
7815 set diffmergeid $id
7816 set diffids $id
7817 set treediffs($id) {}
7818 set np [llength $parents($curview,$id)]
7819 settabs $np
7820 getblobdiffs $id
7823 proc startdiff {ids} {
7824 global treediffs diffids treepending diffmergeid nullid nullid2
7826 settabs 1
7827 set diffids $ids
7828 unset -nocomplain diffmergeid
7829 if {![info exists treediffs($ids)] ||
7830 [lsearch -exact $ids $nullid] >= 0 ||
7831 [lsearch -exact $ids $nullid2] >= 0} {
7832 if {![info exists treepending]} {
7833 gettreediffs $ids
7835 } else {
7836 addtocflist $ids
7840 proc showinlinediff {ids} {
7841 global commitinfo commitdata ctext
7842 global treediffs
7844 set info $commitinfo($ids)
7845 set diff [lindex $info 7]
7846 set difflines [split $diff "\n"]
7848 initblobdiffvars
7849 set treediff {}
7851 set inhdr 0
7852 foreach line $difflines {
7853 if {![string compare -length 5 "diff " $line]} {
7854 set inhdr 1
7855 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7856 # offset also accounts for the b/ prefix
7857 lappend treediff [string range $line 6 end]
7858 set inhdr 0
7862 set treediffs($ids) $treediff
7863 add_flist $treediff
7865 $ctext conf -state normal
7866 foreach line $difflines {
7867 parseblobdiffline $ids $line
7869 maybe_scroll_ctext 1
7870 $ctext conf -state disabled
7873 # If the filename (name) is under any of the passed filter paths
7874 # then return true to include the file in the listing.
7875 proc path_filter {filter name} {
7876 set worktree [gitworktree]
7877 foreach p $filter {
7878 set fq_p [file normalize $p]
7879 set fq_n [file normalize [file join $worktree $name]]
7880 if {[string match [file normalize $fq_p]* $fq_n]} {
7881 return 1
7884 return 0
7887 proc addtocflist {ids} {
7888 global treediffs
7890 add_flist $treediffs($ids)
7891 getblobdiffs $ids
7894 proc diffcmd {ids flags} {
7895 global log_showroot nullid nullid2 git_version
7897 set i [lsearch -exact $ids $nullid]
7898 set j [lsearch -exact $ids $nullid2]
7899 if {$i >= 0} {
7900 if {[llength $ids] > 1 && $j < 0} {
7901 # comparing working directory with some specific revision
7902 set cmd [concat | git diff-index $flags]
7903 if {$i == 0} {
7904 lappend cmd -R [lindex $ids 1]
7905 } else {
7906 lappend cmd [lindex $ids 0]
7908 } else {
7909 # comparing working directory with index
7910 set cmd [concat | git diff-files $flags]
7911 if {$j == 1} {
7912 lappend cmd -R
7915 } elseif {$j >= 0} {
7916 if {[package vcompare $git_version "1.7.2"] >= 0} {
7917 set flags "$flags --ignore-submodules=dirty"
7919 set cmd [concat | git diff-index --cached $flags]
7920 if {[llength $ids] > 1} {
7921 # comparing index with specific revision
7922 if {$j == 0} {
7923 lappend cmd -R [lindex $ids 1]
7924 } else {
7925 lappend cmd [lindex $ids 0]
7927 } else {
7928 # comparing index with HEAD
7929 lappend cmd HEAD
7931 } else {
7932 if {$log_showroot} {
7933 lappend flags --root
7935 set cmd [concat | git diff-tree -r $flags $ids]
7937 return $cmd
7940 proc gettreediffs {ids} {
7941 global treediff treepending limitdiffs vfilelimit curview
7943 set cmd [diffcmd $ids {--no-commit-id}]
7944 if {$limitdiffs && $vfilelimit($curview) ne {}} {
7945 set cmd [concat $cmd -- $vfilelimit($curview)]
7947 if {[catch {set gdtf [open $cmd r]}]} return
7949 set treepending $ids
7950 set treediff {}
7951 fconfigure $gdtf -blocking 0 -encoding binary
7952 filerun $gdtf [list gettreediffline $gdtf $ids]
7955 proc gettreediffline {gdtf ids} {
7956 global treediff treediffs treepending diffids diffmergeid
7957 global cmitmode vfilelimit curview limitdiffs perfile_attrs
7959 set nr 0
7960 set sublist {}
7961 set max 1000
7962 if {$perfile_attrs} {
7963 # cache_gitattr is slow, and even slower on win32 where we
7964 # have to invoke it for only about 30 paths at a time
7965 set max 500
7966 if {[tk windowingsystem] == "win32"} {
7967 set max 120
7970 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7971 set i [string first "\t" $line]
7972 if {$i >= 0} {
7973 set file [string range $line [expr {$i+1}] end]
7974 if {[string index $file 0] eq "\""} {
7975 set file [lindex $file 0]
7977 set file [encoding convertfrom $file]
7978 if {$file ne [lindex $treediff end]} {
7979 lappend treediff $file
7980 lappend sublist $file
7984 if {$perfile_attrs} {
7985 cache_gitattr encoding $sublist
7987 if {![eof $gdtf]} {
7988 return [expr {$nr >= $max? 2: 1}]
7990 close $gdtf
7991 set treediffs($ids) $treediff
7992 unset treepending
7993 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7994 gettree $diffids
7995 } elseif {$ids != $diffids} {
7996 if {![info exists diffmergeid]} {
7997 gettreediffs $diffids
7999 } else {
8000 addtocflist $ids
8002 return 0
8005 # empty string or positive integer
8006 proc diffcontextvalidate {v} {
8007 return [regexp {^(|[1-9][0-9]*)$} $v]
8010 proc diffcontextchange {n1 n2 op} {
8011 global diffcontextstring diffcontext
8013 if {[string is integer -strict $diffcontextstring]} {
8014 if {$diffcontextstring >= 0} {
8015 set diffcontext $diffcontextstring
8016 reselectline
8021 proc changeignorespace {} {
8022 reselectline
8025 proc changeworddiff {name ix op} {
8026 reselectline
8029 proc initblobdiffvars {} {
8030 global diffencoding targetline diffnparents
8031 global diffinhdr currdiffsubmod diffseehere
8032 set targetline {}
8033 set diffnparents 0
8034 set diffinhdr 0
8035 set diffencoding [get_path_encoding {}]
8036 set currdiffsubmod ""
8037 set diffseehere -1
8040 proc getblobdiffs {ids} {
8041 global blobdifffd diffids env
8042 global treediffs
8043 global diffcontext
8044 global ignorespace
8045 global worddiff
8046 global limitdiffs vfilelimit curview
8047 global git_version
8049 set textconv {}
8050 if {[package vcompare $git_version "1.6.1"] >= 0} {
8051 set textconv "--textconv"
8053 set submodule {}
8054 if {[package vcompare $git_version "1.6.6"] >= 0} {
8055 set submodule "--submodule"
8057 set cmd [diffcmd $ids "-p $textconv $submodule -C --cc --no-commit-id -U$diffcontext"]
8058 if {$ignorespace} {
8059 append cmd " -w"
8061 if {$worddiff ne [mc "Line diff"]} {
8062 append cmd " --word-diff=porcelain"
8064 if {$limitdiffs && $vfilelimit($curview) ne {}} {
8065 set cmd [concat $cmd -- $vfilelimit($curview)]
8067 if {[catch {set bdf [open $cmd r]} err]} {
8068 error_popup [mc "Error getting diffs: %s" $err]
8069 return
8071 fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
8072 set blobdifffd($ids) $bdf
8073 initblobdiffvars
8074 filerun $bdf [list getblobdiffline $bdf $diffids]
8077 proc savecmitpos {} {
8078 global ctext cmitmode
8080 if {$cmitmode eq "tree"} {
8081 return {}
8083 return [list target_scrollpos [$ctext index @0,0]]
8086 proc savectextpos {} {
8087 global ctext
8089 return [list target_scrollpos [$ctext index @0,0]]
8092 proc maybe_scroll_ctext {ateof} {
8093 global ctext target_scrollpos
8095 if {![info exists target_scrollpos]} return
8096 if {!$ateof} {
8097 set nlines [expr {[winfo height $ctext]
8098 / [font metrics textfont -linespace]}]
8099 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
8101 $ctext yview $target_scrollpos
8102 unset target_scrollpos
8105 proc setinlist {var i val} {
8106 global $var
8108 while {[llength [set $var]] < $i} {
8109 lappend $var {}
8111 if {[llength [set $var]] == $i} {
8112 lappend $var $val
8113 } else {
8114 lset $var $i $val
8118 proc makediffhdr {fname ids} {
8119 global ctext curdiffstart treediffs diffencoding
8120 global ctext_file_names jump_to_here targetline diffline
8122 set fname [encoding convertfrom $fname]
8123 set diffencoding [get_path_encoding $fname]
8124 set i [lsearch -exact $treediffs($ids) $fname]
8125 if {$i >= 0} {
8126 setinlist difffilestart $i $curdiffstart
8128 lset ctext_file_names end $fname
8129 set l [expr {(78 - [string length $fname]) / 2}]
8130 set pad [string range "----------------------------------------" 1 $l]
8131 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8132 set targetline {}
8133 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8134 set targetline [lindex $jump_to_here 1]
8136 set diffline 0
8139 proc blobdiffmaybeseehere {ateof} {
8140 global diffseehere
8141 if {$diffseehere >= 0} {
8142 mark_ctext_line [lindex [split $diffseehere .] 0]
8144 maybe_scroll_ctext $ateof
8147 proc getblobdiffline {bdf ids} {
8148 global diffids blobdifffd
8149 global ctext
8151 set nr 0
8152 $ctext conf -state normal
8153 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8154 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8155 # Older diff read. Abort it.
8156 catch {close $bdf}
8157 if {$ids != $diffids} {
8158 array unset blobdifffd $ids
8160 return 0
8162 parseblobdiffline $ids $line
8164 $ctext conf -state disabled
8165 blobdiffmaybeseehere [eof $bdf]
8166 if {[eof $bdf]} {
8167 catch {close $bdf}
8168 array unset blobdifffd $ids
8169 return 0
8171 return [expr {$nr >= 1000? 2: 1}]
8174 proc parseblobdiffline {ids line} {
8175 global ctext curdiffstart
8176 global diffnexthead diffnextnote difffilestart
8177 global ctext_file_names ctext_file_lines
8178 global diffinhdr treediffs mergemax diffnparents
8179 global diffencoding jump_to_here targetline diffline currdiffsubmod
8180 global worddiff diffseehere
8182 if {![string compare -length 5 "diff " $line]} {
8183 if {![regexp {^diff (--cc|--git) } $line m type]} {
8184 set line [encoding convertfrom $line]
8185 $ctext insert end "$line\n" hunksep
8186 continue
8188 # start of a new file
8189 set diffinhdr 1
8190 set currdiffsubmod ""
8192 $ctext insert end "\n"
8193 set curdiffstart [$ctext index "end - 1c"]
8194 lappend ctext_file_names ""
8195 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8196 $ctext insert end "\n" filesep
8198 if {$type eq "--cc"} {
8199 # start of a new file in a merge diff
8200 set fname [string range $line 10 end]
8201 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8202 lappend treediffs($ids) $fname
8203 add_flist [list $fname]
8206 } else {
8207 set line [string range $line 11 end]
8208 # If the name hasn't changed the length will be odd,
8209 # the middle char will be a space, and the two bits either
8210 # side will be a/name and b/name, or "a/name" and "b/name".
8211 # If the name has changed we'll get "rename from" and
8212 # "rename to" or "copy from" and "copy to" lines following
8213 # this, and we'll use them to get the filenames.
8214 # This complexity is necessary because spaces in the
8215 # filename(s) don't get escaped.
8216 set l [string length $line]
8217 set i [expr {$l / 2}]
8218 if {!(($l & 1) && [string index $line $i] eq " " &&
8219 [string range $line 2 [expr {$i - 1}]] eq \
8220 [string range $line [expr {$i + 3}] end])} {
8221 return
8223 # unescape if quoted and chop off the a/ from the front
8224 if {[string index $line 0] eq "\""} {
8225 set fname [string range [lindex $line 0] 2 end]
8226 } else {
8227 set fname [string range $line 2 [expr {$i - 1}]]
8230 makediffhdr $fname $ids
8232 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8233 set fname [encoding convertfrom [string range $line 16 end]]
8234 $ctext insert end "\n"
8235 set curdiffstart [$ctext index "end - 1c"]
8236 lappend ctext_file_names $fname
8237 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8238 $ctext insert end "$line\n" filesep
8239 set i [lsearch -exact $treediffs($ids) $fname]
8240 if {$i >= 0} {
8241 setinlist difffilestart $i $curdiffstart
8244 } elseif {![string compare -length 2 "@@" $line]} {
8245 regexp {^@@+} $line ats
8246 set line [encoding convertfrom $diffencoding $line]
8247 $ctext insert end "$line\n" hunksep
8248 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8249 set diffline $nl
8251 set diffnparents [expr {[string length $ats] - 1}]
8252 set diffinhdr 0
8254 } elseif {![string compare -length 10 "Submodule " $line]} {
8255 # start of a new submodule
8256 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8257 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8258 } else {
8259 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8261 if {$currdiffsubmod != $fname} {
8262 $ctext insert end "\n"; # Add newline after commit message
8264 if {$currdiffsubmod != $fname} {
8265 set curdiffstart [$ctext index "end - 1c"]
8266 lappend ctext_file_names ""
8267 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8268 makediffhdr $fname $ids
8269 set currdiffsubmod $fname
8270 $ctext insert end "\n$line\n" filesep
8271 } else {
8272 $ctext insert end "$line\n" filesep
8274 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " >" $line]} {
8275 set line [encoding convertfrom $diffencoding $line]
8276 $ctext insert end "$line\n" dresult
8277 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " <" $line]} {
8278 set line [encoding convertfrom $diffencoding $line]
8279 $ctext insert end "$line\n" d0
8280 } elseif {$diffinhdr} {
8281 if {![string compare -length 12 "rename from " $line]} {
8282 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8283 if {[string index $fname 0] eq "\""} {
8284 set fname [lindex $fname 0]
8286 set fname [encoding convertfrom $fname]
8287 set i [lsearch -exact $treediffs($ids) $fname]
8288 if {$i >= 0} {
8289 setinlist difffilestart $i $curdiffstart
8291 } elseif {![string compare -length 10 $line "rename to "] ||
8292 ![string compare -length 8 $line "copy to "]} {
8293 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8294 if {[string index $fname 0] eq "\""} {
8295 set fname [lindex $fname 0]
8297 makediffhdr $fname $ids
8298 } elseif {[string compare -length 3 $line "---"] == 0} {
8299 # do nothing
8300 return
8301 } elseif {[string compare -length 3 $line "+++"] == 0} {
8302 set diffinhdr 0
8303 return
8305 $ctext insert end "$line\n" filesep
8307 } else {
8308 set line [string map {\x1A ^Z} \
8309 [encoding convertfrom $diffencoding $line]]
8310 # parse the prefix - one ' ', '-' or '+' for each parent
8311 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8312 set tag [expr {$diffnparents > 1? "m": "d"}]
8313 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8314 set words_pre_markup ""
8315 set words_post_markup ""
8316 if {[string trim $prefix " -+"] eq {}} {
8317 # prefix only has " ", "-" and "+" in it: normal diff line
8318 set num [string first "-" $prefix]
8319 if {$dowords} {
8320 set line [string range $line 1 end]
8322 if {$num >= 0} {
8323 # removed line, first parent with line is $num
8324 if {$num >= $mergemax} {
8325 set num "max"
8327 if {$dowords && $worddiff eq [mc "Markup words"]} {
8328 $ctext insert end "\[-$line-\]" $tag$num
8329 } else {
8330 $ctext insert end "$line" $tag$num
8332 if {!$dowords} {
8333 $ctext insert end "\n" $tag$num
8335 } else {
8336 set tags {}
8337 if {[string first "+" $prefix] >= 0} {
8338 # added line
8339 lappend tags ${tag}result
8340 if {$diffnparents > 1} {
8341 set num [string first " " $prefix]
8342 if {$num >= 0} {
8343 if {$num >= $mergemax} {
8344 set num "max"
8346 lappend tags m$num
8349 set words_pre_markup "{+"
8350 set words_post_markup "+}"
8352 if {$targetline ne {}} {
8353 if {$diffline == $targetline} {
8354 set diffseehere [$ctext index "end - 1 chars"]
8355 set targetline {}
8356 } else {
8357 incr diffline
8360 if {$dowords && $worddiff eq [mc "Markup words"]} {
8361 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8362 } else {
8363 $ctext insert end "$line" $tags
8365 if {!$dowords} {
8366 $ctext insert end "\n" $tags
8369 } elseif {$dowords && $prefix eq "~"} {
8370 $ctext insert end "\n" {}
8371 } else {
8372 # "\ No newline at end of file",
8373 # or something else we don't recognize
8374 $ctext insert end "$line\n" hunksep
8379 proc changediffdisp {} {
8380 global ctext diffelide
8382 $ctext tag conf d0 -elide [lindex $diffelide 0]
8383 $ctext tag conf dresult -elide [lindex $diffelide 1]
8386 proc highlightfile {cline} {
8387 global cflist cflist_top
8389 if {![info exists cflist_top]} return
8391 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8392 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8393 $cflist see $cline.0
8394 set cflist_top $cline
8397 proc highlightfile_for_scrollpos {topidx} {
8398 global cmitmode difffilestart
8400 if {$cmitmode eq "tree"} return
8401 if {![info exists difffilestart]} return
8403 set top [lindex [split $topidx .] 0]
8404 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8405 highlightfile 0
8406 } else {
8407 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8411 proc prevfile {} {
8412 global difffilestart ctext cmitmode
8414 if {$cmitmode eq "tree"} return
8415 set prev 0.0
8416 set here [$ctext index @0,0]
8417 foreach loc $difffilestart {
8418 if {[$ctext compare $loc >= $here]} {
8419 $ctext yview $prev
8420 return
8422 set prev $loc
8424 $ctext yview $prev
8427 proc nextfile {} {
8428 global difffilestart ctext cmitmode
8430 if {$cmitmode eq "tree"} return
8431 set here [$ctext index @0,0]
8432 foreach loc $difffilestart {
8433 if {[$ctext compare $loc > $here]} {
8434 $ctext yview $loc
8435 return
8440 proc clear_ctext {{first 1.0}} {
8441 global ctext smarktop smarkbot
8442 global ctext_file_names ctext_file_lines
8443 global pendinglinks
8445 set l [lindex [split $first .] 0]
8446 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8447 set smarktop $l
8449 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8450 set smarkbot $l
8452 $ctext delete $first end
8453 if {$first eq "1.0"} {
8454 unset -nocomplain pendinglinks
8456 set ctext_file_names {}
8457 set ctext_file_lines {}
8460 proc settabs {{firstab {}}} {
8461 global firsttabstop tabstop ctext have_tk85
8463 if {$firstab ne {} && $have_tk85} {
8464 set firsttabstop $firstab
8466 set w [font measure textfont "0"]
8467 if {$firsttabstop != 0} {
8468 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8469 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8470 } elseif {$have_tk85 || $tabstop != 8} {
8471 $ctext conf -tabs [expr {$tabstop * $w}]
8472 } else {
8473 $ctext conf -tabs {}
8477 proc incrsearch {name ix op} {
8478 global ctext searchstring searchdirn
8480 if {[catch {$ctext index anchor}]} {
8481 # no anchor set, use start of selection, or of visible area
8482 set sel [$ctext tag ranges sel]
8483 if {$sel ne {}} {
8484 $ctext mark set anchor [lindex $sel 0]
8485 } elseif {$searchdirn eq "-forwards"} {
8486 $ctext mark set anchor @0,0
8487 } else {
8488 $ctext mark set anchor @0,[winfo height $ctext]
8491 if {$searchstring ne {}} {
8492 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8493 if {$here ne {}} {
8494 $ctext see $here
8495 set mend "$here + $mlen c"
8496 $ctext tag remove sel 1.0 end
8497 $ctext tag add sel $here $mend
8498 suppress_highlighting_file_for_current_scrollpos
8499 highlightfile_for_scrollpos $here
8502 rehighlight_search_results
8505 proc dosearch {} {
8506 global sstring ctext searchstring searchdirn
8508 focus $sstring
8509 $sstring icursor end
8510 set searchdirn -forwards
8511 if {$searchstring ne {}} {
8512 set sel [$ctext tag ranges sel]
8513 if {$sel ne {}} {
8514 set start "[lindex $sel 0] + 1c"
8515 } elseif {[catch {set start [$ctext index anchor]}]} {
8516 set start "@0,0"
8518 set match [$ctext search -count mlen -- $searchstring $start]
8519 $ctext tag remove sel 1.0 end
8520 if {$match eq {}} {
8521 bell
8522 return
8524 $ctext see $match
8525 suppress_highlighting_file_for_current_scrollpos
8526 highlightfile_for_scrollpos $match
8527 set mend "$match + $mlen c"
8528 $ctext tag add sel $match $mend
8529 $ctext mark unset anchor
8530 rehighlight_search_results
8534 proc dosearchback {} {
8535 global sstring ctext searchstring searchdirn
8537 focus $sstring
8538 $sstring icursor end
8539 set searchdirn -backwards
8540 if {$searchstring ne {}} {
8541 set sel [$ctext tag ranges sel]
8542 if {$sel ne {}} {
8543 set start [lindex $sel 0]
8544 } elseif {[catch {set start [$ctext index anchor]}]} {
8545 set start @0,[winfo height $ctext]
8547 set match [$ctext search -backwards -count ml -- $searchstring $start]
8548 $ctext tag remove sel 1.0 end
8549 if {$match eq {}} {
8550 bell
8551 return
8553 $ctext see $match
8554 suppress_highlighting_file_for_current_scrollpos
8555 highlightfile_for_scrollpos $match
8556 set mend "$match + $ml c"
8557 $ctext tag add sel $match $mend
8558 $ctext mark unset anchor
8559 rehighlight_search_results
8563 proc rehighlight_search_results {} {
8564 global ctext searchstring
8566 $ctext tag remove found 1.0 end
8567 $ctext tag remove currentsearchhit 1.0 end
8569 if {$searchstring ne {}} {
8570 searchmarkvisible 1
8574 proc searchmark {first last} {
8575 global ctext searchstring
8577 set sel [$ctext tag ranges sel]
8579 set mend $first.0
8580 while {1} {
8581 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8582 if {$match eq {}} break
8583 set mend "$match + $mlen c"
8584 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8585 $ctext tag add currentsearchhit $match $mend
8586 } else {
8587 $ctext tag add found $match $mend
8592 proc searchmarkvisible {doall} {
8593 global ctext smarktop smarkbot
8595 set topline [lindex [split [$ctext index @0,0] .] 0]
8596 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8597 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8598 # no overlap with previous
8599 searchmark $topline $botline
8600 set smarktop $topline
8601 set smarkbot $botline
8602 } else {
8603 if {$topline < $smarktop} {
8604 searchmark $topline [expr {$smarktop-1}]
8605 set smarktop $topline
8607 if {$botline > $smarkbot} {
8608 searchmark [expr {$smarkbot+1}] $botline
8609 set smarkbot $botline
8614 proc suppress_highlighting_file_for_current_scrollpos {} {
8615 global ctext suppress_highlighting_file_for_this_scrollpos
8617 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8620 proc scrolltext {f0 f1} {
8621 global searchstring cmitmode ctext
8622 global suppress_highlighting_file_for_this_scrollpos
8624 set topidx [$ctext index @0,0]
8625 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8626 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8627 highlightfile_for_scrollpos $topidx
8630 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8632 .bleft.bottom.sb set $f0 $f1
8633 if {$searchstring ne {}} {
8634 searchmarkvisible 0
8638 proc setcoords {} {
8639 global linespc charspc canvx0 canvy0
8640 global xspc1 xspc2 lthickness
8642 set linespc [font metrics mainfont -linespace]
8643 set charspc [font measure mainfont "m"]
8644 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8645 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8646 set lthickness [expr {int($linespc / 9) + 1}]
8647 set xspc1(0) $linespc
8648 set xspc2 $linespc
8651 proc redisplay {} {
8652 global canv
8653 global selectedline
8655 set ymax [lindex [$canv cget -scrollregion] 3]
8656 if {$ymax eq {} || $ymax == 0} return
8657 set span [$canv yview]
8658 clear_display
8659 setcanvscroll
8660 allcanvs yview moveto [lindex $span 0]
8661 drawvisible
8662 if {$selectedline ne {}} {
8663 selectline $selectedline 0
8664 allcanvs yview moveto [lindex $span 0]
8668 proc parsefont {f n} {
8669 global fontattr
8671 set fontattr($f,family) [lindex $n 0]
8672 set s [lindex $n 1]
8673 if {$s eq {} || $s == 0} {
8674 set s 10
8675 } elseif {$s < 0} {
8676 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8678 set fontattr($f,size) $s
8679 set fontattr($f,weight) normal
8680 set fontattr($f,slant) roman
8681 foreach style [lrange $n 2 end] {
8682 switch -- $style {
8683 "normal" -
8684 "bold" {set fontattr($f,weight) $style}
8685 "roman" -
8686 "italic" {set fontattr($f,slant) $style}
8691 proc fontflags {f {isbold 0}} {
8692 global fontattr
8694 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8695 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8696 -slant $fontattr($f,slant)]
8699 proc fontname {f} {
8700 global fontattr
8702 set n [list $fontattr($f,family) $fontattr($f,size)]
8703 if {$fontattr($f,weight) eq "bold"} {
8704 lappend n "bold"
8706 if {$fontattr($f,slant) eq "italic"} {
8707 lappend n "italic"
8709 return $n
8712 proc incrfont {inc} {
8713 global mainfont textfont ctext canv cflist showrefstop
8714 global stopped entries fontattr
8716 unmarkmatches
8717 set s $fontattr(mainfont,size)
8718 incr s $inc
8719 if {$s < 1} {
8720 set s 1
8722 set fontattr(mainfont,size) $s
8723 font config mainfont -size $s
8724 font config mainfontbold -size $s
8725 set mainfont [fontname mainfont]
8726 set s $fontattr(textfont,size)
8727 incr s $inc
8728 if {$s < 1} {
8729 set s 1
8731 set fontattr(textfont,size) $s
8732 font config textfont -size $s
8733 font config textfontbold -size $s
8734 set textfont [fontname textfont]
8735 setcoords
8736 settabs
8737 redisplay
8740 proc clearsha1 {} {
8741 global sha1entry sha1string
8742 if {[string length $sha1string] == 40} {
8743 $sha1entry delete 0 end
8747 proc sha1change {n1 n2 op} {
8748 global sha1string currentid sha1but
8749 if {$sha1string == {}
8750 || ([info exists currentid] && $sha1string == $currentid)} {
8751 set state disabled
8752 } else {
8753 set state normal
8755 if {[$sha1but cget -state] == $state} return
8756 if {$state == "normal"} {
8757 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8758 } else {
8759 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8763 proc gotocommit {} {
8764 global sha1string tagids headids curview varcid
8766 if {$sha1string == {}
8767 || ([info exists currentid] && $sha1string == $currentid)} return
8768 if {[info exists tagids($sha1string)]} {
8769 set id $tagids($sha1string)
8770 } elseif {[info exists headids($sha1string)]} {
8771 set id $headids($sha1string)
8772 } else {
8773 set id [string tolower $sha1string]
8774 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8775 set matches [longid $id]
8776 if {$matches ne {}} {
8777 if {[llength $matches] > 1} {
8778 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8779 return
8781 set id [lindex $matches 0]
8783 } else {
8784 if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8785 error_popup [mc "Revision %s is not known" $sha1string]
8786 return
8790 if {[commitinview $id $curview]} {
8791 selectline [rowofcommit $id] 1
8792 return
8794 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8795 set msg [mc "SHA1 id %s is not known" $sha1string]
8796 } else {
8797 set msg [mc "Revision %s is not in the current view" $sha1string]
8799 error_popup $msg
8802 proc lineenter {x y id} {
8803 global hoverx hovery hoverid hovertimer
8804 global commitinfo canv
8806 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8807 set hoverx $x
8808 set hovery $y
8809 set hoverid $id
8810 if {[info exists hovertimer]} {
8811 after cancel $hovertimer
8813 set hovertimer [after 500 linehover]
8814 $canv delete hover
8817 proc linemotion {x y id} {
8818 global hoverx hovery hoverid hovertimer
8820 if {[info exists hoverid] && $id == $hoverid} {
8821 set hoverx $x
8822 set hovery $y
8823 if {[info exists hovertimer]} {
8824 after cancel $hovertimer
8826 set hovertimer [after 500 linehover]
8830 proc lineleave {id} {
8831 global hoverid hovertimer canv
8833 if {[info exists hoverid] && $id == $hoverid} {
8834 $canv delete hover
8835 if {[info exists hovertimer]} {
8836 after cancel $hovertimer
8837 unset hovertimer
8839 unset hoverid
8843 proc linehover {} {
8844 global hoverx hovery hoverid hovertimer
8845 global canv linespc lthickness
8846 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8848 global commitinfo
8850 set text [lindex $commitinfo($hoverid) 0]
8851 set ymax [lindex [$canv cget -scrollregion] 3]
8852 if {$ymax == {}} return
8853 set yfrac [lindex [$canv yview] 0]
8854 set x [expr {$hoverx + 2 * $linespc}]
8855 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8856 set x0 [expr {$x - 2 * $lthickness}]
8857 set y0 [expr {$y - 2 * $lthickness}]
8858 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8859 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8860 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8861 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8862 -width 1 -tags hover]
8863 $canv raise $t
8864 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8865 -font mainfont -fill $linehoverfgcolor]
8866 $canv raise $t
8869 proc clickisonarrow {id y} {
8870 global lthickness
8872 set ranges [rowranges $id]
8873 set thresh [expr {2 * $lthickness + 6}]
8874 set n [expr {[llength $ranges] - 1}]
8875 for {set i 1} {$i < $n} {incr i} {
8876 set row [lindex $ranges $i]
8877 if {abs([yc $row] - $y) < $thresh} {
8878 return $i
8881 return {}
8884 proc arrowjump {id n y} {
8885 global canv
8887 # 1 <-> 2, 3 <-> 4, etc...
8888 set n [expr {(($n - 1) ^ 1) + 1}]
8889 set row [lindex [rowranges $id] $n]
8890 set yt [yc $row]
8891 set ymax [lindex [$canv cget -scrollregion] 3]
8892 if {$ymax eq {} || $ymax <= 0} return
8893 set view [$canv yview]
8894 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8895 set yfrac [expr {$yt / $ymax - $yspan / 2}]
8896 if {$yfrac < 0} {
8897 set yfrac 0
8899 allcanvs yview moveto $yfrac
8902 proc lineclick {x y id isnew} {
8903 global ctext commitinfo children canv thickerline curview
8905 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8906 unmarkmatches
8907 unselectline
8908 normalline
8909 $canv delete hover
8910 # draw this line thicker than normal
8911 set thickerline $id
8912 drawlines $id
8913 if {$isnew} {
8914 set ymax [lindex [$canv cget -scrollregion] 3]
8915 if {$ymax eq {}} return
8916 set yfrac [lindex [$canv yview] 0]
8917 set y [expr {$y + $yfrac * $ymax}]
8919 set dirn [clickisonarrow $id $y]
8920 if {$dirn ne {}} {
8921 arrowjump $id $dirn $y
8922 return
8925 if {$isnew} {
8926 addtohistory [list lineclick $x $y $id 0] savectextpos
8928 # fill the details pane with info about this line
8929 $ctext conf -state normal
8930 clear_ctext
8931 settabs 0
8932 $ctext insert end "[mc "Parent"]:\t"
8933 $ctext insert end $id link0
8934 setlink $id link0
8935 set info $commitinfo($id)
8936 $ctext insert end "\n\t[lindex $info 0]\n"
8937 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8938 set date [formatdate [lindex $info 2]]
8939 $ctext insert end "\t[mc "Date"]:\t$date\n"
8940 set kids $children($curview,$id)
8941 if {$kids ne {}} {
8942 $ctext insert end "\n[mc "Children"]:"
8943 set i 0
8944 foreach child $kids {
8945 incr i
8946 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8947 set info $commitinfo($child)
8948 $ctext insert end "\n\t"
8949 $ctext insert end $child link$i
8950 setlink $child link$i
8951 $ctext insert end "\n\t[lindex $info 0]"
8952 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8953 set date [formatdate [lindex $info 2]]
8954 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8957 maybe_scroll_ctext 1
8958 $ctext conf -state disabled
8959 init_flist {}
8962 proc normalline {} {
8963 global thickerline
8964 if {[info exists thickerline]} {
8965 set id $thickerline
8966 unset thickerline
8967 drawlines $id
8971 proc selbyid {id {isnew 1}} {
8972 global curview
8973 if {[commitinview $id $curview]} {
8974 selectline [rowofcommit $id] $isnew
8978 proc mstime {} {
8979 global startmstime
8980 if {![info exists startmstime]} {
8981 set startmstime [clock clicks -milliseconds]
8983 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8986 proc rowmenu {x y id} {
8987 global rowctxmenu selectedline rowmenuid curview
8988 global nullid nullid2 fakerowmenu mainhead markedid
8990 stopfinding
8991 set rowmenuid $id
8992 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8993 set state disabled
8994 } else {
8995 set state normal
8997 if {[info exists markedid] && $markedid ne $id} {
8998 set mstate normal
8999 } else {
9000 set mstate disabled
9002 if {$id ne $nullid && $id ne $nullid2} {
9003 set menu $rowctxmenu
9004 if {$mainhead ne {}} {
9005 $menu entryconfigure 8 -label [mc "Reset %s branch to here" $mainhead] -state normal
9006 } else {
9007 $menu entryconfigure 8 -label [mc "Detached head: can't reset" $mainhead] -state disabled
9009 $menu entryconfigure 10 -state $mstate
9010 $menu entryconfigure 11 -state $mstate
9011 $menu entryconfigure 12 -state $mstate
9012 } else {
9013 set menu $fakerowmenu
9015 $menu entryconfigure [mca "Diff this -> selected"] -state $state
9016 $menu entryconfigure [mca "Diff selected -> this"] -state $state
9017 $menu entryconfigure [mca "Make patch"] -state $state
9018 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
9019 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
9020 tk_popup $menu $x $y
9023 proc markhere {} {
9024 global rowmenuid markedid canv
9026 set markedid $rowmenuid
9027 make_idmark $markedid
9030 proc gotomark {} {
9031 global markedid
9033 if {[info exists markedid]} {
9034 selbyid $markedid
9038 proc replace_by_kids {l r} {
9039 global curview children
9041 set id [commitonrow $r]
9042 set l [lreplace $l 0 0]
9043 foreach kid $children($curview,$id) {
9044 lappend l [rowofcommit $kid]
9046 return [lsort -integer -decreasing -unique $l]
9049 proc find_common_desc {} {
9050 global markedid rowmenuid curview children
9052 if {![info exists markedid]} return
9053 if {![commitinview $markedid $curview] ||
9054 ![commitinview $rowmenuid $curview]} return
9055 #set t1 [clock clicks -milliseconds]
9056 set l1 [list [rowofcommit $markedid]]
9057 set l2 [list [rowofcommit $rowmenuid]]
9058 while 1 {
9059 set r1 [lindex $l1 0]
9060 set r2 [lindex $l2 0]
9061 if {$r1 eq {} || $r2 eq {}} break
9062 if {$r1 == $r2} {
9063 selectline $r1 1
9064 break
9066 if {$r1 > $r2} {
9067 set l1 [replace_by_kids $l1 $r1]
9068 } else {
9069 set l2 [replace_by_kids $l2 $r2]
9072 #set t2 [clock clicks -milliseconds]
9073 #puts "took [expr {$t2-$t1}]ms"
9076 proc compare_commits {} {
9077 global markedid rowmenuid curview children
9079 if {![info exists markedid]} return
9080 if {![commitinview $markedid $curview]} return
9081 addtohistory [list do_cmp_commits $markedid $rowmenuid]
9082 do_cmp_commits $markedid $rowmenuid
9085 proc getpatchid {id} {
9086 global patchids
9088 if {![info exists patchids($id)]} {
9089 set cmd [diffcmd [list $id] {-p --root}]
9090 # trim off the initial "|"
9091 set cmd [lrange $cmd 1 end]
9092 if {[catch {
9093 set x [eval exec $cmd | git patch-id]
9094 set patchids($id) [lindex $x 0]
9095 }]} {
9096 set patchids($id) "error"
9099 return $patchids($id)
9102 proc do_cmp_commits {a b} {
9103 global ctext curview parents children patchids commitinfo
9105 $ctext conf -state normal
9106 clear_ctext
9107 init_flist {}
9108 for {set i 0} {$i < 100} {incr i} {
9109 set skipa 0
9110 set skipb 0
9111 if {[llength $parents($curview,$a)] > 1} {
9112 appendshortlink $a [mc "Skipping merge commit "] "\n"
9113 set skipa 1
9114 } else {
9115 set patcha [getpatchid $a]
9117 if {[llength $parents($curview,$b)] > 1} {
9118 appendshortlink $b [mc "Skipping merge commit "] "\n"
9119 set skipb 1
9120 } else {
9121 set patchb [getpatchid $b]
9123 if {!$skipa && !$skipb} {
9124 set heada [lindex $commitinfo($a) 0]
9125 set headb [lindex $commitinfo($b) 0]
9126 if {$patcha eq "error"} {
9127 appendshortlink $a [mc "Error getting patch ID for "] \
9128 [mc " - stopping\n"]
9129 break
9131 if {$patchb eq "error"} {
9132 appendshortlink $b [mc "Error getting patch ID for "] \
9133 [mc " - stopping\n"]
9134 break
9136 if {$patcha eq $patchb} {
9137 if {$heada eq $headb} {
9138 appendshortlink $a [mc "Commit "]
9139 appendshortlink $b " == " " $heada\n"
9140 } else {
9141 appendshortlink $a [mc "Commit "] " $heada\n"
9142 appendshortlink $b [mc " is the same patch as\n "] \
9143 " $headb\n"
9145 set skipa 1
9146 set skipb 1
9147 } else {
9148 $ctext insert end "\n"
9149 appendshortlink $a [mc "Commit "] " $heada\n"
9150 appendshortlink $b [mc " differs from\n "] \
9151 " $headb\n"
9152 $ctext insert end [mc "Diff of commits:\n\n"]
9153 $ctext conf -state disabled
9154 update
9155 diffcommits $a $b
9156 return
9159 if {$skipa} {
9160 set kids [real_children $curview,$a]
9161 if {[llength $kids] != 1} {
9162 $ctext insert end "\n"
9163 appendshortlink $a [mc "Commit "] \
9164 [mc " has %s children - stopping\n" [llength $kids]]
9165 break
9167 set a [lindex $kids 0]
9169 if {$skipb} {
9170 set kids [real_children $curview,$b]
9171 if {[llength $kids] != 1} {
9172 appendshortlink $b [mc "Commit "] \
9173 [mc " has %s children - stopping\n" [llength $kids]]
9174 break
9176 set b [lindex $kids 0]
9179 $ctext conf -state disabled
9182 proc diffcommits {a b} {
9183 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9185 set tmpdir [gitknewtmpdir]
9186 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9187 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9188 if {[catch {
9189 exec git diff-tree -p --pretty $a >$fna
9190 exec git diff-tree -p --pretty $b >$fnb
9191 } err]} {
9192 error_popup [mc "Error writing commit to file: %s" $err]
9193 return
9195 if {[catch {
9196 set fd [open "| diff -U$diffcontext $fna $fnb" r]
9197 } err]} {
9198 error_popup [mc "Error diffing commits: %s" $err]
9199 return
9201 set diffids [list commits $a $b]
9202 set blobdifffd($diffids) $fd
9203 set diffinhdr 0
9204 set currdiffsubmod ""
9205 filerun $fd [list getblobdiffline $fd $diffids]
9208 proc diffvssel {dirn} {
9209 global rowmenuid selectedline
9211 if {$selectedline eq {}} return
9212 if {$dirn} {
9213 set oldid [commitonrow $selectedline]
9214 set newid $rowmenuid
9215 } else {
9216 set oldid $rowmenuid
9217 set newid [commitonrow $selectedline]
9219 addtohistory [list doseldiff $oldid $newid] savectextpos
9220 doseldiff $oldid $newid
9223 proc diffvsmark {dirn} {
9224 global rowmenuid markedid
9226 if {![info exists markedid]} return
9227 if {$dirn} {
9228 set oldid $markedid
9229 set newid $rowmenuid
9230 } else {
9231 set oldid $rowmenuid
9232 set newid $markedid
9234 addtohistory [list doseldiff $oldid $newid] savectextpos
9235 doseldiff $oldid $newid
9238 proc doseldiff {oldid newid} {
9239 global ctext
9240 global commitinfo
9242 $ctext conf -state normal
9243 clear_ctext
9244 init_flist [mc "Top"]
9245 $ctext insert end "[mc "From"] "
9246 $ctext insert end $oldid link0
9247 setlink $oldid link0
9248 $ctext insert end "\n "
9249 $ctext insert end [lindex $commitinfo($oldid) 0]
9250 $ctext insert end "\n\n[mc "To"] "
9251 $ctext insert end $newid link1
9252 setlink $newid link1
9253 $ctext insert end "\n "
9254 $ctext insert end [lindex $commitinfo($newid) 0]
9255 $ctext insert end "\n"
9256 $ctext conf -state disabled
9257 $ctext tag remove found 1.0 end
9258 startdiff [list $oldid $newid]
9261 proc mkpatch {} {
9262 global rowmenuid currentid commitinfo patchtop patchnum NS
9264 if {![info exists currentid]} return
9265 set oldid $currentid
9266 set oldhead [lindex $commitinfo($oldid) 0]
9267 set newid $rowmenuid
9268 set newhead [lindex $commitinfo($newid) 0]
9269 set top .patch
9270 set patchtop $top
9271 catch {destroy $top}
9272 ttk_toplevel $top
9273 make_transient $top .
9274 ${NS}::label $top.title -text [mc "Generate patch"]
9275 grid $top.title - -pady 10
9276 ${NS}::label $top.from -text [mc "From:"]
9277 ${NS}::entry $top.fromsha1 -width 40
9278 $top.fromsha1 insert 0 $oldid
9279 $top.fromsha1 conf -state readonly
9280 grid $top.from $top.fromsha1 -sticky w
9281 ${NS}::entry $top.fromhead -width 60
9282 $top.fromhead insert 0 $oldhead
9283 $top.fromhead conf -state readonly
9284 grid x $top.fromhead -sticky w
9285 ${NS}::label $top.to -text [mc "To:"]
9286 ${NS}::entry $top.tosha1 -width 40
9287 $top.tosha1 insert 0 $newid
9288 $top.tosha1 conf -state readonly
9289 grid $top.to $top.tosha1 -sticky w
9290 ${NS}::entry $top.tohead -width 60
9291 $top.tohead insert 0 $newhead
9292 $top.tohead conf -state readonly
9293 grid x $top.tohead -sticky w
9294 ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9295 grid $top.rev x -pady 10 -padx 5
9296 ${NS}::label $top.flab -text [mc "Output file:"]
9297 ${NS}::entry $top.fname -width 60
9298 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9299 incr patchnum
9300 grid $top.flab $top.fname -sticky w
9301 ${NS}::frame $top.buts
9302 ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9303 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9304 bind $top <Key-Return> mkpatchgo
9305 bind $top <Key-Escape> mkpatchcan
9306 grid $top.buts.gen $top.buts.can
9307 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9308 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9309 grid $top.buts - -pady 10 -sticky ew
9310 focus $top.fname
9313 proc mkpatchrev {} {
9314 global patchtop
9316 set oldid [$patchtop.fromsha1 get]
9317 set oldhead [$patchtop.fromhead get]
9318 set newid [$patchtop.tosha1 get]
9319 set newhead [$patchtop.tohead get]
9320 foreach e [list fromsha1 fromhead tosha1 tohead] \
9321 v [list $newid $newhead $oldid $oldhead] {
9322 $patchtop.$e conf -state normal
9323 $patchtop.$e delete 0 end
9324 $patchtop.$e insert 0 $v
9325 $patchtop.$e conf -state readonly
9329 proc mkpatchgo {} {
9330 global patchtop nullid nullid2
9332 set oldid [$patchtop.fromsha1 get]
9333 set newid [$patchtop.tosha1 get]
9334 set fname [$patchtop.fname get]
9335 set cmd [diffcmd [list $oldid $newid] -p]
9336 # trim off the initial "|"
9337 set cmd [lrange $cmd 1 end]
9338 lappend cmd >$fname &
9339 if {[catch {eval exec $cmd} err]} {
9340 error_popup "[mc "Error creating patch:"] $err" $patchtop
9342 catch {destroy $patchtop}
9343 unset patchtop
9346 proc mkpatchcan {} {
9347 global patchtop
9349 catch {destroy $patchtop}
9350 unset patchtop
9353 proc mktag {} {
9354 global rowmenuid mktagtop commitinfo NS
9356 set top .maketag
9357 set mktagtop $top
9358 catch {destroy $top}
9359 ttk_toplevel $top
9360 make_transient $top .
9361 ${NS}::label $top.title -text [mc "Create tag"]
9362 grid $top.title - -pady 10
9363 ${NS}::label $top.id -text [mc "ID:"]
9364 ${NS}::entry $top.sha1 -width 40
9365 $top.sha1 insert 0 $rowmenuid
9366 $top.sha1 conf -state readonly
9367 grid $top.id $top.sha1 -sticky w
9368 ${NS}::entry $top.head -width 60
9369 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9370 $top.head conf -state readonly
9371 grid x $top.head -sticky w
9372 ${NS}::label $top.tlab -text [mc "Tag name:"]
9373 ${NS}::entry $top.tag -width 60
9374 grid $top.tlab $top.tag -sticky w
9375 ${NS}::label $top.op -text [mc "Tag message is optional"]
9376 grid $top.op -columnspan 2 -sticky we
9377 ${NS}::label $top.mlab -text [mc "Tag message:"]
9378 ${NS}::entry $top.msg -width 60
9379 grid $top.mlab $top.msg -sticky w
9380 ${NS}::frame $top.buts
9381 ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9382 ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9383 bind $top <Key-Return> mktaggo
9384 bind $top <Key-Escape> mktagcan
9385 grid $top.buts.gen $top.buts.can
9386 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9387 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9388 grid $top.buts - -pady 10 -sticky ew
9389 focus $top.tag
9392 proc domktag {} {
9393 global mktagtop env tagids idtags
9395 set id [$mktagtop.sha1 get]
9396 set tag [$mktagtop.tag get]
9397 set msg [$mktagtop.msg get]
9398 if {$tag == {}} {
9399 error_popup [mc "No tag name specified"] $mktagtop
9400 return 0
9402 if {[info exists tagids($tag)]} {
9403 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9404 return 0
9406 if {[catch {
9407 if {$msg != {}} {
9408 exec git tag -a -m $msg $tag $id
9409 } else {
9410 exec git tag $tag $id
9412 } err]} {
9413 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9414 return 0
9417 set tagids($tag) $id
9418 lappend idtags($id) $tag
9419 redrawtags $id
9420 addedtag $id
9421 dispneartags 0
9422 run refill_reflist
9423 return 1
9426 proc redrawtags {id} {
9427 global canv linehtag idpos currentid curview cmitlisted markedid
9428 global canvxmax iddrawn circleitem mainheadid circlecolors
9429 global mainheadcirclecolor
9431 if {![commitinview $id $curview]} return
9432 if {![info exists iddrawn($id)]} return
9433 set row [rowofcommit $id]
9434 if {$id eq $mainheadid} {
9435 set ofill $mainheadcirclecolor
9436 } else {
9437 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9439 $canv itemconf $circleitem($row) -fill $ofill
9440 $canv delete tag.$id
9441 set xt [eval drawtags $id $idpos($id)]
9442 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9443 set text [$canv itemcget $linehtag($id) -text]
9444 set font [$canv itemcget $linehtag($id) -font]
9445 set xr [expr {$xt + [font measure $font $text]}]
9446 if {$xr > $canvxmax} {
9447 set canvxmax $xr
9448 setcanvscroll
9450 if {[info exists currentid] && $currentid == $id} {
9451 make_secsel $id
9453 if {[info exists markedid] && $markedid eq $id} {
9454 make_idmark $id
9458 proc mktagcan {} {
9459 global mktagtop
9461 catch {destroy $mktagtop}
9462 unset mktagtop
9465 proc mktaggo {} {
9466 if {![domktag]} return
9467 mktagcan
9470 proc copyreference {} {
9471 global rowmenuid autosellen
9473 set format "%h (\"%s\", %ad)"
9474 set cmd [list git show -s --pretty=format:$format --date=short]
9475 if {$autosellen < 40} {
9476 lappend cmd --abbrev=$autosellen
9478 set reference [eval exec $cmd $rowmenuid]
9480 clipboard clear
9481 clipboard append $reference
9484 proc writecommit {} {
9485 global rowmenuid wrcomtop commitinfo wrcomcmd NS
9487 set top .writecommit
9488 set wrcomtop $top
9489 catch {destroy $top}
9490 ttk_toplevel $top
9491 make_transient $top .
9492 ${NS}::label $top.title -text [mc "Write commit to file"]
9493 grid $top.title - -pady 10
9494 ${NS}::label $top.id -text [mc "ID:"]
9495 ${NS}::entry $top.sha1 -width 40
9496 $top.sha1 insert 0 $rowmenuid
9497 $top.sha1 conf -state readonly
9498 grid $top.id $top.sha1 -sticky w
9499 ${NS}::entry $top.head -width 60
9500 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9501 $top.head conf -state readonly
9502 grid x $top.head -sticky w
9503 ${NS}::label $top.clab -text [mc "Command:"]
9504 ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9505 grid $top.clab $top.cmd -sticky w -pady 10
9506 ${NS}::label $top.flab -text [mc "Output file:"]
9507 ${NS}::entry $top.fname -width 60
9508 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9509 grid $top.flab $top.fname -sticky w
9510 ${NS}::frame $top.buts
9511 ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9512 ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9513 bind $top <Key-Return> wrcomgo
9514 bind $top <Key-Escape> wrcomcan
9515 grid $top.buts.gen $top.buts.can
9516 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9517 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9518 grid $top.buts - -pady 10 -sticky ew
9519 focus $top.fname
9522 proc wrcomgo {} {
9523 global wrcomtop
9525 set id [$wrcomtop.sha1 get]
9526 set cmd "echo $id | [$wrcomtop.cmd get]"
9527 set fname [$wrcomtop.fname get]
9528 if {[catch {exec sh -c $cmd >$fname &} err]} {
9529 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9531 catch {destroy $wrcomtop}
9532 unset wrcomtop
9535 proc wrcomcan {} {
9536 global wrcomtop
9538 catch {destroy $wrcomtop}
9539 unset wrcomtop
9542 proc mkbranch {} {
9543 global NS rowmenuid
9545 set top .branchdialog
9547 set val(name) ""
9548 set val(id) $rowmenuid
9549 set val(command) [list mkbrgo $top]
9551 set ui(title) [mc "Create branch"]
9552 set ui(accept) [mc "Create"]
9554 branchdia $top val ui
9557 proc mvbranch {} {
9558 global NS
9559 global headmenuid headmenuhead
9561 set top .branchdialog
9563 set val(name) $headmenuhead
9564 set val(id) $headmenuid
9565 set val(command) [list mvbrgo $top $headmenuhead]
9567 set ui(title) [mc "Rename branch %s" $headmenuhead]
9568 set ui(accept) [mc "Rename"]
9570 branchdia $top val ui
9573 proc branchdia {top valvar uivar} {
9574 global NS commitinfo
9575 upvar $valvar val $uivar ui
9577 catch {destroy $top}
9578 ttk_toplevel $top
9579 make_transient $top .
9580 ${NS}::label $top.title -text $ui(title)
9581 grid $top.title - -pady 10
9582 ${NS}::label $top.id -text [mc "ID:"]
9583 ${NS}::entry $top.sha1 -width 40
9584 $top.sha1 insert 0 $val(id)
9585 $top.sha1 conf -state readonly
9586 grid $top.id $top.sha1 -sticky w
9587 ${NS}::entry $top.head -width 60
9588 $top.head insert 0 [lindex $commitinfo($val(id)) 0]
9589 $top.head conf -state readonly
9590 grid x $top.head -sticky ew
9591 grid columnconfigure $top 1 -weight 1
9592 ${NS}::label $top.nlab -text [mc "Name:"]
9593 ${NS}::entry $top.name -width 40
9594 $top.name insert 0 $val(name)
9595 grid $top.nlab $top.name -sticky w
9596 ${NS}::frame $top.buts
9597 ${NS}::button $top.buts.go -text $ui(accept) -command $val(command)
9598 ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9599 bind $top <Key-Return> $val(command)
9600 bind $top <Key-Escape> "catch {destroy $top}"
9601 grid $top.buts.go $top.buts.can
9602 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9603 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9604 grid $top.buts - -pady 10 -sticky ew
9605 focus $top.name
9608 proc mkbrgo {top} {
9609 global headids idheads
9611 set name [$top.name get]
9612 set id [$top.sha1 get]
9613 set cmdargs {}
9614 set old_id {}
9615 if {$name eq {}} {
9616 error_popup [mc "Please specify a name for the new branch"] $top
9617 return
9619 if {[info exists headids($name)]} {
9620 if {![confirm_popup [mc \
9621 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9622 return
9624 set old_id $headids($name)
9625 lappend cmdargs -f
9627 catch {destroy $top}
9628 lappend cmdargs $name $id
9629 nowbusy newbranch
9630 update
9631 if {[catch {
9632 eval exec git branch $cmdargs
9633 } err]} {
9634 notbusy newbranch
9635 error_popup $err
9636 } else {
9637 notbusy newbranch
9638 if {$old_id ne {}} {
9639 movehead $id $name
9640 movedhead $id $name
9641 redrawtags $old_id
9642 redrawtags $id
9643 } else {
9644 set headids($name) $id
9645 lappend idheads($id) $name
9646 addedhead $id $name
9647 redrawtags $id
9649 dispneartags 0
9650 run refill_reflist
9654 proc mvbrgo {top prevname} {
9655 global headids idheads mainhead mainheadid
9657 set name [$top.name get]
9658 set id [$top.sha1 get]
9659 set cmdargs {}
9660 if {$name eq $prevname} {
9661 catch {destroy $top}
9662 return
9664 if {$name eq {}} {
9665 error_popup [mc "Please specify a new name for the branch"] $top
9666 return
9668 catch {destroy $top}
9669 lappend cmdargs -m $prevname $name
9670 nowbusy renamebranch
9671 update
9672 if {[catch {
9673 eval exec git branch $cmdargs
9674 } err]} {
9675 notbusy renamebranch
9676 error_popup $err
9677 } else {
9678 notbusy renamebranch
9679 removehead $id $prevname
9680 removedhead $id $prevname
9681 set headids($name) $id
9682 lappend idheads($id) $name
9683 addedhead $id $name
9684 if {$prevname eq $mainhead} {
9685 set mainhead $name
9686 set mainheadid $id
9688 redrawtags $id
9689 dispneartags 0
9690 run refill_reflist
9694 proc exec_citool {tool_args {baseid {}}} {
9695 global commitinfo env
9697 set save_env [array get env GIT_AUTHOR_*]
9699 if {$baseid ne {}} {
9700 if {![info exists commitinfo($baseid)]} {
9701 getcommit $baseid
9703 set author [lindex $commitinfo($baseid) 1]
9704 set date [lindex $commitinfo($baseid) 2]
9705 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9706 $author author name email]
9707 && $date ne {}} {
9708 set env(GIT_AUTHOR_NAME) $name
9709 set env(GIT_AUTHOR_EMAIL) $email
9710 set env(GIT_AUTHOR_DATE) $date
9714 eval exec git citool $tool_args &
9716 array unset env GIT_AUTHOR_*
9717 array set env $save_env
9720 proc cherrypick {} {
9721 global rowmenuid curview
9722 global mainhead mainheadid
9723 global gitdir
9725 set oldhead [exec git rev-parse HEAD]
9726 set dheads [descheads $rowmenuid]
9727 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9728 set ok [confirm_popup [mc "Commit %s is already\
9729 included in branch %s -- really re-apply it?" \
9730 [string range $rowmenuid 0 7] $mainhead]]
9731 if {!$ok} return
9733 nowbusy cherrypick [mc "Cherry-picking"]
9734 update
9735 # Unfortunately git-cherry-pick writes stuff to stderr even when
9736 # no error occurs, and exec takes that as an indication of error...
9737 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9738 notbusy cherrypick
9739 if {[regexp -line \
9740 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9741 $err msg fname]} {
9742 error_popup [mc "Cherry-pick failed because of local changes\
9743 to file '%s'.\nPlease commit, reset or stash\
9744 your changes and try again." $fname]
9745 } elseif {[regexp -line \
9746 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9747 $err]} {
9748 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9749 conflict.\nDo you wish to run git citool to\
9750 resolve it?"]]} {
9751 # Force citool to read MERGE_MSG
9752 file delete [file join $gitdir "GITGUI_MSG"]
9753 exec_citool {} $rowmenuid
9755 } else {
9756 error_popup $err
9758 run updatecommits
9759 return
9761 set newhead [exec git rev-parse HEAD]
9762 if {$newhead eq $oldhead} {
9763 notbusy cherrypick
9764 error_popup [mc "No changes committed"]
9765 return
9767 addnewchild $newhead $oldhead
9768 if {[commitinview $oldhead $curview]} {
9769 # XXX this isn't right if we have a path limit...
9770 insertrow $newhead $oldhead $curview
9771 if {$mainhead ne {}} {
9772 movehead $newhead $mainhead
9773 movedhead $newhead $mainhead
9775 set mainheadid $newhead
9776 redrawtags $oldhead
9777 redrawtags $newhead
9778 selbyid $newhead
9780 notbusy cherrypick
9783 proc revert {} {
9784 global rowmenuid curview
9785 global mainhead mainheadid
9786 global gitdir
9788 set oldhead [exec git rev-parse HEAD]
9789 set dheads [descheads $rowmenuid]
9790 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9791 set ok [confirm_popup [mc "Commit %s is not\
9792 included in branch %s -- really revert it?" \
9793 [string range $rowmenuid 0 7] $mainhead]]
9794 if {!$ok} return
9796 nowbusy revert [mc "Reverting"]
9797 update
9799 if [catch {exec git revert --no-edit $rowmenuid} err] {
9800 notbusy revert
9801 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9802 $err match files] {
9803 regsub {\n( |\t)+} $files "\n" files
9804 error_popup [mc "Revert failed because of local changes to\
9805 the following files:%s Please commit, reset or stash \
9806 your changes and try again." $files]
9807 } elseif [regexp {error: could not revert} $err] {
9808 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9809 Do you wish to run git citool to resolve it?"]] {
9810 # Force citool to read MERGE_MSG
9811 file delete [file join $gitdir "GITGUI_MSG"]
9812 exec_citool {} $rowmenuid
9814 } else { error_popup $err }
9815 run updatecommits
9816 return
9819 set newhead [exec git rev-parse HEAD]
9820 if { $newhead eq $oldhead } {
9821 notbusy revert
9822 error_popup [mc "No changes committed"]
9823 return
9826 addnewchild $newhead $oldhead
9828 if [commitinview $oldhead $curview] {
9829 # XXX this isn't right if we have a path limit...
9830 insertrow $newhead $oldhead $curview
9831 if {$mainhead ne {}} {
9832 movehead $newhead $mainhead
9833 movedhead $newhead $mainhead
9835 set mainheadid $newhead
9836 redrawtags $oldhead
9837 redrawtags $newhead
9838 selbyid $newhead
9841 notbusy revert
9844 proc resethead {} {
9845 global mainhead rowmenuid confirm_ok resettype NS
9847 set confirm_ok 0
9848 set w ".confirmreset"
9849 ttk_toplevel $w
9850 make_transient $w .
9851 wm title $w [mc "Confirm reset"]
9852 ${NS}::label $w.m -text \
9853 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9854 pack $w.m -side top -fill x -padx 20 -pady 20
9855 ${NS}::labelframe $w.f -text [mc "Reset type:"]
9856 set resettype mixed
9857 ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9858 -text [mc "Soft: Leave working tree and index untouched"]
9859 grid $w.f.soft -sticky w
9860 ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9861 -text [mc "Mixed: Leave working tree untouched, reset index"]
9862 grid $w.f.mixed -sticky w
9863 ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9864 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9865 grid $w.f.hard -sticky w
9866 pack $w.f -side top -fill x -padx 4
9867 ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9868 pack $w.ok -side left -fill x -padx 20 -pady 20
9869 ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9870 bind $w <Key-Escape> [list destroy $w]
9871 pack $w.cancel -side right -fill x -padx 20 -pady 20
9872 bind $w <Visibility> "grab $w; focus $w"
9873 tkwait window $w
9874 if {!$confirm_ok} return
9875 if {[catch {set fd [open \
9876 [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9877 error_popup $err
9878 } else {
9879 dohidelocalchanges
9880 filerun $fd [list readresetstat $fd]
9881 nowbusy reset [mc "Resetting"]
9882 selbyid $rowmenuid
9886 proc readresetstat {fd} {
9887 global mainhead mainheadid showlocalchanges rprogcoord
9889 if {[gets $fd line] >= 0} {
9890 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9891 set rprogcoord [expr {1.0 * $m / $n}]
9892 adjustprogress
9894 return 1
9896 set rprogcoord 0
9897 adjustprogress
9898 notbusy reset
9899 if {[catch {close $fd} err]} {
9900 error_popup $err
9902 set oldhead $mainheadid
9903 set newhead [exec git rev-parse HEAD]
9904 if {$newhead ne $oldhead} {
9905 movehead $newhead $mainhead
9906 movedhead $newhead $mainhead
9907 set mainheadid $newhead
9908 redrawtags $oldhead
9909 redrawtags $newhead
9911 if {$showlocalchanges} {
9912 doshowlocalchanges
9914 return 0
9917 # context menu for a head
9918 proc headmenu {x y id head} {
9919 global headmenuid headmenuhead headctxmenu mainhead headids
9921 stopfinding
9922 set headmenuid $id
9923 set headmenuhead $head
9924 array set state {0 normal 1 normal 2 normal}
9925 if {[string match "remotes/*" $head]} {
9926 set localhead [string range $head [expr [string last / $head] + 1] end]
9927 if {[info exists headids($localhead)]} {
9928 set state(0) disabled
9930 array set state {1 disabled 2 disabled}
9932 if {$head eq $mainhead} {
9933 array set state {0 disabled 2 disabled}
9935 foreach i {0 1 2} {
9936 $headctxmenu entryconfigure $i -state $state($i)
9938 tk_popup $headctxmenu $x $y
9941 proc cobranch {} {
9942 global headmenuid headmenuhead headids
9943 global showlocalchanges
9945 # check the tree is clean first??
9946 set newhead $headmenuhead
9947 set command [list | git checkout]
9948 if {[string match "remotes/*" $newhead]} {
9949 set remote $newhead
9950 set newhead [string range $newhead [expr [string last / $newhead] + 1] end]
9951 # The following check is redundant - the menu option should
9952 # be disabled to begin with...
9953 if {[info exists headids($newhead)]} {
9954 error_popup [mc "A local branch named %s exists already" $newhead]
9955 return
9957 lappend command -b $newhead --track $remote
9958 } else {
9959 lappend command $newhead
9961 lappend command 2>@1
9962 nowbusy checkout [mc "Checking out"]
9963 update
9964 dohidelocalchanges
9965 if {[catch {
9966 set fd [open $command r]
9967 } err]} {
9968 notbusy checkout
9969 error_popup $err
9970 if {$showlocalchanges} {
9971 dodiffindex
9973 } else {
9974 filerun $fd [list readcheckoutstat $fd $newhead $headmenuid]
9978 proc readcheckoutstat {fd newhead newheadid} {
9979 global mainhead mainheadid headids idheads showlocalchanges progresscoords
9980 global viewmainheadid curview
9982 if {[gets $fd line] >= 0} {
9983 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9984 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9985 adjustprogress
9987 return 1
9989 set progresscoords {0 0}
9990 adjustprogress
9991 notbusy checkout
9992 if {[catch {close $fd} err]} {
9993 error_popup $err
9994 return
9996 set oldmainid $mainheadid
9997 if {! [info exists headids($newhead)]} {
9998 set headids($newhead) $newheadid
9999 lappend idheads($newheadid) $newhead
10000 addedhead $newheadid $newhead
10002 set mainhead $newhead
10003 set mainheadid $newheadid
10004 set viewmainheadid($curview) $newheadid
10005 redrawtags $oldmainid
10006 redrawtags $newheadid
10007 selbyid $newheadid
10008 if {$showlocalchanges} {
10009 dodiffindex
10013 proc rmbranch {} {
10014 global headmenuid headmenuhead mainhead
10015 global idheads
10017 set head $headmenuhead
10018 set id $headmenuid
10019 # this check shouldn't be needed any more...
10020 if {$head eq $mainhead} {
10021 error_popup [mc "Cannot delete the currently checked-out branch"]
10022 return
10024 set dheads [descheads $id]
10025 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
10026 # the stuff on this branch isn't on any other branch
10027 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
10028 branch.\nReally delete branch %s?" $head $head]]} return
10030 nowbusy rmbranch
10031 update
10032 if {[catch {exec git branch -D $head} err]} {
10033 notbusy rmbranch
10034 error_popup $err
10035 return
10037 removehead $id $head
10038 removedhead $id $head
10039 redrawtags $id
10040 notbusy rmbranch
10041 dispneartags 0
10042 run refill_reflist
10045 # Display a list of tags and heads
10046 proc showrefs {} {
10047 global showrefstop bgcolor fgcolor selectbgcolor NS
10048 global bglist fglist reflistfilter reflist maincursor
10050 set top .showrefs
10051 set showrefstop $top
10052 if {[winfo exists $top]} {
10053 raise $top
10054 refill_reflist
10055 return
10057 ttk_toplevel $top
10058 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
10059 make_transient $top .
10060 text $top.list -background $bgcolor -foreground $fgcolor \
10061 -selectbackground $selectbgcolor -font mainfont \
10062 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
10063 -width 30 -height 20 -cursor $maincursor \
10064 -spacing1 1 -spacing3 1 -state disabled
10065 $top.list tag configure highlight -background $selectbgcolor
10066 if {![lsearch -exact $bglist $top.list]} {
10067 lappend bglist $top.list
10068 lappend fglist $top.list
10070 ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
10071 ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
10072 grid $top.list $top.ysb -sticky nsew
10073 grid $top.xsb x -sticky ew
10074 ${NS}::frame $top.f
10075 ${NS}::label $top.f.l -text "[mc "Filter"]: "
10076 ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
10077 set reflistfilter "*"
10078 trace add variable reflistfilter write reflistfilter_change
10079 pack $top.f.e -side right -fill x -expand 1
10080 pack $top.f.l -side left
10081 grid $top.f - -sticky ew -pady 2
10082 ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
10083 bind $top <Key-Escape> [list destroy $top]
10084 grid $top.close -
10085 grid columnconfigure $top 0 -weight 1
10086 grid rowconfigure $top 0 -weight 1
10087 bind $top.list <1> {break}
10088 bind $top.list <B1-Motion> {break}
10089 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
10090 set reflist {}
10091 refill_reflist
10094 proc sel_reflist {w x y} {
10095 global showrefstop reflist headids tagids otherrefids
10097 if {![winfo exists $showrefstop]} return
10098 set l [lindex [split [$w index "@$x,$y"] "."] 0]
10099 set ref [lindex $reflist [expr {$l-1}]]
10100 set n [lindex $ref 0]
10101 switch -- [lindex $ref 1] {
10102 "H" {selbyid $headids($n)}
10103 "R" {selbyid $headids($n)}
10104 "T" {selbyid $tagids($n)}
10105 "o" {selbyid $otherrefids($n)}
10107 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
10110 proc unsel_reflist {} {
10111 global showrefstop
10113 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10114 $showrefstop.list tag remove highlight 0.0 end
10117 proc reflistfilter_change {n1 n2 op} {
10118 global reflistfilter
10120 after cancel refill_reflist
10121 after 200 refill_reflist
10124 proc refill_reflist {} {
10125 global reflist reflistfilter showrefstop headids tagids otherrefids
10126 global curview
10128 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10129 set refs {}
10130 foreach n [array names headids] {
10131 if {[string match $reflistfilter $n]} {
10132 if {[commitinview $headids($n) $curview]} {
10133 if {[string match "remotes/*" $n]} {
10134 lappend refs [list $n R]
10135 } else {
10136 lappend refs [list $n H]
10138 } else {
10139 interestedin $headids($n) {run refill_reflist}
10143 foreach n [array names tagids] {
10144 if {[string match $reflistfilter $n]} {
10145 if {[commitinview $tagids($n) $curview]} {
10146 lappend refs [list $n T]
10147 } else {
10148 interestedin $tagids($n) {run refill_reflist}
10152 foreach n [array names otherrefids] {
10153 if {[string match $reflistfilter $n]} {
10154 if {[commitinview $otherrefids($n) $curview]} {
10155 lappend refs [list $n o]
10156 } else {
10157 interestedin $otherrefids($n) {run refill_reflist}
10161 set refs [lsort -index 0 $refs]
10162 if {$refs eq $reflist} return
10164 # Update the contents of $showrefstop.list according to the
10165 # differences between $reflist (old) and $refs (new)
10166 $showrefstop.list conf -state normal
10167 $showrefstop.list insert end "\n"
10168 set i 0
10169 set j 0
10170 while {$i < [llength $reflist] || $j < [llength $refs]} {
10171 if {$i < [llength $reflist]} {
10172 if {$j < [llength $refs]} {
10173 set cmp [string compare [lindex $reflist $i 0] \
10174 [lindex $refs $j 0]]
10175 if {$cmp == 0} {
10176 set cmp [string compare [lindex $reflist $i 1] \
10177 [lindex $refs $j 1]]
10179 } else {
10180 set cmp -1
10182 } else {
10183 set cmp 1
10185 switch -- $cmp {
10186 -1 {
10187 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
10188 incr i
10191 incr i
10192 incr j
10195 set l [expr {$j + 1}]
10196 $showrefstop.list image create $l.0 -align baseline \
10197 -image reficon-[lindex $refs $j 1] -padx 2
10198 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
10199 incr j
10203 set reflist $refs
10204 # delete last newline
10205 $showrefstop.list delete end-2c end-1c
10206 $showrefstop.list conf -state disabled
10209 # Stuff for finding nearby tags
10210 proc getallcommits {} {
10211 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
10212 global idheads idtags idotherrefs allparents tagobjid
10213 global gitdir
10215 if {![info exists allcommits]} {
10216 set nextarc 0
10217 set allcommits 0
10218 set seeds {}
10219 set allcwait 0
10220 set cachedarcs 0
10221 set allccache [file join $gitdir "gitk.cache"]
10222 if {![catch {
10223 set f [open $allccache r]
10224 set allcwait 1
10225 getcache $f
10226 }]} return
10229 if {$allcwait} {
10230 return
10232 set cmd [list | git rev-list --parents]
10233 set allcupdate [expr {$seeds ne {}}]
10234 if {!$allcupdate} {
10235 set ids "--all"
10236 } else {
10237 set refs [concat [array names idheads] [array names idtags] \
10238 [array names idotherrefs]]
10239 set ids {}
10240 set tagobjs {}
10241 foreach name [array names tagobjid] {
10242 lappend tagobjs $tagobjid($name)
10244 foreach id [lsort -unique $refs] {
10245 if {![info exists allparents($id)] &&
10246 [lsearch -exact $tagobjs $id] < 0} {
10247 lappend ids $id
10250 if {$ids ne {}} {
10251 foreach id $seeds {
10252 lappend ids "^$id"
10254 lappend ids "--"
10257 if {$ids ne {}} {
10258 if {$ids eq "--all"} {
10259 set cmd [concat $cmd "--all"]
10260 } else {
10261 set cmd [concat $cmd --stdin "<<[join $ids "\\n"]"]
10263 set fd [open $cmd r]
10264 fconfigure $fd -blocking 0
10265 incr allcommits
10266 nowbusy allcommits
10267 filerun $fd [list getallclines $fd]
10268 } else {
10269 dispneartags 0
10273 # Since most commits have 1 parent and 1 child, we group strings of
10274 # such commits into "arcs" joining branch/merge points (BMPs), which
10275 # are commits that either don't have 1 parent or don't have 1 child.
10277 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10278 # arcout(id) - outgoing arcs for BMP
10279 # arcids(a) - list of IDs on arc including end but not start
10280 # arcstart(a) - BMP ID at start of arc
10281 # arcend(a) - BMP ID at end of arc
10282 # growing(a) - arc a is still growing
10283 # arctags(a) - IDs out of arcids (excluding end) that have tags
10284 # archeads(a) - IDs out of arcids (excluding end) that have heads
10285 # The start of an arc is at the descendent end, so "incoming" means
10286 # coming from descendents, and "outgoing" means going towards ancestors.
10288 proc getallclines {fd} {
10289 global allparents allchildren idtags idheads nextarc
10290 global arcnos arcids arctags arcout arcend arcstart archeads growing
10291 global seeds allcommits cachedarcs allcupdate
10293 set nid 0
10294 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10295 set id [lindex $line 0]
10296 if {[info exists allparents($id)]} {
10297 # seen it already
10298 continue
10300 set cachedarcs 0
10301 set olds [lrange $line 1 end]
10302 set allparents($id) $olds
10303 if {![info exists allchildren($id)]} {
10304 set allchildren($id) {}
10305 set arcnos($id) {}
10306 lappend seeds $id
10307 } else {
10308 set a $arcnos($id)
10309 if {[llength $olds] == 1 && [llength $a] == 1} {
10310 lappend arcids($a) $id
10311 if {[info exists idtags($id)]} {
10312 lappend arctags($a) $id
10314 if {[info exists idheads($id)]} {
10315 lappend archeads($a) $id
10317 if {[info exists allparents($olds)]} {
10318 # seen parent already
10319 if {![info exists arcout($olds)]} {
10320 splitarc $olds
10322 lappend arcids($a) $olds
10323 set arcend($a) $olds
10324 unset growing($a)
10326 lappend allchildren($olds) $id
10327 lappend arcnos($olds) $a
10328 continue
10331 foreach a $arcnos($id) {
10332 lappend arcids($a) $id
10333 set arcend($a) $id
10334 unset growing($a)
10337 set ao {}
10338 foreach p $olds {
10339 lappend allchildren($p) $id
10340 set a [incr nextarc]
10341 set arcstart($a) $id
10342 set archeads($a) {}
10343 set arctags($a) {}
10344 set archeads($a) {}
10345 set arcids($a) {}
10346 lappend ao $a
10347 set growing($a) 1
10348 if {[info exists allparents($p)]} {
10349 # seen it already, may need to make a new branch
10350 if {![info exists arcout($p)]} {
10351 splitarc $p
10353 lappend arcids($a) $p
10354 set arcend($a) $p
10355 unset growing($a)
10357 lappend arcnos($p) $a
10359 set arcout($id) $ao
10361 if {$nid > 0} {
10362 global cached_dheads cached_dtags cached_atags
10363 unset -nocomplain cached_dheads
10364 unset -nocomplain cached_dtags
10365 unset -nocomplain cached_atags
10367 if {![eof $fd]} {
10368 return [expr {$nid >= 1000? 2: 1}]
10370 set cacheok 1
10371 if {[catch {
10372 fconfigure $fd -blocking 1
10373 close $fd
10374 } err]} {
10375 # got an error reading the list of commits
10376 # if we were updating, try rereading the whole thing again
10377 if {$allcupdate} {
10378 incr allcommits -1
10379 dropcache $err
10380 return
10382 error_popup "[mc "Error reading commit topology information;\
10383 branch and preceding/following tag information\
10384 will be incomplete."]\n($err)"
10385 set cacheok 0
10387 if {[incr allcommits -1] == 0} {
10388 notbusy allcommits
10389 if {$cacheok} {
10390 run savecache
10393 dispneartags 0
10394 return 0
10397 proc recalcarc {a} {
10398 global arctags archeads arcids idtags idheads
10400 set at {}
10401 set ah {}
10402 foreach id [lrange $arcids($a) 0 end-1] {
10403 if {[info exists idtags($id)]} {
10404 lappend at $id
10406 if {[info exists idheads($id)]} {
10407 lappend ah $id
10410 set arctags($a) $at
10411 set archeads($a) $ah
10414 proc splitarc {p} {
10415 global arcnos arcids nextarc arctags archeads idtags idheads
10416 global arcstart arcend arcout allparents growing
10418 set a $arcnos($p)
10419 if {[llength $a] != 1} {
10420 puts "oops splitarc called but [llength $a] arcs already"
10421 return
10423 set a [lindex $a 0]
10424 set i [lsearch -exact $arcids($a) $p]
10425 if {$i < 0} {
10426 puts "oops splitarc $p not in arc $a"
10427 return
10429 set na [incr nextarc]
10430 if {[info exists arcend($a)]} {
10431 set arcend($na) $arcend($a)
10432 } else {
10433 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10434 set j [lsearch -exact $arcnos($l) $a]
10435 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10437 set tail [lrange $arcids($a) [expr {$i+1}] end]
10438 set arcids($a) [lrange $arcids($a) 0 $i]
10439 set arcend($a) $p
10440 set arcstart($na) $p
10441 set arcout($p) $na
10442 set arcids($na) $tail
10443 if {[info exists growing($a)]} {
10444 set growing($na) 1
10445 unset growing($a)
10448 foreach id $tail {
10449 if {[llength $arcnos($id)] == 1} {
10450 set arcnos($id) $na
10451 } else {
10452 set j [lsearch -exact $arcnos($id) $a]
10453 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10457 # reconstruct tags and heads lists
10458 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10459 recalcarc $a
10460 recalcarc $na
10461 } else {
10462 set arctags($na) {}
10463 set archeads($na) {}
10467 # Update things for a new commit added that is a child of one
10468 # existing commit. Used when cherry-picking.
10469 proc addnewchild {id p} {
10470 global allparents allchildren idtags nextarc
10471 global arcnos arcids arctags arcout arcend arcstart archeads growing
10472 global seeds allcommits
10474 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10475 set allparents($id) [list $p]
10476 set allchildren($id) {}
10477 set arcnos($id) {}
10478 lappend seeds $id
10479 lappend allchildren($p) $id
10480 set a [incr nextarc]
10481 set arcstart($a) $id
10482 set archeads($a) {}
10483 set arctags($a) {}
10484 set arcids($a) [list $p]
10485 set arcend($a) $p
10486 if {![info exists arcout($p)]} {
10487 splitarc $p
10489 lappend arcnos($p) $a
10490 set arcout($id) [list $a]
10493 # This implements a cache for the topology information.
10494 # The cache saves, for each arc, the start and end of the arc,
10495 # the ids on the arc, and the outgoing arcs from the end.
10496 proc readcache {f} {
10497 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10498 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10499 global allcwait
10501 set a $nextarc
10502 set lim $cachedarcs
10503 if {$lim - $a > 500} {
10504 set lim [expr {$a + 500}]
10506 if {[catch {
10507 if {$a == $lim} {
10508 # finish reading the cache and setting up arctags, etc.
10509 set line [gets $f]
10510 if {$line ne "1"} {error "bad final version"}
10511 close $f
10512 foreach id [array names idtags] {
10513 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10514 [llength $allparents($id)] == 1} {
10515 set a [lindex $arcnos($id) 0]
10516 if {$arctags($a) eq {}} {
10517 recalcarc $a
10521 foreach id [array names idheads] {
10522 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10523 [llength $allparents($id)] == 1} {
10524 set a [lindex $arcnos($id) 0]
10525 if {$archeads($a) eq {}} {
10526 recalcarc $a
10530 foreach id [lsort -unique $possible_seeds] {
10531 if {$arcnos($id) eq {}} {
10532 lappend seeds $id
10535 set allcwait 0
10536 } else {
10537 while {[incr a] <= $lim} {
10538 set line [gets $f]
10539 if {[llength $line] != 3} {error "bad line"}
10540 set s [lindex $line 0]
10541 set arcstart($a) $s
10542 lappend arcout($s) $a
10543 if {![info exists arcnos($s)]} {
10544 lappend possible_seeds $s
10545 set arcnos($s) {}
10547 set e [lindex $line 1]
10548 if {$e eq {}} {
10549 set growing($a) 1
10550 } else {
10551 set arcend($a) $e
10552 if {![info exists arcout($e)]} {
10553 set arcout($e) {}
10556 set arcids($a) [lindex $line 2]
10557 foreach id $arcids($a) {
10558 lappend allparents($s) $id
10559 set s $id
10560 lappend arcnos($id) $a
10562 if {![info exists allparents($s)]} {
10563 set allparents($s) {}
10565 set arctags($a) {}
10566 set archeads($a) {}
10568 set nextarc [expr {$a - 1}]
10570 } err]} {
10571 dropcache $err
10572 return 0
10574 if {!$allcwait} {
10575 getallcommits
10577 return $allcwait
10580 proc getcache {f} {
10581 global nextarc cachedarcs possible_seeds
10583 if {[catch {
10584 set line [gets $f]
10585 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10586 # make sure it's an integer
10587 set cachedarcs [expr {int([lindex $line 1])}]
10588 if {$cachedarcs < 0} {error "bad number of arcs"}
10589 set nextarc 0
10590 set possible_seeds {}
10591 run readcache $f
10592 } err]} {
10593 dropcache $err
10595 return 0
10598 proc dropcache {err} {
10599 global allcwait nextarc cachedarcs seeds
10601 #puts "dropping cache ($err)"
10602 foreach v {arcnos arcout arcids arcstart arcend growing \
10603 arctags archeads allparents allchildren} {
10604 global $v
10605 unset -nocomplain $v
10607 set allcwait 0
10608 set nextarc 0
10609 set cachedarcs 0
10610 set seeds {}
10611 getallcommits
10614 proc writecache {f} {
10615 global cachearc cachedarcs allccache
10616 global arcstart arcend arcnos arcids arcout
10618 set a $cachearc
10619 set lim $cachedarcs
10620 if {$lim - $a > 1000} {
10621 set lim [expr {$a + 1000}]
10623 if {[catch {
10624 while {[incr a] <= $lim} {
10625 if {[info exists arcend($a)]} {
10626 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10627 } else {
10628 puts $f [list $arcstart($a) {} $arcids($a)]
10631 } err]} {
10632 catch {close $f}
10633 catch {file delete $allccache}
10634 #puts "writing cache failed ($err)"
10635 return 0
10637 set cachearc [expr {$a - 1}]
10638 if {$a > $cachedarcs} {
10639 puts $f "1"
10640 close $f
10641 return 0
10643 return 1
10646 proc savecache {} {
10647 global nextarc cachedarcs cachearc allccache
10649 if {$nextarc == $cachedarcs} return
10650 set cachearc 0
10651 set cachedarcs $nextarc
10652 catch {
10653 set f [open $allccache w]
10654 puts $f [list 1 $cachedarcs]
10655 run writecache $f
10659 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10660 # or 0 if neither is true.
10661 proc anc_or_desc {a b} {
10662 global arcout arcstart arcend arcnos cached_isanc
10664 if {$arcnos($a) eq $arcnos($b)} {
10665 # Both are on the same arc(s); either both are the same BMP,
10666 # or if one is not a BMP, the other is also not a BMP or is
10667 # the BMP at end of the arc (and it only has 1 incoming arc).
10668 # Or both can be BMPs with no incoming arcs.
10669 if {$a eq $b || $arcnos($a) eq {}} {
10670 return 0
10672 # assert {[llength $arcnos($a)] == 1}
10673 set arc [lindex $arcnos($a) 0]
10674 set i [lsearch -exact $arcids($arc) $a]
10675 set j [lsearch -exact $arcids($arc) $b]
10676 if {$i < 0 || $i > $j} {
10677 return 1
10678 } else {
10679 return -1
10683 if {![info exists arcout($a)]} {
10684 set arc [lindex $arcnos($a) 0]
10685 if {[info exists arcend($arc)]} {
10686 set aend $arcend($arc)
10687 } else {
10688 set aend {}
10690 set a $arcstart($arc)
10691 } else {
10692 set aend $a
10694 if {![info exists arcout($b)]} {
10695 set arc [lindex $arcnos($b) 0]
10696 if {[info exists arcend($arc)]} {
10697 set bend $arcend($arc)
10698 } else {
10699 set bend {}
10701 set b $arcstart($arc)
10702 } else {
10703 set bend $b
10705 if {$a eq $bend} {
10706 return 1
10708 if {$b eq $aend} {
10709 return -1
10711 if {[info exists cached_isanc($a,$bend)]} {
10712 if {$cached_isanc($a,$bend)} {
10713 return 1
10716 if {[info exists cached_isanc($b,$aend)]} {
10717 if {$cached_isanc($b,$aend)} {
10718 return -1
10720 if {[info exists cached_isanc($a,$bend)]} {
10721 return 0
10725 set todo [list $a $b]
10726 set anc($a) a
10727 set anc($b) b
10728 for {set i 0} {$i < [llength $todo]} {incr i} {
10729 set x [lindex $todo $i]
10730 if {$anc($x) eq {}} {
10731 continue
10733 foreach arc $arcnos($x) {
10734 set xd $arcstart($arc)
10735 if {$xd eq $bend} {
10736 set cached_isanc($a,$bend) 1
10737 set cached_isanc($b,$aend) 0
10738 return 1
10739 } elseif {$xd eq $aend} {
10740 set cached_isanc($b,$aend) 1
10741 set cached_isanc($a,$bend) 0
10742 return -1
10744 if {![info exists anc($xd)]} {
10745 set anc($xd) $anc($x)
10746 lappend todo $xd
10747 } elseif {$anc($xd) ne $anc($x)} {
10748 set anc($xd) {}
10752 set cached_isanc($a,$bend) 0
10753 set cached_isanc($b,$aend) 0
10754 return 0
10757 # This identifies whether $desc has an ancestor that is
10758 # a growing tip of the graph and which is not an ancestor of $anc
10759 # and returns 0 if so and 1 if not.
10760 # If we subsequently discover a tag on such a growing tip, and that
10761 # turns out to be a descendent of $anc (which it could, since we
10762 # don't necessarily see children before parents), then $desc
10763 # isn't a good choice to display as a descendent tag of
10764 # $anc (since it is the descendent of another tag which is
10765 # a descendent of $anc). Similarly, $anc isn't a good choice to
10766 # display as a ancestor tag of $desc.
10768 proc is_certain {desc anc} {
10769 global arcnos arcout arcstart arcend growing problems
10771 set certain {}
10772 if {[llength $arcnos($anc)] == 1} {
10773 # tags on the same arc are certain
10774 if {$arcnos($desc) eq $arcnos($anc)} {
10775 return 1
10777 if {![info exists arcout($anc)]} {
10778 # if $anc is partway along an arc, use the start of the arc instead
10779 set a [lindex $arcnos($anc) 0]
10780 set anc $arcstart($a)
10783 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10784 set x $desc
10785 } else {
10786 set a [lindex $arcnos($desc) 0]
10787 set x $arcend($a)
10789 if {$x == $anc} {
10790 return 1
10792 set anclist [list $x]
10793 set dl($x) 1
10794 set nnh 1
10795 set ngrowanc 0
10796 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10797 set x [lindex $anclist $i]
10798 if {$dl($x)} {
10799 incr nnh -1
10801 set done($x) 1
10802 foreach a $arcout($x) {
10803 if {[info exists growing($a)]} {
10804 if {![info exists growanc($x)] && $dl($x)} {
10805 set growanc($x) 1
10806 incr ngrowanc
10808 } else {
10809 set y $arcend($a)
10810 if {[info exists dl($y)]} {
10811 if {$dl($y)} {
10812 if {!$dl($x)} {
10813 set dl($y) 0
10814 if {![info exists done($y)]} {
10815 incr nnh -1
10817 if {[info exists growanc($x)]} {
10818 incr ngrowanc -1
10820 set xl [list $y]
10821 for {set k 0} {$k < [llength $xl]} {incr k} {
10822 set z [lindex $xl $k]
10823 foreach c $arcout($z) {
10824 if {[info exists arcend($c)]} {
10825 set v $arcend($c)
10826 if {[info exists dl($v)] && $dl($v)} {
10827 set dl($v) 0
10828 if {![info exists done($v)]} {
10829 incr nnh -1
10831 if {[info exists growanc($v)]} {
10832 incr ngrowanc -1
10834 lappend xl $v
10841 } elseif {$y eq $anc || !$dl($x)} {
10842 set dl($y) 0
10843 lappend anclist $y
10844 } else {
10845 set dl($y) 1
10846 lappend anclist $y
10847 incr nnh
10852 foreach x [array names growanc] {
10853 if {$dl($x)} {
10854 return 0
10856 return 0
10858 return 1
10861 proc validate_arctags {a} {
10862 global arctags idtags
10864 set i -1
10865 set na $arctags($a)
10866 foreach id $arctags($a) {
10867 incr i
10868 if {![info exists idtags($id)]} {
10869 set na [lreplace $na $i $i]
10870 incr i -1
10873 set arctags($a) $na
10876 proc validate_archeads {a} {
10877 global archeads idheads
10879 set i -1
10880 set na $archeads($a)
10881 foreach id $archeads($a) {
10882 incr i
10883 if {![info exists idheads($id)]} {
10884 set na [lreplace $na $i $i]
10885 incr i -1
10888 set archeads($a) $na
10891 # Return the list of IDs that have tags that are descendents of id,
10892 # ignoring IDs that are descendents of IDs already reported.
10893 proc desctags {id} {
10894 global arcnos arcstart arcids arctags idtags allparents
10895 global growing cached_dtags
10897 if {![info exists allparents($id)]} {
10898 return {}
10900 set t1 [clock clicks -milliseconds]
10901 set argid $id
10902 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10903 # part-way along an arc; check that arc first
10904 set a [lindex $arcnos($id) 0]
10905 if {$arctags($a) ne {}} {
10906 validate_arctags $a
10907 set i [lsearch -exact $arcids($a) $id]
10908 set tid {}
10909 foreach t $arctags($a) {
10910 set j [lsearch -exact $arcids($a) $t]
10911 if {$j >= $i} break
10912 set tid $t
10914 if {$tid ne {}} {
10915 return $tid
10918 set id $arcstart($a)
10919 if {[info exists idtags($id)]} {
10920 return $id
10923 if {[info exists cached_dtags($id)]} {
10924 return $cached_dtags($id)
10927 set origid $id
10928 set todo [list $id]
10929 set queued($id) 1
10930 set nc 1
10931 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10932 set id [lindex $todo $i]
10933 set done($id) 1
10934 set ta [info exists hastaggedancestor($id)]
10935 if {!$ta} {
10936 incr nc -1
10938 # ignore tags on starting node
10939 if {!$ta && $i > 0} {
10940 if {[info exists idtags($id)]} {
10941 set tagloc($id) $id
10942 set ta 1
10943 } elseif {[info exists cached_dtags($id)]} {
10944 set tagloc($id) $cached_dtags($id)
10945 set ta 1
10948 foreach a $arcnos($id) {
10949 set d $arcstart($a)
10950 if {!$ta && $arctags($a) ne {}} {
10951 validate_arctags $a
10952 if {$arctags($a) ne {}} {
10953 lappend tagloc($id) [lindex $arctags($a) end]
10956 if {$ta || $arctags($a) ne {}} {
10957 set tomark [list $d]
10958 for {set j 0} {$j < [llength $tomark]} {incr j} {
10959 set dd [lindex $tomark $j]
10960 if {![info exists hastaggedancestor($dd)]} {
10961 if {[info exists done($dd)]} {
10962 foreach b $arcnos($dd) {
10963 lappend tomark $arcstart($b)
10965 if {[info exists tagloc($dd)]} {
10966 unset tagloc($dd)
10968 } elseif {[info exists queued($dd)]} {
10969 incr nc -1
10971 set hastaggedancestor($dd) 1
10975 if {![info exists queued($d)]} {
10976 lappend todo $d
10977 set queued($d) 1
10978 if {![info exists hastaggedancestor($d)]} {
10979 incr nc
10984 set tags {}
10985 foreach id [array names tagloc] {
10986 if {![info exists hastaggedancestor($id)]} {
10987 foreach t $tagloc($id) {
10988 if {[lsearch -exact $tags $t] < 0} {
10989 lappend tags $t
10994 set t2 [clock clicks -milliseconds]
10995 set loopix $i
10997 # remove tags that are descendents of other tags
10998 for {set i 0} {$i < [llength $tags]} {incr i} {
10999 set a [lindex $tags $i]
11000 for {set j 0} {$j < $i} {incr j} {
11001 set b [lindex $tags $j]
11002 set r [anc_or_desc $a $b]
11003 if {$r == 1} {
11004 set tags [lreplace $tags $j $j]
11005 incr j -1
11006 incr i -1
11007 } elseif {$r == -1} {
11008 set tags [lreplace $tags $i $i]
11009 incr i -1
11010 break
11015 if {[array names growing] ne {}} {
11016 # graph isn't finished, need to check if any tag could get
11017 # eclipsed by another tag coming later. Simply ignore any
11018 # tags that could later get eclipsed.
11019 set ctags {}
11020 foreach t $tags {
11021 if {[is_certain $t $origid]} {
11022 lappend ctags $t
11025 if {$tags eq $ctags} {
11026 set cached_dtags($origid) $tags
11027 } else {
11028 set tags $ctags
11030 } else {
11031 set cached_dtags($origid) $tags
11033 set t3 [clock clicks -milliseconds]
11034 if {0 && $t3 - $t1 >= 100} {
11035 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
11036 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
11038 return $tags
11041 proc anctags {id} {
11042 global arcnos arcids arcout arcend arctags idtags allparents
11043 global growing cached_atags
11045 if {![info exists allparents($id)]} {
11046 return {}
11048 set t1 [clock clicks -milliseconds]
11049 set argid $id
11050 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
11051 # part-way along an arc; check that arc first
11052 set a [lindex $arcnos($id) 0]
11053 if {$arctags($a) ne {}} {
11054 validate_arctags $a
11055 set i [lsearch -exact $arcids($a) $id]
11056 foreach t $arctags($a) {
11057 set j [lsearch -exact $arcids($a) $t]
11058 if {$j > $i} {
11059 return $t
11063 if {![info exists arcend($a)]} {
11064 return {}
11066 set id $arcend($a)
11067 if {[info exists idtags($id)]} {
11068 return $id
11071 if {[info exists cached_atags($id)]} {
11072 return $cached_atags($id)
11075 set origid $id
11076 set todo [list $id]
11077 set queued($id) 1
11078 set taglist {}
11079 set nc 1
11080 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
11081 set id [lindex $todo $i]
11082 set done($id) 1
11083 set td [info exists hastaggeddescendent($id)]
11084 if {!$td} {
11085 incr nc -1
11087 # ignore tags on starting node
11088 if {!$td && $i > 0} {
11089 if {[info exists idtags($id)]} {
11090 set tagloc($id) $id
11091 set td 1
11092 } elseif {[info exists cached_atags($id)]} {
11093 set tagloc($id) $cached_atags($id)
11094 set td 1
11097 foreach a $arcout($id) {
11098 if {!$td && $arctags($a) ne {}} {
11099 validate_arctags $a
11100 if {$arctags($a) ne {}} {
11101 lappend tagloc($id) [lindex $arctags($a) 0]
11104 if {![info exists arcend($a)]} continue
11105 set d $arcend($a)
11106 if {$td || $arctags($a) ne {}} {
11107 set tomark [list $d]
11108 for {set j 0} {$j < [llength $tomark]} {incr j} {
11109 set dd [lindex $tomark $j]
11110 if {![info exists hastaggeddescendent($dd)]} {
11111 if {[info exists done($dd)]} {
11112 foreach b $arcout($dd) {
11113 if {[info exists arcend($b)]} {
11114 lappend tomark $arcend($b)
11117 if {[info exists tagloc($dd)]} {
11118 unset tagloc($dd)
11120 } elseif {[info exists queued($dd)]} {
11121 incr nc -1
11123 set hastaggeddescendent($dd) 1
11127 if {![info exists queued($d)]} {
11128 lappend todo $d
11129 set queued($d) 1
11130 if {![info exists hastaggeddescendent($d)]} {
11131 incr nc
11136 set t2 [clock clicks -milliseconds]
11137 set loopix $i
11138 set tags {}
11139 foreach id [array names tagloc] {
11140 if {![info exists hastaggeddescendent($id)]} {
11141 foreach t $tagloc($id) {
11142 if {[lsearch -exact $tags $t] < 0} {
11143 lappend tags $t
11149 # remove tags that are ancestors of other tags
11150 for {set i 0} {$i < [llength $tags]} {incr i} {
11151 set a [lindex $tags $i]
11152 for {set j 0} {$j < $i} {incr j} {
11153 set b [lindex $tags $j]
11154 set r [anc_or_desc $a $b]
11155 if {$r == -1} {
11156 set tags [lreplace $tags $j $j]
11157 incr j -1
11158 incr i -1
11159 } elseif {$r == 1} {
11160 set tags [lreplace $tags $i $i]
11161 incr i -1
11162 break
11167 if {[array names growing] ne {}} {
11168 # graph isn't finished, need to check if any tag could get
11169 # eclipsed by another tag coming later. Simply ignore any
11170 # tags that could later get eclipsed.
11171 set ctags {}
11172 foreach t $tags {
11173 if {[is_certain $origid $t]} {
11174 lappend ctags $t
11177 if {$tags eq $ctags} {
11178 set cached_atags($origid) $tags
11179 } else {
11180 set tags $ctags
11182 } else {
11183 set cached_atags($origid) $tags
11185 set t3 [clock clicks -milliseconds]
11186 if {0 && $t3 - $t1 >= 100} {
11187 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
11188 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
11190 return $tags
11193 # Return the list of IDs that have heads that are descendents of id,
11194 # including id itself if it has a head.
11195 proc descheads {id} {
11196 global arcnos arcstart arcids archeads idheads cached_dheads
11197 global allparents arcout
11199 if {![info exists allparents($id)]} {
11200 return {}
11202 set aret {}
11203 if {![info exists arcout($id)]} {
11204 # part-way along an arc; check it first
11205 set a [lindex $arcnos($id) 0]
11206 if {$archeads($a) ne {}} {
11207 validate_archeads $a
11208 set i [lsearch -exact $arcids($a) $id]
11209 foreach t $archeads($a) {
11210 set j [lsearch -exact $arcids($a) $t]
11211 if {$j > $i} break
11212 lappend aret $t
11215 set id $arcstart($a)
11217 set origid $id
11218 set todo [list $id]
11219 set seen($id) 1
11220 set ret {}
11221 for {set i 0} {$i < [llength $todo]} {incr i} {
11222 set id [lindex $todo $i]
11223 if {[info exists cached_dheads($id)]} {
11224 set ret [concat $ret $cached_dheads($id)]
11225 } else {
11226 if {[info exists idheads($id)]} {
11227 lappend ret $id
11229 foreach a $arcnos($id) {
11230 if {$archeads($a) ne {}} {
11231 validate_archeads $a
11232 if {$archeads($a) ne {}} {
11233 set ret [concat $ret $archeads($a)]
11236 set d $arcstart($a)
11237 if {![info exists seen($d)]} {
11238 lappend todo $d
11239 set seen($d) 1
11244 set ret [lsort -unique $ret]
11245 set cached_dheads($origid) $ret
11246 return [concat $ret $aret]
11249 proc addedtag {id} {
11250 global arcnos arcout cached_dtags cached_atags
11252 if {![info exists arcnos($id)]} return
11253 if {![info exists arcout($id)]} {
11254 recalcarc [lindex $arcnos($id) 0]
11256 unset -nocomplain cached_dtags
11257 unset -nocomplain cached_atags
11260 proc addedhead {hid head} {
11261 global arcnos arcout cached_dheads
11263 if {![info exists arcnos($hid)]} return
11264 if {![info exists arcout($hid)]} {
11265 recalcarc [lindex $arcnos($hid) 0]
11267 unset -nocomplain cached_dheads
11270 proc removedhead {hid head} {
11271 global cached_dheads
11273 unset -nocomplain cached_dheads
11276 proc movedhead {hid head} {
11277 global arcnos arcout cached_dheads
11279 if {![info exists arcnos($hid)]} return
11280 if {![info exists arcout($hid)]} {
11281 recalcarc [lindex $arcnos($hid) 0]
11283 unset -nocomplain cached_dheads
11286 proc changedrefs {} {
11287 global cached_dheads cached_dtags cached_atags cached_tagcontent
11288 global arctags archeads arcnos arcout idheads idtags
11290 foreach id [concat [array names idheads] [array names idtags]] {
11291 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11292 set a [lindex $arcnos($id) 0]
11293 if {![info exists donearc($a)]} {
11294 recalcarc $a
11295 set donearc($a) 1
11299 unset -nocomplain cached_tagcontent
11300 unset -nocomplain cached_dtags
11301 unset -nocomplain cached_atags
11302 unset -nocomplain cached_dheads
11305 proc rereadrefs {} {
11306 global idtags idheads idotherrefs mainheadid
11308 set refids [concat [array names idtags] \
11309 [array names idheads] [array names idotherrefs]]
11310 foreach id $refids {
11311 if {![info exists ref($id)]} {
11312 set ref($id) [listrefs $id]
11315 set oldmainhead $mainheadid
11316 readrefs
11317 changedrefs
11318 set refids [lsort -unique [concat $refids [array names idtags] \
11319 [array names idheads] [array names idotherrefs]]]
11320 foreach id $refids {
11321 set v [listrefs $id]
11322 if {![info exists ref($id)] || $ref($id) != $v} {
11323 redrawtags $id
11326 if {$oldmainhead ne $mainheadid} {
11327 redrawtags $oldmainhead
11328 redrawtags $mainheadid
11330 run refill_reflist
11333 proc listrefs {id} {
11334 global idtags idheads idotherrefs
11336 set x {}
11337 if {[info exists idtags($id)]} {
11338 set x $idtags($id)
11340 set y {}
11341 if {[info exists idheads($id)]} {
11342 set y $idheads($id)
11344 set z {}
11345 if {[info exists idotherrefs($id)]} {
11346 set z $idotherrefs($id)
11348 return [list $x $y $z]
11351 proc add_tag_ctext {tag} {
11352 global ctext cached_tagcontent tagids
11354 if {![info exists cached_tagcontent($tag)]} {
11355 catch {
11356 set cached_tagcontent($tag) [exec git cat-file -p $tag]
11359 $ctext insert end "[mc "Tag"]: $tag\n" bold
11360 if {[info exists cached_tagcontent($tag)]} {
11361 set text $cached_tagcontent($tag)
11362 } else {
11363 set text "[mc "Id"]: $tagids($tag)"
11365 appendwithlinks $text {}
11368 proc showtag {tag isnew} {
11369 global ctext cached_tagcontent tagids linknum tagobjid
11371 if {$isnew} {
11372 addtohistory [list showtag $tag 0] savectextpos
11374 $ctext conf -state normal
11375 clear_ctext
11376 settabs 0
11377 set linknum 0
11378 add_tag_ctext $tag
11379 maybe_scroll_ctext 1
11380 $ctext conf -state disabled
11381 init_flist {}
11384 proc showtags {id isnew} {
11385 global idtags ctext linknum
11387 if {$isnew} {
11388 addtohistory [list showtags $id 0] savectextpos
11390 $ctext conf -state normal
11391 clear_ctext
11392 settabs 0
11393 set linknum 0
11394 set sep {}
11395 foreach tag $idtags($id) {
11396 $ctext insert end $sep
11397 add_tag_ctext $tag
11398 set sep "\n\n"
11400 maybe_scroll_ctext 1
11401 $ctext conf -state disabled
11402 init_flist {}
11405 proc doquit {} {
11406 global stopped
11407 global gitktmpdir
11409 set stopped 100
11410 savestuff .
11411 destroy .
11413 if {[info exists gitktmpdir]} {
11414 catch {file delete -force $gitktmpdir}
11418 proc mkfontdisp {font top which} {
11419 global fontattr fontpref $font NS use_ttk
11421 set fontpref($font) [set $font]
11422 ${NS}::button $top.${font}but -text $which \
11423 -command [list choosefont $font $which]
11424 ${NS}::label $top.$font -relief flat -font $font \
11425 -text $fontattr($font,family) -justify left
11426 grid x $top.${font}but $top.$font -sticky w
11429 proc choosefont {font which} {
11430 global fontparam fontlist fonttop fontattr
11431 global prefstop NS
11433 set fontparam(which) $which
11434 set fontparam(font) $font
11435 set fontparam(family) [font actual $font -family]
11436 set fontparam(size) $fontattr($font,size)
11437 set fontparam(weight) $fontattr($font,weight)
11438 set fontparam(slant) $fontattr($font,slant)
11439 set top .gitkfont
11440 set fonttop $top
11441 if {![winfo exists $top]} {
11442 font create sample
11443 eval font config sample [font actual $font]
11444 ttk_toplevel $top
11445 make_transient $top $prefstop
11446 wm title $top [mc "Gitk font chooser"]
11447 ${NS}::label $top.l -textvariable fontparam(which)
11448 pack $top.l -side top
11449 set fontlist [lsort [font families]]
11450 ${NS}::frame $top.f
11451 listbox $top.f.fam -listvariable fontlist \
11452 -yscrollcommand [list $top.f.sb set]
11453 bind $top.f.fam <<ListboxSelect>> selfontfam
11454 ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11455 pack $top.f.sb -side right -fill y
11456 pack $top.f.fam -side left -fill both -expand 1
11457 pack $top.f -side top -fill both -expand 1
11458 ${NS}::frame $top.g
11459 spinbox $top.g.size -from 4 -to 40 -width 4 \
11460 -textvariable fontparam(size) \
11461 -validatecommand {string is integer -strict %s}
11462 checkbutton $top.g.bold -padx 5 \
11463 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11464 -variable fontparam(weight) -onvalue bold -offvalue normal
11465 checkbutton $top.g.ital -padx 5 \
11466 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
11467 -variable fontparam(slant) -onvalue italic -offvalue roman
11468 pack $top.g.size $top.g.bold $top.g.ital -side left
11469 pack $top.g -side top
11470 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11471 -background white
11472 $top.c create text 100 25 -anchor center -text $which -font sample \
11473 -fill black -tags text
11474 bind $top.c <Configure> [list centertext $top.c]
11475 pack $top.c -side top -fill x
11476 ${NS}::frame $top.buts
11477 ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11478 ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11479 bind $top <Key-Return> fontok
11480 bind $top <Key-Escape> fontcan
11481 grid $top.buts.ok $top.buts.can
11482 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11483 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11484 pack $top.buts -side bottom -fill x
11485 trace add variable fontparam write chg_fontparam
11486 } else {
11487 raise $top
11488 $top.c itemconf text -text $which
11490 set i [lsearch -exact $fontlist $fontparam(family)]
11491 if {$i >= 0} {
11492 $top.f.fam selection set $i
11493 $top.f.fam see $i
11497 proc centertext {w} {
11498 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11501 proc fontok {} {
11502 global fontparam fontpref prefstop
11504 set f $fontparam(font)
11505 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11506 if {$fontparam(weight) eq "bold"} {
11507 lappend fontpref($f) "bold"
11509 if {$fontparam(slant) eq "italic"} {
11510 lappend fontpref($f) "italic"
11512 set w $prefstop.notebook.fonts.$f
11513 $w conf -text $fontparam(family) -font $fontpref($f)
11515 fontcan
11518 proc fontcan {} {
11519 global fonttop fontparam
11521 if {[info exists fonttop]} {
11522 catch {destroy $fonttop}
11523 catch {font delete sample}
11524 unset fonttop
11525 unset fontparam
11529 if {[package vsatisfies [package provide Tk] 8.6]} {
11530 # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11531 # function to make use of it.
11532 proc choosefont {font which} {
11533 tk fontchooser configure -title $which -font $font \
11534 -command [list on_choosefont $font $which]
11535 tk fontchooser show
11537 proc on_choosefont {font which newfont} {
11538 global fontparam
11539 puts stderr "$font $newfont"
11540 array set f [font actual $newfont]
11541 set fontparam(which) $which
11542 set fontparam(font) $font
11543 set fontparam(family) $f(-family)
11544 set fontparam(size) $f(-size)
11545 set fontparam(weight) $f(-weight)
11546 set fontparam(slant) $f(-slant)
11547 fontok
11551 proc selfontfam {} {
11552 global fonttop fontparam
11554 set i [$fonttop.f.fam curselection]
11555 if {$i ne {}} {
11556 set fontparam(family) [$fonttop.f.fam get $i]
11560 proc chg_fontparam {v sub op} {
11561 global fontparam
11563 font config sample -$sub $fontparam($sub)
11566 # Create a property sheet tab page
11567 proc create_prefs_page {w} {
11568 global NS
11569 set parent [join [lrange [split $w .] 0 end-1] .]
11570 if {[winfo class $parent] eq "TNotebook"} {
11571 ${NS}::frame $w
11572 } else {
11573 ${NS}::labelframe $w
11577 proc prefspage_general {notebook} {
11578 global NS maxwidth maxgraphpct showneartags showlocalchanges
11579 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11580 global hideremotes want_ttk have_ttk maxrefs web_browser
11582 set page [create_prefs_page $notebook.general]
11584 ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11585 grid $page.ldisp - -sticky w -pady 10
11586 ${NS}::label $page.spacer -text " "
11587 ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11588 spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11589 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11590 #xgettext:no-tcl-format
11591 ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11592 spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11593 grid x $page.maxpctl $page.maxpct -sticky w
11594 ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11595 -variable showlocalchanges
11596 grid x $page.showlocal -sticky w
11597 ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11598 -variable autoselect
11599 spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11600 grid x $page.autoselect $page.autosellen -sticky w
11601 ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11602 -variable hideremotes
11603 grid x $page.hideremotes -sticky w
11605 ${NS}::label $page.ddisp -text [mc "Diff display options"]
11606 grid $page.ddisp - -sticky w -pady 10
11607 ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11608 spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11609 grid x $page.tabstopl $page.tabstop -sticky w
11610 ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11611 -variable showneartags
11612 grid x $page.ntag -sticky w
11613 ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11614 spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11615 grid x $page.maxrefsl $page.maxrefs -sticky w
11616 ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11617 -variable limitdiffs
11618 grid x $page.ldiff -sticky w
11619 ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11620 -variable perfile_attrs
11621 grid x $page.lattr -sticky w
11623 ${NS}::entry $page.extdifft -textvariable extdifftool
11624 ${NS}::frame $page.extdifff
11625 ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11626 ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11627 pack $page.extdifff.l $page.extdifff.b -side left
11628 pack configure $page.extdifff.l -padx 10
11629 grid x $page.extdifff $page.extdifft -sticky ew
11631 ${NS}::entry $page.webbrowser -textvariable web_browser
11632 ${NS}::frame $page.webbrowserf
11633 ${NS}::label $page.webbrowserf.l -text [mc "Web browser" ]
11634 pack $page.webbrowserf.l -side left
11635 pack configure $page.webbrowserf.l -padx 10
11636 grid x $page.webbrowserf $page.webbrowser -sticky ew
11638 ${NS}::label $page.lgen -text [mc "General options"]
11639 grid $page.lgen - -sticky w -pady 10
11640 ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11641 -text [mc "Use themed widgets"]
11642 if {$have_ttk} {
11643 ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11644 } else {
11645 ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11647 grid x $page.want_ttk $page.ttk_note -sticky w
11648 return $page
11651 proc prefspage_colors {notebook} {
11652 global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11653 global diffbgcolors
11655 set page [create_prefs_page $notebook.colors]
11657 ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11658 grid $page.cdisp - -sticky w -pady 10
11659 label $page.ui -padx 40 -relief sunk -background $uicolor
11660 ${NS}::button $page.uibut -text [mc "Interface"] \
11661 -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11662 grid x $page.uibut $page.ui -sticky w
11663 label $page.bg -padx 40 -relief sunk -background $bgcolor
11664 ${NS}::button $page.bgbut -text [mc "Background"] \
11665 -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11666 grid x $page.bgbut $page.bg -sticky w
11667 label $page.fg -padx 40 -relief sunk -background $fgcolor
11668 ${NS}::button $page.fgbut -text [mc "Foreground"] \
11669 -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11670 grid x $page.fgbut $page.fg -sticky w
11671 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11672 ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11673 -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11674 [list $ctext tag conf d0 -foreground]]
11675 grid x $page.diffoldbut $page.diffold -sticky w
11676 label $page.diffoldbg -padx 40 -relief sunk -background [lindex $diffbgcolors 0]
11677 ${NS}::button $page.diffoldbgbut -text [mc "Diff: old lines bg"] \
11678 -command [list choosecolor diffbgcolors 0 $page.diffoldbg \
11679 [mc "diff old lines bg"] \
11680 [list $ctext tag conf d0 -background]]
11681 grid x $page.diffoldbgbut $page.diffoldbg -sticky w
11682 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11683 ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11684 -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11685 [list $ctext tag conf dresult -foreground]]
11686 grid x $page.diffnewbut $page.diffnew -sticky w
11687 label $page.diffnewbg -padx 40 -relief sunk -background [lindex $diffbgcolors 1]
11688 ${NS}::button $page.diffnewbgbut -text [mc "Diff: new lines bg"] \
11689 -command [list choosecolor diffbgcolors 1 $page.diffnewbg \
11690 [mc "diff new lines bg"] \
11691 [list $ctext tag conf dresult -background]]
11692 grid x $page.diffnewbgbut $page.diffnewbg -sticky w
11693 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11694 ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11695 -command [list choosecolor diffcolors 2 $page.hunksep \
11696 [mc "diff hunk header"] \
11697 [list $ctext tag conf hunksep -foreground]]
11698 grid x $page.hunksepbut $page.hunksep -sticky w
11699 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11700 ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11701 -command [list choosecolor markbgcolor {} $page.markbgsep \
11702 [mc "marked line background"] \
11703 [list $ctext tag conf omark -background]]
11704 grid x $page.markbgbut $page.markbgsep -sticky w
11705 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11706 ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11707 -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11708 grid x $page.selbgbut $page.selbgsep -sticky w
11709 return $page
11712 proc prefspage_fonts {notebook} {
11713 global NS
11714 set page [create_prefs_page $notebook.fonts]
11715 ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11716 grid $page.cfont - -sticky w -pady 10
11717 mkfontdisp mainfont $page [mc "Main font"]
11718 mkfontdisp textfont $page [mc "Diff display font"]
11719 mkfontdisp uifont $page [mc "User interface font"]
11720 return $page
11723 proc doprefs {} {
11724 global maxwidth maxgraphpct use_ttk NS
11725 global oldprefs prefstop showneartags showlocalchanges
11726 global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11727 global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11728 global hideremotes want_ttk have_ttk
11730 set top .gitkprefs
11731 set prefstop $top
11732 if {[winfo exists $top]} {
11733 raise $top
11734 return
11736 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11737 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11738 set oldprefs($v) [set $v]
11740 ttk_toplevel $top
11741 wm title $top [mc "Gitk preferences"]
11742 make_transient $top .
11744 if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11745 set notebook [ttk::notebook $top.notebook]
11746 } else {
11747 set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11750 lappend pages [prefspage_general $notebook] [mc "General"]
11751 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11752 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11753 set col 0
11754 foreach {page title} $pages {
11755 if {$use_notebook} {
11756 $notebook add $page -text $title
11757 } else {
11758 set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11759 -text $title -command [list raise $page]]
11760 $page configure -text $title
11761 grid $btn -row 0 -column [incr col] -sticky w
11762 grid $page -row 1 -column 0 -sticky news -columnspan 100
11766 if {!$use_notebook} {
11767 grid columnconfigure $notebook 0 -weight 1
11768 grid rowconfigure $notebook 1 -weight 1
11769 raise [lindex $pages 0]
11772 grid $notebook -sticky news -padx 2 -pady 2
11773 grid rowconfigure $top 0 -weight 1
11774 grid columnconfigure $top 0 -weight 1
11776 ${NS}::frame $top.buts
11777 ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11778 ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11779 bind $top <Key-Return> prefsok
11780 bind $top <Key-Escape> prefscan
11781 grid $top.buts.ok $top.buts.can
11782 grid columnconfigure $top.buts 0 -weight 1 -uniform a
11783 grid columnconfigure $top.buts 1 -weight 1 -uniform a
11784 grid $top.buts - - -pady 10 -sticky ew
11785 grid columnconfigure $top 2 -weight 1
11786 bind $top <Visibility> [list focus $top.buts.ok]
11789 proc choose_extdiff {} {
11790 global extdifftool
11792 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11793 if {$prog ne {}} {
11794 set extdifftool $prog
11798 proc choosecolor {v vi w x cmd} {
11799 global $v
11801 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11802 -title [mc "Gitk: choose color for %s" $x]]
11803 if {$c eq {}} return
11804 $w conf -background $c
11805 lset $v $vi $c
11806 eval $cmd $c
11809 proc setselbg {c} {
11810 global bglist cflist
11811 foreach w $bglist {
11812 if {[winfo exists $w]} {
11813 $w configure -selectbackground $c
11816 $cflist tag configure highlight \
11817 -background [$cflist cget -selectbackground]
11818 allcanvs itemconf secsel -fill $c
11821 # This sets the background color and the color scheme for the whole UI.
11822 # For some reason, tk_setPalette chooses a nasty dark red for selectColor
11823 # if we don't specify one ourselves, which makes the checkbuttons and
11824 # radiobuttons look bad. This chooses white for selectColor if the
11825 # background color is light, or black if it is dark.
11826 proc setui {c} {
11827 if {[tk windowingsystem] eq "win32"} { return }
11828 set bg [winfo rgb . $c]
11829 set selc black
11830 if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11831 set selc white
11833 tk_setPalette background $c selectColor $selc
11836 proc setbg {c} {
11837 global bglist
11839 foreach w $bglist {
11840 if {[winfo exists $w]} {
11841 $w conf -background $c
11846 proc setfg {c} {
11847 global fglist canv
11849 foreach w $fglist {
11850 if {[winfo exists $w]} {
11851 $w conf -foreground $c
11854 allcanvs itemconf text -fill $c
11855 $canv itemconf circle -outline $c
11856 $canv itemconf markid -outline $c
11859 proc prefscan {} {
11860 global oldprefs prefstop
11862 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11863 limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11864 global $v
11865 set $v $oldprefs($v)
11867 catch {destroy $prefstop}
11868 unset prefstop
11869 fontcan
11872 proc prefsok {} {
11873 global maxwidth maxgraphpct
11874 global oldprefs prefstop showneartags showlocalchanges
11875 global fontpref mainfont textfont uifont
11876 global limitdiffs treediffs perfile_attrs
11877 global hideremotes
11879 catch {destroy $prefstop}
11880 unset prefstop
11881 fontcan
11882 set fontchanged 0
11883 if {$mainfont ne $fontpref(mainfont)} {
11884 set mainfont $fontpref(mainfont)
11885 parsefont mainfont $mainfont
11886 eval font configure mainfont [fontflags mainfont]
11887 eval font configure mainfontbold [fontflags mainfont 1]
11888 setcoords
11889 set fontchanged 1
11891 if {$textfont ne $fontpref(textfont)} {
11892 set textfont $fontpref(textfont)
11893 parsefont textfont $textfont
11894 eval font configure textfont [fontflags textfont]
11895 eval font configure textfontbold [fontflags textfont 1]
11897 if {$uifont ne $fontpref(uifont)} {
11898 set uifont $fontpref(uifont)
11899 parsefont uifont $uifont
11900 eval font configure uifont [fontflags uifont]
11902 settabs
11903 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11904 if {$showlocalchanges} {
11905 doshowlocalchanges
11906 } else {
11907 dohidelocalchanges
11910 if {$limitdiffs != $oldprefs(limitdiffs) ||
11911 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11912 # treediffs elements are limited by path;
11913 # won't have encodings cached if perfile_attrs was just turned on
11914 unset -nocomplain treediffs
11916 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11917 || $maxgraphpct != $oldprefs(maxgraphpct)} {
11918 redisplay
11919 } elseif {$showneartags != $oldprefs(showneartags) ||
11920 $limitdiffs != $oldprefs(limitdiffs)} {
11921 reselectline
11923 if {$hideremotes != $oldprefs(hideremotes)} {
11924 rereadrefs
11928 proc formatdate {d} {
11929 global datetimeformat
11930 if {$d ne {}} {
11931 # If $datetimeformat includes a timezone, display in the
11932 # timezone of the argument. Otherwise, display in local time.
11933 if {[string match {*%[zZ]*} $datetimeformat]} {
11934 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11935 # Tcl < 8.5 does not support -timezone. Emulate it by
11936 # setting TZ (e.g. TZ=<-0430>+04:30).
11937 global env
11938 if {[info exists env(TZ)]} {
11939 set savedTZ $env(TZ)
11941 set zone [lindex $d 1]
11942 set sign [string map {+ - - +} [string index $zone 0]]
11943 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11944 set d [clock format [lindex $d 0] -format $datetimeformat]
11945 if {[info exists savedTZ]} {
11946 set env(TZ) $savedTZ
11947 } else {
11948 unset env(TZ)
11951 } else {
11952 set d [clock format [lindex $d 0] -format $datetimeformat]
11955 return $d
11958 # This list of encoding names and aliases is distilled from
11959 # http://www.iana.org/assignments/character-sets.
11960 # Not all of them are supported by Tcl.
11961 set encoding_aliases {
11962 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11963 ISO646-US US-ASCII us IBM367 cp367 csASCII }
11964 { ISO-10646-UTF-1 csISO10646UTF1 }
11965 { ISO_646.basic:1983 ref csISO646basic1983 }
11966 { INVARIANT csINVARIANT }
11967 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11968 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11969 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11970 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11971 { NATS-DANO iso-ir-9-1 csNATSDANO }
11972 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11973 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11974 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11975 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11976 { ISO-2022-KR csISO2022KR }
11977 { EUC-KR csEUCKR }
11978 { ISO-2022-JP csISO2022JP }
11979 { ISO-2022-JP-2 csISO2022JP2 }
11980 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11981 csISO13JISC6220jp }
11982 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11983 { IT iso-ir-15 ISO646-IT csISO15Italian }
11984 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11985 { ES iso-ir-17 ISO646-ES csISO17Spanish }
11986 { greek7-old iso-ir-18 csISO18Greek7Old }
11987 { latin-greek iso-ir-19 csISO19LatinGreek }
11988 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11989 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11990 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11991 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11992 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11993 { BS_viewdata iso-ir-47 csISO47BSViewdata }
11994 { INIS iso-ir-49 csISO49INIS }
11995 { INIS-8 iso-ir-50 csISO50INIS8 }
11996 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11997 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11998 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11999 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
12000 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
12001 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
12002 csISO60Norwegian1 }
12003 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
12004 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
12005 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
12006 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
12007 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
12008 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
12009 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
12010 { greek7 iso-ir-88 csISO88Greek7 }
12011 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
12012 { iso-ir-90 csISO90 }
12013 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
12014 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
12015 csISO92JISC62991984b }
12016 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
12017 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
12018 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
12019 csISO95JIS62291984handadd }
12020 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
12021 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
12022 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
12023 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
12024 CP819 csISOLatin1 }
12025 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
12026 { T.61-7bit iso-ir-102 csISO102T617bit }
12027 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
12028 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
12029 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
12030 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
12031 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
12032 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
12033 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
12034 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
12035 arabic csISOLatinArabic }
12036 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
12037 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
12038 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
12039 greek greek8 csISOLatinGreek }
12040 { T.101-G2 iso-ir-128 csISO128T101G2 }
12041 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
12042 csISOLatinHebrew }
12043 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
12044 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
12045 { CSN_369103 iso-ir-139 csISO139CSN369103 }
12046 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
12047 { ISO_6937-2-add iso-ir-142 csISOTextComm }
12048 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
12049 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
12050 csISOLatinCyrillic }
12051 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
12052 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
12053 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
12054 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
12055 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
12056 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
12057 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
12058 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
12059 { ISO_10367-box iso-ir-155 csISO10367Box }
12060 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
12061 { latin-lap lap iso-ir-158 csISO158Lap }
12062 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
12063 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
12064 { us-dk csUSDK }
12065 { dk-us csDKUS }
12066 { JIS_X0201 X0201 csHalfWidthKatakana }
12067 { KSC5636 ISO646-KR csKSC5636 }
12068 { ISO-10646-UCS-2 csUnicode }
12069 { ISO-10646-UCS-4 csUCS4 }
12070 { DEC-MCS dec csDECMCS }
12071 { hp-roman8 roman8 r8 csHPRoman8 }
12072 { macintosh mac csMacintosh }
12073 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
12074 csIBM037 }
12075 { IBM038 EBCDIC-INT cp038 csIBM038 }
12076 { IBM273 CP273 csIBM273 }
12077 { IBM274 EBCDIC-BE CP274 csIBM274 }
12078 { IBM275 EBCDIC-BR cp275 csIBM275 }
12079 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
12080 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
12081 { IBM280 CP280 ebcdic-cp-it csIBM280 }
12082 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
12083 { IBM284 CP284 ebcdic-cp-es csIBM284 }
12084 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
12085 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
12086 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
12087 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
12088 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
12089 { IBM424 cp424 ebcdic-cp-he csIBM424 }
12090 { IBM437 cp437 437 csPC8CodePage437 }
12091 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
12092 { IBM775 cp775 csPC775Baltic }
12093 { IBM850 cp850 850 csPC850Multilingual }
12094 { IBM851 cp851 851 csIBM851 }
12095 { IBM852 cp852 852 csPCp852 }
12096 { IBM855 cp855 855 csIBM855 }
12097 { IBM857 cp857 857 csIBM857 }
12098 { IBM860 cp860 860 csIBM860 }
12099 { IBM861 cp861 861 cp-is csIBM861 }
12100 { IBM862 cp862 862 csPC862LatinHebrew }
12101 { IBM863 cp863 863 csIBM863 }
12102 { IBM864 cp864 csIBM864 }
12103 { IBM865 cp865 865 csIBM865 }
12104 { IBM866 cp866 866 csIBM866 }
12105 { IBM868 CP868 cp-ar csIBM868 }
12106 { IBM869 cp869 869 cp-gr csIBM869 }
12107 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
12108 { IBM871 CP871 ebcdic-cp-is csIBM871 }
12109 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
12110 { IBM891 cp891 csIBM891 }
12111 { IBM903 cp903 csIBM903 }
12112 { IBM904 cp904 904 csIBBM904 }
12113 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
12114 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
12115 { IBM1026 CP1026 csIBM1026 }
12116 { EBCDIC-AT-DE csIBMEBCDICATDE }
12117 { EBCDIC-AT-DE-A csEBCDICATDEA }
12118 { EBCDIC-CA-FR csEBCDICCAFR }
12119 { EBCDIC-DK-NO csEBCDICDKNO }
12120 { EBCDIC-DK-NO-A csEBCDICDKNOA }
12121 { EBCDIC-FI-SE csEBCDICFISE }
12122 { EBCDIC-FI-SE-A csEBCDICFISEA }
12123 { EBCDIC-FR csEBCDICFR }
12124 { EBCDIC-IT csEBCDICIT }
12125 { EBCDIC-PT csEBCDICPT }
12126 { EBCDIC-ES csEBCDICES }
12127 { EBCDIC-ES-A csEBCDICESA }
12128 { EBCDIC-ES-S csEBCDICESS }
12129 { EBCDIC-UK csEBCDICUK }
12130 { EBCDIC-US csEBCDICUS }
12131 { UNKNOWN-8BIT csUnknown8BiT }
12132 { MNEMONIC csMnemonic }
12133 { MNEM csMnem }
12134 { VISCII csVISCII }
12135 { VIQR csVIQR }
12136 { KOI8-R csKOI8R }
12137 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
12138 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
12139 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
12140 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
12141 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
12142 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
12143 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
12144 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
12145 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
12146 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
12147 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
12148 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
12149 { IBM1047 IBM-1047 }
12150 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
12151 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
12152 { UNICODE-1-1 csUnicode11 }
12153 { CESU-8 csCESU-8 }
12154 { BOCU-1 csBOCU-1 }
12155 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
12156 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
12157 l8 }
12158 { ISO-8859-15 ISO_8859-15 Latin-9 }
12159 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
12160 { GBK CP936 MS936 windows-936 }
12161 { JIS_Encoding csJISEncoding }
12162 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
12163 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
12164 EUC-JP }
12165 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
12166 { ISO-10646-UCS-Basic csUnicodeASCII }
12167 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
12168 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
12169 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
12170 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
12171 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
12172 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
12173 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
12174 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
12175 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
12176 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
12177 { Adobe-Standard-Encoding csAdobeStandardEncoding }
12178 { Ventura-US csVenturaUS }
12179 { Ventura-International csVenturaInternational }
12180 { PC8-Danish-Norwegian csPC8DanishNorwegian }
12181 { PC8-Turkish csPC8Turkish }
12182 { IBM-Symbols csIBMSymbols }
12183 { IBM-Thai csIBMThai }
12184 { HP-Legal csHPLegal }
12185 { HP-Pi-font csHPPiFont }
12186 { HP-Math8 csHPMath8 }
12187 { Adobe-Symbol-Encoding csHPPSMath }
12188 { HP-DeskTop csHPDesktop }
12189 { Ventura-Math csVenturaMath }
12190 { Microsoft-Publishing csMicrosoftPublishing }
12191 { Windows-31J csWindows31J }
12192 { GB2312 csGB2312 }
12193 { Big5 csBig5 }
12196 proc tcl_encoding {enc} {
12197 global encoding_aliases tcl_encoding_cache
12198 if {[info exists tcl_encoding_cache($enc)]} {
12199 return $tcl_encoding_cache($enc)
12201 set names [encoding names]
12202 set lcnames [string tolower $names]
12203 set enc [string tolower $enc]
12204 set i [lsearch -exact $lcnames $enc]
12205 if {$i < 0} {
12206 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
12207 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
12208 set i [lsearch -exact $lcnames $encx]
12211 if {$i < 0} {
12212 foreach l $encoding_aliases {
12213 set ll [string tolower $l]
12214 if {[lsearch -exact $ll $enc] < 0} continue
12215 # look through the aliases for one that tcl knows about
12216 foreach e $ll {
12217 set i [lsearch -exact $lcnames $e]
12218 if {$i < 0} {
12219 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
12220 set i [lsearch -exact $lcnames $ex]
12223 if {$i >= 0} break
12225 break
12228 set tclenc {}
12229 if {$i >= 0} {
12230 set tclenc [lindex $names $i]
12232 set tcl_encoding_cache($enc) $tclenc
12233 return $tclenc
12236 proc gitattr {path attr default} {
12237 global path_attr_cache
12238 if {[info exists path_attr_cache($attr,$path)]} {
12239 set r $path_attr_cache($attr,$path)
12240 } else {
12241 set r "unspecified"
12242 if {![catch {set line [exec git check-attr $attr -- $path]}]} {
12243 regexp "(.*): $attr: (.*)" $line m f r
12245 set path_attr_cache($attr,$path) $r
12247 if {$r eq "unspecified"} {
12248 return $default
12250 return $r
12253 proc cache_gitattr {attr pathlist} {
12254 global path_attr_cache
12255 set newlist {}
12256 foreach path $pathlist {
12257 if {![info exists path_attr_cache($attr,$path)]} {
12258 lappend newlist $path
12261 set lim 1000
12262 if {[tk windowingsystem] == "win32"} {
12263 # windows has a 32k limit on the arguments to a command...
12264 set lim 30
12266 while {$newlist ne {}} {
12267 set head [lrange $newlist 0 [expr {$lim - 1}]]
12268 set newlist [lrange $newlist $lim end]
12269 if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
12270 foreach row [split $rlist "\n"] {
12271 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12272 if {[string index $path 0] eq "\""} {
12273 set path [encoding convertfrom [lindex $path 0]]
12275 set path_attr_cache($attr,$path) $value
12282 proc get_path_encoding {path} {
12283 global gui_encoding perfile_attrs
12284 set tcl_enc $gui_encoding
12285 if {$path ne {} && $perfile_attrs} {
12286 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12287 if {$enc2 ne {}} {
12288 set tcl_enc $enc2
12291 return $tcl_enc
12294 ## For msgcat loading, first locate the installation location.
12295 if { [info exists ::env(GITK_MSGSDIR)] } {
12296 ## Msgsdir was manually set in the environment.
12297 set gitk_msgsdir $::env(GITK_MSGSDIR)
12298 } else {
12299 ## Let's guess the prefix from argv0.
12300 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12301 set gitk_libdir [file join $gitk_prefix share gitk lib]
12302 set gitk_msgsdir [file join $gitk_libdir msgs]
12303 unset gitk_prefix
12306 ## Internationalization (i18n) through msgcat and gettext. See
12307 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12308 package require msgcat
12309 namespace import ::msgcat::mc
12310 ## And eventually load the actual message catalog
12311 ::msgcat::mcload $gitk_msgsdir
12313 # First check that Tcl/Tk is recent enough
12314 if {[catch {package require Tk 8.4} err]} {
12315 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
12316 Gitk requires at least Tcl/Tk 8.4."]
12317 exit 1
12320 # on OSX bring the current Wish process window to front
12321 if {[tk windowingsystem] eq "aqua"} {
12322 exec osascript -e [format {
12323 tell application "System Events"
12324 set frontmost of processes whose unix id is %d to true
12325 end tell
12326 } [pid] ]
12329 # Unset GIT_TRACE var if set
12330 if { [info exists ::env(GIT_TRACE)] } {
12331 unset ::env(GIT_TRACE)
12334 # defaults...
12335 set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12337 set gitencoding {}
12338 catch {
12339 set gitencoding [exec git config --get i18n.commitencoding]
12341 catch {
12342 set gitencoding [exec git config --get i18n.logoutputencoding]
12344 if {$gitencoding == ""} {
12345 set gitencoding "utf-8"
12347 set tclencoding [tcl_encoding $gitencoding]
12348 if {$tclencoding == {}} {
12349 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12352 set gui_encoding [encoding system]
12353 catch {
12354 set enc [exec git config --get gui.encoding]
12355 if {$enc ne {}} {
12356 set tclenc [tcl_encoding $enc]
12357 if {$tclenc ne {}} {
12358 set gui_encoding $tclenc
12359 } else {
12360 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12365 set log_showroot true
12366 catch {
12367 set log_showroot [exec git config --bool --get log.showroot]
12370 if {[tk windowingsystem] eq "aqua"} {
12371 set mainfont {{Lucida Grande} 9}
12372 set textfont {Monaco 9}
12373 set uifont {{Lucida Grande} 9 bold}
12374 } elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12375 # fontconfig!
12376 set mainfont {sans 9}
12377 set textfont {monospace 9}
12378 set uifont {sans 9 bold}
12379 } else {
12380 set mainfont {Helvetica 9}
12381 set textfont {Courier 9}
12382 set uifont {Helvetica 9 bold}
12384 set tabstop 8
12385 set findmergefiles 0
12386 set maxgraphpct 50
12387 set maxwidth 16
12388 set revlistorder 0
12389 set fastdate 0
12390 set uparrowlen 5
12391 set downarrowlen 5
12392 set mingaplen 100
12393 set cmitmode "patch"
12394 set wrapcomment "none"
12395 set showneartags 1
12396 set hideremotes 0
12397 set maxrefs 20
12398 set visiblerefs {"master"}
12399 set maxlinelen 200
12400 set showlocalchanges 1
12401 set limitdiffs 1
12402 set datetimeformat "%Y-%m-%d %H:%M:%S"
12403 set autoselect 1
12404 set autosellen 40
12405 set perfile_attrs 0
12406 set want_ttk 1
12408 if {[tk windowingsystem] eq "aqua"} {
12409 set extdifftool "opendiff"
12410 } else {
12411 set extdifftool "meld"
12414 set colors {"#00ff00" red blue magenta darkgrey brown orange}
12415 if {[tk windowingsystem] eq "win32"} {
12416 set uicolor SystemButtonFace
12417 set uifgcolor SystemButtonText
12418 set uifgdisabledcolor SystemDisabledText
12419 set bgcolor SystemWindow
12420 set fgcolor SystemWindowText
12421 set selectbgcolor SystemHighlight
12422 set web_browser "cmd /c start"
12423 } else {
12424 set uicolor grey85
12425 set uifgcolor black
12426 set uifgdisabledcolor "#999"
12427 set bgcolor white
12428 set fgcolor black
12429 set selectbgcolor gray85
12430 if {[tk windowingsystem] eq "aqua"} {
12431 set web_browser "open"
12432 } else {
12433 set web_browser "xdg-open"
12436 set diffcolors {"#c30000" "#009800" blue}
12437 set diffbgcolors {"#fff3f3" "#f0fff0"}
12438 set diffcontext 3
12439 set mergecolors {red blue "#00ff00" purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12440 set ignorespace 0
12441 set worddiff ""
12442 set markbgcolor "#e0e0ff"
12444 set headbgcolor "#00ff00"
12445 set headfgcolor black
12446 set headoutlinecolor black
12447 set remotebgcolor #ffddaa
12448 set tagbgcolor yellow
12449 set tagfgcolor black
12450 set tagoutlinecolor black
12451 set reflinecolor black
12452 set filesepbgcolor #aaaaaa
12453 set filesepfgcolor black
12454 set linehoverbgcolor #ffff80
12455 set linehoverfgcolor black
12456 set linehoveroutlinecolor black
12457 set mainheadcirclecolor yellow
12458 set workingfilescirclecolor red
12459 set indexcirclecolor "#00ff00"
12460 set circlecolors {white blue gray blue blue}
12461 set linkfgcolor blue
12462 set circleoutlinecolor $fgcolor
12463 set foundbgcolor yellow
12464 set currentsearchhitbgcolor orange
12466 # button for popping up context menus
12467 if {[tk windowingsystem] eq "aqua"} {
12468 set ctxbut <Button-2>
12469 } else {
12470 set ctxbut <Button-3>
12473 catch {
12474 # follow the XDG base directory specification by default. See
12475 # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12476 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12477 # XDG_CONFIG_HOME environment variable is set
12478 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12479 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12480 } else {
12481 # default XDG_CONFIG_HOME
12482 set config_file "~/.config/git/gitk"
12483 set config_file_tmp "~/.config/git/gitk-tmp"
12485 if {![file exists $config_file]} {
12486 # for backward compatibility use the old config file if it exists
12487 if {[file exists "~/.gitk"]} {
12488 set config_file "~/.gitk"
12489 set config_file_tmp "~/.gitk-tmp"
12490 } elseif {![file exists [file dirname $config_file]]} {
12491 file mkdir [file dirname $config_file]
12494 source $config_file
12496 config_check_tmp_exists 50
12498 set config_variables {
12499 mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12500 cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12501 hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12502 bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12503 markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12504 extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12505 remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12506 filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12507 linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12508 indexcirclecolor circlecolors linkfgcolor circleoutlinecolor diffbgcolors
12509 web_browser
12511 foreach var $config_variables {
12512 config_init_trace $var
12513 trace add variable $var write config_variable_change_cb
12516 parsefont mainfont $mainfont
12517 eval font create mainfont [fontflags mainfont]
12518 eval font create mainfontbold [fontflags mainfont 1]
12520 parsefont textfont $textfont
12521 eval font create textfont [fontflags textfont]
12522 eval font create textfontbold [fontflags textfont 1]
12524 parsefont uifont $uifont
12525 eval font create uifont [fontflags uifont]
12527 setui $uicolor
12529 setoptions
12531 # check that we can find a .git directory somewhere...
12532 if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12533 show_error {} . [mc "Cannot find a git repository here."]
12534 exit 1
12537 set selecthead {}
12538 set selectheadid {}
12540 set revtreeargs {}
12541 set cmdline_files {}
12542 set i 0
12543 set revtreeargscmd {}
12544 foreach arg $argv {
12545 switch -glob -- $arg {
12546 "" { }
12547 "--" {
12548 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12549 break
12551 "--select-commit=*" {
12552 set selecthead [string range $arg 16 end]
12554 "--argscmd=*" {
12555 set revtreeargscmd [string range $arg 10 end]
12557 default {
12558 lappend revtreeargs $arg
12561 incr i
12564 if {$selecthead eq "HEAD"} {
12565 set selecthead {}
12568 if {$i >= [llength $argv] && $revtreeargs ne {}} {
12569 # no -- on command line, but some arguments (other than --argscmd)
12570 if {[catch {
12571 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12572 set cmdline_files [split $f "\n"]
12573 set n [llength $cmdline_files]
12574 set revtreeargs [lrange $revtreeargs 0 end-$n]
12575 # Unfortunately git rev-parse doesn't produce an error when
12576 # something is both a revision and a filename. To be consistent
12577 # with git log and git rev-list, check revtreeargs for filenames.
12578 foreach arg $revtreeargs {
12579 if {[file exists $arg]} {
12580 show_error {} . [mc "Ambiguous argument '%s': both revision\
12581 and filename" $arg]
12582 exit 1
12585 } err]} {
12586 # unfortunately we get both stdout and stderr in $err,
12587 # so look for "fatal:".
12588 set i [string first "fatal:" $err]
12589 if {$i > 0} {
12590 set err [string range $err [expr {$i + 6}] end]
12592 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12593 exit 1
12597 set nullid "0000000000000000000000000000000000000000"
12598 set nullid2 "0000000000000000000000000000000000000001"
12599 set nullfile "/dev/null"
12601 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12602 if {![info exists have_ttk]} {
12603 set have_ttk [llength [info commands ::ttk::style]]
12605 set use_ttk [expr {$have_ttk && $want_ttk}]
12606 set NS [expr {$use_ttk ? "ttk" : ""}]
12608 if {$use_ttk} {
12609 setttkstyle
12612 regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12614 set show_notes {}
12615 if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12616 set show_notes "--show-notes"
12619 set appname "gitk"
12621 set runq {}
12622 set history {}
12623 set historyindex 0
12624 set fh_serial 0
12625 set nhl_names {}
12626 set highlight_paths {}
12627 set findpattern {}
12628 set searchdirn -forwards
12629 set boldids {}
12630 set boldnameids {}
12631 set diffelide {0 0}
12632 set markingmatches 0
12633 set linkentercount 0
12634 set need_redisplay 0
12635 set nrows_drawn 0
12636 set firsttabstop 0
12638 set nextviewnum 1
12639 set curview 0
12640 set selectedview 0
12641 set selectedhlview [mc "None"]
12642 set highlight_related [mc "None"]
12643 set highlight_files {}
12644 set viewfiles(0) {}
12645 set viewperm(0) 0
12646 set viewchanged(0) 0
12647 set viewargs(0) {}
12648 set viewargscmd(0) {}
12650 set selectedline {}
12651 set numcommits 0
12652 set loginstance 0
12653 set cmdlineok 0
12654 set stopped 0
12655 set stuffsaved 0
12656 set patchnum 0
12657 set lserial 0
12658 set hasworktree [hasworktree]
12659 set cdup {}
12660 if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12661 set cdup [exec git rev-parse --show-cdup]
12663 set worktree [gitworktree]
12664 setcoords
12665 makewindow
12666 catch {
12667 image create photo gitlogo -width 16 -height 16
12669 image create photo gitlogominus -width 4 -height 2
12670 gitlogominus put #C00000 -to 0 0 4 2
12671 gitlogo copy gitlogominus -to 1 5
12672 gitlogo copy gitlogominus -to 6 5
12673 gitlogo copy gitlogominus -to 11 5
12674 image delete gitlogominus
12676 image create photo gitlogoplus -width 4 -height 4
12677 gitlogoplus put #008000 -to 1 0 3 4
12678 gitlogoplus put #008000 -to 0 1 4 3
12679 gitlogo copy gitlogoplus -to 1 9
12680 gitlogo copy gitlogoplus -to 6 9
12681 gitlogo copy gitlogoplus -to 11 9
12682 image delete gitlogoplus
12684 image create photo gitlogo32 -width 32 -height 32
12685 gitlogo32 copy gitlogo -zoom 2 2
12687 wm iconphoto . -default gitlogo gitlogo32
12689 # wait for the window to become visible
12690 tkwait visibility .
12691 set_window_title
12692 update
12693 readrefs
12695 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12696 # create a view for the files/dirs specified on the command line
12697 set curview 1
12698 set selectedview 1
12699 set nextviewnum 2
12700 set viewname(1) [mc "Command line"]
12701 set viewfiles(1) $cmdline_files
12702 set viewargs(1) $revtreeargs
12703 set viewargscmd(1) $revtreeargscmd
12704 set viewperm(1) 0
12705 set viewchanged(1) 0
12706 set vdatemode(1) 0
12707 addviewmenu 1
12708 .bar.view entryconf [mca "&Edit view..."] -state normal
12709 .bar.view entryconf [mca "&Delete view"] -state normal
12712 if {[info exists permviews]} {
12713 foreach v $permviews {
12714 set n $nextviewnum
12715 incr nextviewnum
12716 set viewname($n) [lindex $v 0]
12717 set viewfiles($n) [lindex $v 1]
12718 set viewargs($n) [lindex $v 2]
12719 set viewargscmd($n) [lindex $v 3]
12720 set viewperm($n) 1
12721 set viewchanged($n) 0
12722 addviewmenu $n
12726 if {[tk windowingsystem] eq "win32"} {
12727 focus -force .
12730 getcommits {}
12732 # Local variables:
12733 # mode: tcl
12734 # indent-tabs-mode: t
12735 # tab-width: 8
12736 # End: